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