mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 00:29:45 +00:00
1 line
19 KiB
Plaintext
Executable File
1 line
19 KiB
Plaintext
Executable File
\ loadscreen fuer ATARI 8bit cas16jan07\ 800 / 600 XL / 800 XL / 1200 XL / 130 XE / 65 XE / 800 XE 1 &13 +thru \ 65KEY? GETKEY cas16jan07 | $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) cas09jan07$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 ) cca16jan07 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) cas09jan07 | &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 @ ; \ cas16jan07 | : 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 \ FileInterface cas16jan07\ definitions for fileinterface &4 CONSTANT R/O &8 CONSTANT W/O &12 CONSTANT R/W | 3 CONSTANT COPEN | 5 CONSTANT CGTXTR | 7 CONSTANT CGBINR | 9 CONSTANT CPTXTR | $B CONSTANT CPBINR | $C CONSTANT CCLOSE | $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 cas16jan07 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 \ definitions for fileinterface cas16jan07code XIO ( aux2 aux1 addr len com ch# -- len ior ) sp x) LDA .A ASL .A ASL .A ASL .A ASL TAX 2 # ldy sp )y lda ICCOM ,x sta iny iny ( store command ) sp )y lda ICBLL ,x sta iny ( length ) sp )y lda ICBLH ,x sta iny sp )y lda ICBAL ,x sta iny ( address ) sp )y lda ICBAH ,x sta iny sp )y lda ICAX1 ,x sta iny iny ( aux1 ) sp )y lda ICAX2 ,x sta ( aux2 ) CIOV jsr sp DUP LDA CLC # 8 ADC DUP STA CS ?[ SWAP 1+ INC ]? 0 # ldy ICSTA ,x lda sp )y sta ( ior ) 0>= ?[ 0 # lda sp )y sta ]? tya iny sp )y sta iny ICBLL ,x lda sp )y sta iny ICBLH ,x lda sp )y sta xynext jmp end-code \ definitions for fileinterface cas16jan07 : open-file ( caddr u fam -- fileid ior ) -ROT 0 3 -ROLL COPEN freeiocb DUP >R XIO NIP R> SWAP ; : close-file ( fileid -- ior ) >R 0 0 0 0 CCLOSE R> XIO NIP ; | : (DOFILE ( caddr u fileid cmd -- u2 ior ) .S CR SWAP 0 4 -ROLL 0 4 -ROLL .S KEY DROP XIO ; : read-file ( caddr u fileid -- u2 ior ) CGBINR (DOFILE ; : write-file ( caddr u fileid -- ior ) CPBINR (DOFILE NIP ; \ definitions for fileinterface cas16jan07 : read-line ( caddr u1 fileid -- u2 flag ior ) CGTXTR (DOFILE DUP =0 SWAP ; : write-line ( caddr u fileid -- ior ) CPTXTR (DOFILE NIP ; VARIABLE SOURCE-ID 0 SOURCE-ID ! $580 CONSTANT FNBUF : REFILL ( -- flag ) tib $50 erase tib $50 SOURCE-ID @ READ-LINE ROT 1- #tib ! >in off nip ; \ definitions for fileinterface cas16jan07: FILEABORT ( ior -- ) DUP $80 > IF ." IO-Error:" . ABORT ELSE DROP THEN ; : INCLUDE-FILE ( fileid -- ) SOURCE-ID ! BEGIN REFILL $80 < WHILE INTERPRET REPEAT SOURCE-ID @ CLOSE-FILE FILEABORT ; : INCLUDED ( caddr u -- ) SOURCE-ID @ >R R/O OPEN-FILE DUP $80 < IF DROP INCLUDE-FILE HERE $50 ERASE #TIB @ >IN ! ELSE ." IO-Error:" . 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 \ cas16jan07 \ cas21dec05 |