mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
305 lines
5.3 KiB
Plaintext
Executable File
305 lines
5.3 KiB
Plaintext
Executable File
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ loadscreen fuer ATARI 8bit cas11aug06
|
|
\ 800 / 600 XL / 800 XL / 1200 XL / 130 XE / 65 XE / 800 XE
|
|
|
|
1 &14 +thru
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ 65KEY? GETKEY cas11aug06
|
|
|
|
| $02FC Constant CH
|
|
| CODE 65KEY? ( -- FLAG) CH lda clc 1 # adc push0a jmp end-code
|
|
|
|
LABEL GETCHK $E425 lda pha $E424 lda pha rts
|
|
| CODE GETKEY ( -- 8B) $FF sty $FE stx GETCHK jsr
|
|
$FE ldx $FF ldy push0a jmp end-code
|
|
|
|
| $02F0 Constant CRSINH
|
|
| CODE CURON ( --) 01 # lda
|
|
LABEL CRS01 CRSINH sta NEXT JMP END-CODE
|
|
| CODE CUROFF ( --) 00 # lda CRS01 JMP END-CODE
|
|
|
|
: 65KEY ( -- 8B)
|
|
CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ;
|
|
\ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05
|
|
7E CONSTANT #BS $9B CONSTANT #CR &27 CONSTANT #ESC
|
|
|
|
: 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2)
|
|
#BS CASE? IF DUP IF DEL 1- THEN EXIT THEN
|
|
#CR CASE? IF DUP SPAN ! EXIT THEN
|
|
>R 2DUP + R@ SWAP C! R> EMIT 1+ ;
|
|
|
|
: 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0
|
|
BEGIN DUP SPAN @ U<
|
|
WHILE KEY DECODE
|
|
REPEAT 2DROP SPACE ;
|
|
|
|
INPUT: KEYBOARD [ HERE INPUT ! ]
|
|
65KEY 65KEY? 65DECODE 65EXPECT [
|
|
|
|
\ (emit 65emit ) cas11aug06
|
|
|
|
LABEL OUTCHK
|
|
$E407 lda pha $E406 lda pha txa rts
|
|
|
|
Code (emit ( 8b -- ) $FF sty $FE stx
|
|
SP X) lda tax OUTCHK jsr
|
|
$FE ldx $FF ldy (drop jmp end-code
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas13aug06
|
|
|
|
| &40 Constant c/row
|
|
|
|
: 65emit ( 8b -- ) (emit ;
|
|
|
|
: 65CR #CR 65emit ;
|
|
|
|
: 65DEL #bs 65emit SPACE #bs 65emit ;
|
|
|
|
: 65PAGE &125 EMIT ;
|
|
|
|
: 65at ( row col -- ) $55 ! $54 C! ;
|
|
|
|
: 65AT? ( -- ROW COL ) $54 C@ $55 @ ;
|
|
|
|
\ er14dez88
|
|
|
|
: 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ TYPE DISPLAY (BYE BP 28MAY85RE) cas09dec05
|
|
|
|
OUTPUT: DISPLAY [ HERE OUTPUT ! ]
|
|
65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [
|
|
|
|
\ fix dosini vector and jump through dosvec
|
|
| code (bye warmboot 1+ lda $0C sta warmboot 2+ lda
|
|
$0D sta $000A ) jmp end-code
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ B/BLK cas21dec05
|
|
|
|
$400 CONSTANT B/BLK
|
|
|
|
\ definitions for fileinterface
|
|
|
|
&4 CONSTANT R/O &8 CONSTANT W/O &12 CONSTANT R/W
|
|
3 CONSTANT IO-OPEN 5 CONSTANT IO-GETREC 7 CONSTANT IO-GETCHR
|
|
9 CONSTANT IO-PUTREC $B CONSTANT IO-PUTCHR $C CONSTANT IO-CLOSE
|
|
|
|
$340 CONSTANT ICFLG $342 CONSTANT ICCOM $343 CONSTANT ICSTA
|
|
$344 CONSTANT ICBAL $345 CONSTANT ICBAH $348 CONSTANT ICBLL
|
|
$349 CONSTANT ICBLH $34A CONSTANT ICAX1 $34B CONSTANT ICAX2
|
|
$E456 CONSTANT CIOV
|
|
|
|
|
|
\ definitions for fileinterface cas11aug06
|
|
|
|
label freeiocb0 70 # lda label freeiocb2 tay ICFLG ,y lda
|
|
$FF # cmp 0<> ?[ tya sec $10 # sbc freeiocb2 bne ]?
|
|
tya rts
|
|
|
|
code freeiocb freeiocb0 jsr .a lsr .a lsr .a lsr .a lsr pha
|
|
push0a jmp end-code
|
|
|
|
label getfileid sp x) lda .a ASL .a ASL .a ASL .a ASL tay rts
|
|
|
|
label getparam 2 # ldy sp )y lda ICBLL ,x sta
|
|
iny sp )y lda ICBLH ,x sta
|
|
iny sp )y lda ICBAL ,x sta
|
|
iny sp )y lda ICBAH ,x sta
|
|
rts
|
|
\ definitions for fileinterface cas13dec05
|
|
|
|
code close-file getfileid jsr tax IO-CLOSE # lda ICCOM ,x sta
|
|
CIOV jsr sp 2inc ICSTA ,x lda 0>= ?[ 0 # lda ]? pha
|
|
PUSH0A jmp end-code
|
|
|
|
code open-file freeiocb0 jsr tax IO-OPEN # lda ICCOM ,y sta
|
|
4 # ldy sp )y lda ICBAL ,x sta
|
|
iny sp )y lda ICBAH ,x sta
|
|
0 # ldy sp )y lda ICAX1 ,x sta
|
|
tya ICAX2 ,x sta
|
|
CIOV jsr sp 2inc 0 # ldy ICSTA ,x lda sp )y sta
|
|
0>= ?[ 0 # lda sp )y sta ]? 0 # lda tay iny sp )y sta
|
|
iny iny sp )y sta txa clc .a lsr .a lsr .a lsr
|
|
.a lsr dey sp )y sta xynext jmp end-code
|
|
|
|
\ definitions for fileinterface cas11aug06
|
|
|
|
code read-file ( caddr u fileid -- u2 ior )
|
|
getfileid jsr tax getparam jsr
|
|
IO-GETCHR # lda ICCOM ,x sta
|
|
CIOV jsr sp 2inc 0 # ldy
|
|
ICSTA ,x lda sp )y sta
|
|
0>= ?[ 0 # lda sp )y sta ]? tya iny sp )y sta
|
|
clc iny ICBLL ,x lda sp )y sta
|
|
iny ICBLH ,x lda sp )y sta xynext jmp end-code
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ definitions for fileinterface cas11aug06
|
|
|
|
code read-line ( caddr u fileid -- u2 flag ior )
|
|
getfileid jsr tax getparam jsr
|
|
IO-GETREC # lda ICCOM ,x sta
|
|
CIOV jsr 0 # ldy
|
|
ICSTA ,x lda
|
|
0>= ?[ tya ]? sp )y sta
|
|
4 # ldy ICBLL ,x lda sp )y sta
|
|
ICBAL ,x adc tay dey n sty 5 # ldy ICBLH ,x lda sp )y sta
|
|
ICBAH ,x adc n 1+ sta 0 # lda tay n )y sta iny
|
|
sp )y sta iny sp )y sta iny sp )y sta xynext jmp end-code
|
|
|
|
|
|
|
|
|
|
\ definitions for fileinterface cas11aug06
|
|
|
|
code write-file ( caddr u fileid -- ior )
|
|
getfileid jsr tax getparam jsr
|
|
IO-PUTCHR # lda ICCOM ,x sta
|
|
CIOV jsr sp 2inc sp 2inc 0 # ldy
|
|
ICSTA ,x lda sp )y sta
|
|
0>= ?[ 0 # lda sp )y sta ]?
|
|
xynext jmp end-code
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ definitions for fileinterface cas11aug06
|
|
VARIABLE SOURCE-ID 0 SOURCE-ID !
|
|
$580 CONSTANT FNBUF
|
|
: REFILL tib $50 erase tib $50 SOURCE-ID @ READ-LINE
|
|
ROT 1 - #tib ! >in off blk off nip ;
|
|
: INCLUDE-FILE ( fileid -- )
|
|
SOURCE-ID ! BEGIN REFILL $80 < WHILE INTERPRET REPEAT
|
|
SOURCE-ID @ CLOSE-FILE ABORT" File Error" ;
|
|
: INCLUDED ( caddr u -- )
|
|
SOURCE-ID @ >R R/O OPEN-FILE DUP $80 < IF DROP
|
|
INCLUDE-FILE HERE $50 ERASE #TIB @ >IN ! ELSE
|
|
." FileError:" . ABORT THEN R> SOURCE-ID ! ;
|
|
: FILE" FNBUF $50 BL FILL HERE $50 BL FILL ASCII " WORD
|
|
COUNT FNBUF SWAP CMOVE FNBUF 0 ;
|
|
: INCLUDE" ( FNAME ) FILE" INCLUDED ; IMMEDIATE
|
|
|
|
\ cas21dec05
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|