PRT2C ok 128 0 pall ATARIVF.FB Scr 0 Dr 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 ende 123 14 15 ATARIVF.FB Scr 1 Dr 0 0 \ Atari 8bit VolksForth Kernel cas02jan07 1 forth definitions 2 : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE 3 4 $2200 DISPLACE ! \ Memory Start Address = $2200 5 TARGET DEFINITIONS $2200 HERE! 6 7 HEX 8 &01 &126 +THRU 9 decimal 10 \ ASSEMBLER NONRELOCATE 11 12 CR .( Unresolved: ) 13 .UNRESOLVED CR CR 14 15 CR .( SAVE-TARGET 6502-FORTH83) ATARIVF.FB Scr 2 Dr 0 0 \ FORTH PREAMBLE AND ID 10JAN85BP) cas11aug06 1 2 ASSEMBLER 3 NOP 0 JMP HERE 2- >LABEL >COLD 4 NOP 0 JMP HERE 2- >LABEL >RESTART 5 6 HERE DUP ORIGIN! 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 3 Dr 0 0 \ USERVARIABLES AND COLDSTART VALUES cas10jan07 1 2 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 3 4 $0D6 ALLOT 5 6 | CREATE LOGO ," volksFORTH-83 Rev. 3.81.4 10jan07" 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 4 Dr 0 0 \ ZERO PAGE VARIABLES & NEXT 03APR85BP) cas11aug06 1 \ Zero Page $A0 - $C8 used 2 A0 DUP >LABEL RP 2+ \ RP = $A0 3 DUP >LABEL UP 2+ \ UP = $A2 4 DUP >LABEL PUTA 1+ \ PUTA = $A4 5 DUP >LABEL SP 2+ \ SP = $A5 6 DUP >LABEL NEXT \ NEXT = $A7 7 DUP 5 + >LABEL IP \ IP = $AB 8 13 + >LABEL W \ W = $BE 9 W 8 + >LABEL N \ N = $C6 10 11 12 13 14 15 ATARIVF.FB Scr 5 Dr 0 0 \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) 1 2 LABEL BOOTNEXT 3 -1 STA \ -1 IS DUMMY SP 4 IP )Y LDA W 1+ STA 5 -1 LDA W STA \ -1 IS DUMMY IP 6 CLC IP LDA 2 # ADC IP STA 7 CS NOT ?[ LABEL WJMP -1 ) JMP ]? 8 IP 1+ INC WJMP BCS END-CODE 9 10 11 12 13 14 15 ATARIVF.FB Scr 6 Dr 0 0 \ 08jab07cas 1 HERE BOOTNEXT - >LABEL BOOTNEXTLEN 2 3 CODE END-TRACE ( PATCH NEXT FOR TRACE ) 4 $A5 # LDA NEXT $A + STA 5 IP # LDA NEXT $B + STA 6 $69 # LDA NEXT $C + STA 7 $02 # LDA NEXT $D + STA 8 NEXT JMP END-CODE 9 10 11 12 13 14 15 ATARIVF.FB Scr 7 Dr 0 0 \ ;C: NOOP 08jab07cas 1 2 CREATE RECOVER ( -- addr ) ASSEMBLER 3 PLA W STA PLA W 1+ STA 4 W WDEC 0 JMP END-CODE 5 6 HERE 2- >LABEL >RECOVER 7 \ HANDCRAFTED FORWARD REFERENCE FOR JMP COMMAND 8 9 COMPILER ASSEMBLER ALSO DEFINITIONS 10 H : ;C: 0 T RECOVER JSR 11 END-CODE ] H ; 12 TARGET 13 CODE NOOP NEXT HERE 2- ! END-CODE 14 15 ATARIVF.FB Scr 8 Dr 0 0 \ USER VARIABLES 17MAR84KS) 08jab07cas 1 2 CONSTANT ORIGIN 8 UALLOT DROP 3 \ FOR MULTITASKER 4 \ DATASTACK = $7000 5 \ RETURNSTACK = $7500 6 USER S0 $7000 S0 ! USER R0 $7500 R0 ! 7 USER DP USER OFFSET 0 OFFSET ! 8 USER BASE &10 BASE ! USER OUTPUT 9 USER INPUT 10 USER ERRORHANDLER \ POINTER FOR ABORT" -CODE 11 USER VOC-LINK 12 USER UDP \ POINTS TO NEXT FREE ADDR IN USER 13 14 15 ATARIVF.FB Scr 9 Dr 0 0 \ MANIPULATE SYSTEM POINTERS 29JAN85BP) 1 2 CODE SP@ ( -- ADDR) 3 SP LDA N STA SP 1+ LDA N 1+ STA 4 N # LDX 5 LABEL XPUSH 6 SP 2DEC 1 ,X LDA SP )Y STA 7 0 ,X LDA 0 # LDX PUTA JMP END-CODE 8 9 CODE SP! ( ADDR --) 10 SP X) LDA TAX SP )Y LDA 11 SP 1+ STA SP STX 0 # LDX 12 NEXT JMP END-CODE 13 14 15 ATARIVF.FB Scr 10 Dr 0 0 \ 1 CODE UP@ ( -- ADDR) 2 UP # LDX XPUSH JMP END-CODE 3 4 CODE UP! ( ADDR --) UP # LDX 5 LABEL XPULL SP )Y LDA 1 ,X STA 6 DEY SP )Y LDA 0 ,X STA 7 LABEL (XYDROP 0 # LDX 1 # LDY 8 LABEL (DROP SP 2INC NEXT JMP 9 END-CODE RESTRICT 10 11 12 13 14 15 ATARIVF.FB Scr 11 Dr 0 0 \ MANIPULATE RETURNSTACK 16FEB85BP/KS) 1 CODE RP@ ( -- ADDR ) 2 RP # LDX XPUSH JMP END-CODE 3 4 CODE RP! ( ADDR -- ) 5 RP # LDX XPULL JMP END-CODE RESTRICT 6 7 CODE >R ( 16B -- ) 8 RP 2DEC SP X) LDA RP X) STA 9 SP )Y LDA RP )Y STA (DROP JMP 10 END-CODE RESTRICT 11 12 13 14 15 ATARIVF.FB Scr 12 Dr 0 0 \ 1 CODE R> ( -- 16B) 2 SP 2DEC RP X) LDA SP X) STA 3 RP )Y LDA SP )Y STA 4 LABEL (RDROP 2 # LDA 5 6 LABEL (NRDROP CLC RP ADC RP STA 7 CS ?[ RP 1+ INC ]? 8 NEXT JMP END-CODE RESTRICT 9 10 11 12 13 14 15 ATARIVF.FB Scr 13 Dr 0 0 \ R@ RDROP EXIT UNNEST 08APR85BP) cas10jan07 1 CODE R@ ( -- 16B) 2 SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP 3 END-CODE 4 5 CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT 6 7 CODE EXIT 8 RP X) LDA IP STA 9 RP )Y LDA IP 1+ STA 10 (RDROP JMP END-CODE 11 12 \ CODE UNNEST 13 \ RP X) LDA IP STA RP )Y LDA IP 1+ STA (rdrop JMP end-code 14 15 ATARIVF.FB Scr 14 Dr 0 0 \ ?EXIT EXECUTE PERFORM 08APR85BP) cas08jan07 1 2 CODE ?EXIT ( FLAG -- ) 3 SP X) LDA SP )Y ORA 4 PHP SP 2INC PLP 5 ' EXIT @ BNE NEXT JMP 6 END-CODE 7 8 CODE EXECUTE ( ADDR --) 9 SP X) LDA W STA 10 SP )Y LDA W 1+ STA 11 SP 2INC W 1- JMP END-CODE 12 13 : PERFORM ( ADDR -- ) @ EXECUTE ; 14 15 ATARIVF.FB Scr 15 Dr 0 0 \ C@ C! 10JAN85BP) cas08jan07 1 2 CODE C@ ( ADDR -- 8B) 3 SP X) LDA N STA SP )Y LDA N 1+ STA 4 LABEL (C@ 0 # LDA SP )Y STA 5 N X) LDA PUTA JMP END-CODE 6 7 CODE C! ( 16B ADDR --) 8 SP X) LDA N STA SP )Y LDA N 1+ STA 9 INY SP )Y LDA N X) STA DEY 10 LABEL (2DROP 11 SP LDA CLC 4 # ADC SP STA 12 CS ?[ SP 1+ INC ]? 13 NEXT JMP END-CODE 14 15 ATARIVF.FB Scr 16 Dr 0 0 \ @ ! +! ctoggle 08APR85BP) cas08jan07 1 2 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; 3 4 CODE @ ( ADDR -- 16B) 5 SP X) LDA N STA SP )Y LDA N 1+ STA 6 N )Y LDA SP )Y STA 7 N X) LDA PUTA JMP END-CODE 8 9 CODE ! ( 16B ADDR --) 10 SP X) LDA N STA SP )Y LDA N 1+ STA 11 INY SP )Y LDA N X) STA 12 INY SP )Y LDA 1 # LDY 13 LABEL (! 14 N )Y STA (2DROP JMP END-CODE 15 ATARIVF.FB Scr 17 Dr 0 0 \ +! DROP 24MAY84KS) cas08jan07 1 2 CODE +! ( N ADDR --) 3 SP X) LDA N STA SP )Y LDA N 1+ STA 4 INY SP )Y LDA CLC N X) ADC N X) STA 5 INY SP )Y LDA 1 # LDY N )Y ADC 6 (! JMP END-CODE 7 8 CODE DROP ( 16B --) 9 (DROP HERE 2- ! END-CODE 10 11 12 13 14 15 ATARIVF.FB Scr 18 Dr 0 0 \ swap cas08jan07 1 CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) 2 SP )Y LDA TAX 3 3 # LDY SP )Y LDA N STA 4 TXA SP )Y STA 5 N LDA 1 # LDY SP )Y STA 6 INY 0 # LDX 7 SP )Y LDA N STA SP X) LDA SP )Y STA 8 DEY 9 N LDA PUTA JMP END-CODE 10 11 12 13 14 15 ATARIVF.FB Scr 19 Dr 0 0 \ DUP ?DUP 08MAY85BP) cas08jan07 1 2 CODE DUP ( 16B -- 16B 16B) 3 SP 2DEC 4 3 # LDY SP )Y LDA 1 # LDY SP )Y STA 5 INY SP )Y LDA DEY 6 PUTA JMP END-CODE 7 8 CODE ?DUP ( 16B -- 16B 16B / FALSE) 9 SP X) LDA SP )Y ORA 10 0= ?[ NEXT JMP ]? 11 ' DUP @ JMP END-CODE 12 13 \ : ?DUP ( 16B -- 16B 16B / FALSE) DUP IF DUP THEN ; 14 \ : DUP ( n - n n ) SP@ @ ; 15 ATARIVF.FB Scr 20 Dr 0 0 \ OVER 13JUN84KS) cas08jan07 1 2 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) 3 SP 2DEC 4 # LDY SP )Y LDA SP X) STA 4 INY SP )Y LDA 1 # LDY SP )Y STA 5 NEXT JMP END-CODE 6 7 8 \\ : ROT >R SWAP R> SWAP ; 9 : OVER >R DUP R> SWAP ; 10 11 12 13 14 15 ATARIVF.FB Scr 21 Dr 0 0 \ ROT cas08jan07 1 CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 2 3 # LDY SP )Y LDA N 1+ STA 3 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 4 5 # LDY SP )Y LDA N STA 5 N 1+ LDA SP )Y STA 6 1 # LDY N LDA SP )Y STA 7 INY SP )Y LDA N 1+ STA 8 SP X) LDA SP )Y STA 9 4 # LDY SP )Y LDA SP X) STA 10 N 1+ LDA SP )Y STA 11 1 # LDY NEXT JMP END-CODE 12 13 14 15 ATARIVF.FB Scr 22 Dr 0 0 \ -ROT NIP UNDER PICK ROLL -ROLL cas08jan07 1 : -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) 2 ROT ROT ; 3 4 : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; 5 6 : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; 7 8 : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; 9 10 : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; 11 12 : -ROLL ( N --) 13 >R DUP SP@ DUP 2+ DUP 2+ SWAP 14 R@ 2* CMOVE R> 1+ 2* + ! ; 15 ATARIVF.FB Scr 23 Dr 0 0 \ DOUBLE WORD STACK MANIP. 21APR83KS) 1 2 : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; 3 4 CODE 2DROP ( 32B -- ) 5 (2DROP HERE 2- ! END-CODE 6 7 : 2DUP ( 32B -- 32B 32B) OVER OVER ; 8 9 \ : 2DROP ( 32B -- ) DROP DROP ; 10 11 12 13 14 15 ATARIVF.FB Scr 24 Dr 0 0 \ + AND OR XOR 08APR85BP) cas08jan07 1 COMPILER ASSEMBLER ALSO DEFINITIONS 2 3 H : DYADOP ( OPCODE --) T 4 INY SP X) LDA DUP C, SP C, SP )Y STA 5 DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA 6 (XYDROP JMP H ; 7 TARGET 8 9 CODE + ( N1 N2 -- N3) CLC $71 DYADOP END-CODE 10 CODE OR ( 16B1 16B2 -- 16B3) $11 DYADOP END-CODE 11 CODE AND ( 16B1 16B2 -- 16B3) $31 DYADOP END-CODE 12 CODE XOR ( 16B1 16B2 -- 16B3) $51 DYADOP END-CODE 13 14 15 ATARIVF.FB Scr 25 Dr 0 0 \ - NOT NEGATE 24DEC83KS) cas08jan07 1 2 CODE - ( N1 N2 -- N3) 3 INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 4 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE 5 6 CODE NOT ( 16B1 -- 16B2) CLC 7 LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA 8 NEXT JMP END-CODE 9 10 CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE 11 12 \ : - NEGATE + ; 13 14 15 ATARIVF.FB Scr 26 Dr 0 0 \ DNEGATE SETUP 14JUN84KS) cas08jan07 1 2 CODE DNEGATE ( D1 -- -D1) 3 INY SEC 4 TXA SP )Y SBC SP )Y STA INY 5 TXA SP )Y SBC SP )Y STA 6 TXA SP X) SBC SP X) STA 1 # LDY 7 TXA SP )Y SBC SP )Y STA 8 NEXT JMP END-CODE 9 LABEL SETUP ( QUAN IN A) 10 .A ASL TAX TAY DEY 11 [[ SP )Y LDA N ,Y STA DEY 0< ?] 12 TXA CLC SP ADC SP STA 13 CS ?[ SP 1+ INC ]? 14 0 # LDX 1 # LDY RTS END-CODE 15 ATARIVF.FB Scr 27 Dr 0 0 \ D+ cas08jan07 1 2 CODE D+ ( D1 D2 -- D3) 3 2 # LDA SETUP JSR INY 4 SP )Y LDA CLC N 2+ ADC SP )Y STA INY 5 SP )Y LDA N 3 + ADC SP )Y STA 6 SP X) LDA N ADC SP X) STA 1 # LDY 7 SP )Y LDA N 1+ ADC SP )Y STA 8 NEXT JMP END-CODE 9 10 11 12 13 14 15 ATARIVF.FB Scr 28 Dr 0 0 \ 1+ 2+ 3+ 4+ 1- 2- 08APR85BP) cas08jan07 1 2 CODE 1+ ( N1 -- N2) 1 # LDA 3 LABEL N+ CLC SP X) ADC 4 CS NOT ?[ PUTA JMP ]? 5 SP X) STA SP )Y LDA 0 # ADC SP )Y STA 6 NEXT JMP END-CODE 7 8 CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE 9 CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE 10 CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE 11 | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE 12 13 14 15 ATARIVF.FB Scr 29 Dr 0 0 \ 1- 2- NUMBER CONSTANTS 24DEC83KS) cas08jan07 1 CODE 1- ( N1 -- N2) SEC 2 LABEL (1- SP X) LDA 1 # SBC 3 CS ?[ PUTA JMP ]? 4 SP X) STA SP )Y LDA 0 # SBC SP )Y STA 5 NEXT JMP END-CODE 6 CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE 7 8 -1 CONSTANT TRUE 0 CONSTANT FALSE 9 ' TRUE ALIAS -1 ' FALSE ALIAS 0 10 11 1 CONSTANT 1 2 CONSTANT 2 12 3 CONSTANT 3 4 CONSTANT 4 13 14 : ON ( ADDR -- ) TRUE SWAP ! ; 15 : OFF ( ADDR -- ) FALSE SWAP ! ; ATARIVF.FB Scr 30 Dr 0 0 \ WORDS FOR NUMBER LITERALS 24MAY84KS) cas08jan07 1 2 CODE CLIT ( -- 8B) 3 SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC 4 NEXT JMP END-CODE RESTRICT 5 6 CODE LIT ( -- 16B) 7 SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA 8 LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT 9 10 : LITERAL ( 16B --) DUP $FF00 AND 11 IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; 12 IMMEDIATE RESTRICT 13 14 \\ : LIT R> DUP 2+ >R @ ; 15 \\ : CLIT R> DUP 1+ >R C@ ; ATARIVF.FB Scr 31 Dr 0 0 \ COMPARISION CODE WORDS 13JUN84KS) cas08jan07 1 CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ 2 LABEL PUTTRUE $FF # LDA $24 C, ]? 3 LABEL PUTFALSE TXA SP )Y STA 4 PUTA JMP END-CODE 5 6 CODE 0= ( 16B -- FLAG) 7 SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE 8 9 CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 10 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP 11 SP )Y LDA N 1+ SBC 12 CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP 13 SP )Y LDA N 3 + SBC 14 PUTTRUE BCS ]? 15 PUTFALSE JMP END-CODE ATARIVF.FB Scr 32 Dr 0 0 \ COMPARISION CODE WORDS 13JUN84KS) 1 2 CODE < ( N1 N2 -- FLAG) 3 SP X) LDA N STA SP )Y LDA N 1+ STA 4 SP 2INC 5 N 1+ LDA SP )Y EOR ' 0< @ BMI 6 SP X) LDA N CMP SP )Y LDA N 1+ SBC 7 ' 0< @ 2+ JMP END-CODE 8 9 CODE U< ( U1 U2 -- FLAG) 10 SP X) LDA N STA SP )Y LDA N 1+ STA 11 SP 2INC 12 SP X) LDA N CMP SP )Y LDA N 1+ SBC 13 CS NOT ?[ PUTTRUE JMP ]? 14 PUTFALSE JMP END-CODE 15 ATARIVF.FB Scr 33 Dr 0 0 \ COMPARISION WORDS 24DEC83KS) cas08jan07 1 2 \ : 0< $8000 AND 0<> ; 3 4 : > ( N1 N2 -- FLAG) SWAP < ; 5 : 0> ( N -- FLAG) NEGATE 0< ; 6 : 0<> ( N -- FLAG) 0= NOT ; 7 : U> ( U1 U2 -- FLAG) SWAP U< ; 8 : = ( N1 N2 -- FLAG) - 0= ; 9 : D0= ( D -- FLAG) OR 0= ; 10 : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; 11 : D< ( D1 D2 -- FLAG) ROT 2DUP - 12 IF > NIP NIP ELSE 2DROP U< THEN ; 13 14 15 ATARIVF.FB Scr 34 Dr 0 0 \ MIN MAX UMAX UMIN EXTEND DABS ABS KS) 1 2 | : MINIMAX ( N1 N2 FLAG -- N3) 3 RDROP IF SWAP THEN DROP ; 4 5 : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT 6 : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT 7 : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT 8 : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT 9 10 : EXTEND ( N -- D) DUP 0< ; 11 12 : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; 13 : ABS ( N -- U) EXTEND IF NEGATE THEN ; 14 15 ATARIVF.FB Scr 35 Dr 0 0 \ LOOP PRIMITIVES 08FEB85BP/KS) cas08jan07 1 2 | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; 3 4 : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT 5 6 : (?DO ( LIMIT START -- ) 7 OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT 8 9 : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; 10 11 CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT 12 13 \\ DODO PUTS "INDEX \ LIMIT \ 14 ADR.OF.DO" ON RETURN-STACK 15 ATARIVF.FB Scr 36 Dr 0 0 \ (LOOP (+LOOP 08APR85BP) 1 CODE (LOOP 2 CLC 1 # LDA RP X) ADC RP X) STA 3 CS ?[ RP )Y LDA 0 # ADC RP )Y STA 4 CS ?[ NEXT JMP ]? ]? 5 LABEL DOLOOP 5 # LDY 6 RP )Y LDA IP 1+ STA DEY 7 RP )Y LDA IP STA 1 # LDY 8 NEXT JMP END-CODE RESTRICT 9 10 CODE (+LOOP 11 CLC SP X) LDA RP X) ADC RP X) STA 12 SP )Y LDA RP )Y ADC RP )Y STA 13 .A ROR SP )Y EOR 14 PHP SP 2INC PLP DOLOOP BPL 15 NEXT JMP END-CODE RESTRICT ATARIVF.FB Scr 37 Dr 0 0 \ LOOP INDICES 08APR85BP) 1 2 CODE I ( -- N) 0 # LDY 3 LABEL LOOPINDEX SP 2DEC CLC 4 RP )Y LDA INY INY 5 RP )Y ADC SP X) STA DEY 6 RP )Y LDA INY INY 7 RP )Y ADC 1 # LDY SP )Y STA 8 NEXT JMP END-CODE RESTRICT 9 10 CODE J ( -- N) 11 6 # LDY LOOPINDEX BNE 12 END-CODE RESTRICT 13 14 15 ATARIVF.FB Scr 38 Dr 0 0 \ BRANCHING 24DEC83KS) 1 2 CODE BRANCH 3 CLC IP LDA IP X) ADC N STA 4 IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA 5 NEXT JMP END-CODE RESTRICT 6 7 CODE ?BRANCH 8 SP X) LDA SP )Y ORA PHP SP 2INC PLP 9 ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT 10 11 \\ : BRANCH R> DUP @ + >R ; RESTRICT 12 13 : ?BRANCH 14 0= R> OVER NOT OVER 2+ AND -ROT 15 DUP @ + AND OR >R ; RESTRICT ATARIVF.FB Scr 39 Dr 0 0 \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) cas11aug06 1 2 : >MARK ( -- ADDR) HERE 0 , ; 3 : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; 4 : MARK 1 ; IMMEDIATE RESTRICT 3 : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT 4 : ELSE 1 ?PAIRS COMPILE BRANCH >MARK 5 SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT 6 : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT 9 10 | : (REPTIL RESOLVE REPEAT ; 12 13 : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT 14 : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT 15 ATARIVF.FB Scr 42 Dr 0 0 \ LOOPS 29JAN85KS/BP) 1 2 : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT 3 4 : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT 5 6 : LOOP 3 ?PAIRS COMPILE (LOOP 7 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT 8 9 : +LOOP 3 ?PAIRS COMPILE (+LOOP 10 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT 11 12 : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT 13 14 \\ RETURNSTACK: CALLADR \ INDEX 15 LIMIT \ ADR OF DO ATARIVF.FB Scr 43 Dr 0 0 \ UM* BP/KS13.2.85) cas02jan07 1 CODE UM* ( U1 U2 -- UD) 2 SP )Y LDA N STA SP X) LDA N 1+ STA 3 INY N 2+ STX N 3+ STX $10 # LDX 4 [[ N 3+ ASL N 2+ ROL N 1+ ROL N ROL 5 CS ?[ CLC SP )Y LDA N 3+ ADC N 3+ STA 6 INY SP )Y LDA DEY N 2+ ADC N 2+ STA 7 CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? 8 DEX 0= ?] 9 N 3+ LDA SP )Y STA INY N 2+ LDA SP )Y STA 1 # LDY 10 N LDA SP )Y STA N 1+ LDA SP X) STA 11 NEXT JMP END-CODE 12 13 \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> $10 0 14 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN 15 >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; ATARIVF.FB Scr 44 Dr 0 0 \ M* 2* 04JUL84KS) cas02jan07 1 2 : M* ( N1 N2 -- D) 3 DUP 0< DUP >R IF NEGATE THEN 4 SWAP DUP 0< IF NEGATE R> NOT >R THEN 5 UM* R> IF DNEGATE THEN ; 6 7 : * ( N N -- PROD) UM* DROP ; 8 9 CODE 2* ( N1 -- N2) 10 SP X) LDA .A ASL SP X) STA 11 SP )Y LDA .A ROL SP )Y STA 12 NEXT JMP END-CODE 13 14 \\ | : 2* DUP + ; 15 ATARIVF.FB Scr 45 Dr 0 0 \ UM/MOD 04JUL84KS) cas02jan07 1 2 | : DIVOVL 3 TRUE ABORT" DIVISION OVERFLOW" ; 4 5 CODE UM/MOD ( UD U -- UREM UQUOT) 6 SP X) LDA N 5 + STA 7 SP )Y LDA N 4+ STA SP 2INC 8 SP X) LDA N 1+ STA 9 SP )Y LDA N STA INY 10 SP )Y LDA N 3+ STA INY 11 SP )Y LDA N 2+ STA $11 # LDX CLC 12 [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC 13 TAY N LDA N 4+ SBC 14 CS NOT ?[ N 6 + ROL ]? 15 CS ?[ N STA N 1+ STY ]? ATARIVF.FB Scr 46 Dr 0 0 \ um/mod cont. cas02jan07 1 2 N 3 + ROL N 2+ ROL N 1+ ROL N ROL 3 DEX 0= ?] 4 1 # LDY N ROR N 1+ ROR 5 CS ?[ ;C: DIVOVL ; ASSEMBLER ]? 6 N 2+ LDA SP )Y STA INY 7 N 1+ LDA SP )Y STA INY 8 N LDA SP )Y STA 1 # LDY 9 N 3 + LDA 10 PUTA JMP END-CODE 11 12 13 14 15 ATARIVF.FB Scr 47 Dr 0 0 \ 2/ M/MOD 24DEC83KS) 1 2 : M/MOD ( D N -- MOD QUOT) 3 DUP >R ABS OVER 4 0< IF UNDER + SWAP THEN 5 UM/MOD R@ 6 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- 7 THEN THEN RDROP ; 8 9 CODE 2/ ( N1 -- N2) 10 SP )Y LDA .A ASL 11 SP )Y LDA .A ROR SP )Y STA 12 SP X) LDA .A ROR 13 PUTA JMP END-CODE 14 15 ATARIVF.FB Scr 48 Dr 0 0 \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) cas08jan07 1 2 : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; 3 : / ( N1 N2 -- QUOT) /MOD NIP ; 4 : MOD ( N1 N2 -- REM) /MOD DROP ; 5 : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; 6 : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; 7 : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; 8 : UD/MOD ( UD1 U2 -- UREM UDQUOT) 9 >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; 10 11 12 13 14 15 ATARIVF.FB Scr 49 Dr 0 0 \ CMOVE BP 08APR85) cas08jan07 1 2 CODE CMOVE ( FROM TO QUAN --) 3 3 # LDA SETUP JSR DEY 4 [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 5 1 # LDY NEXT JMP ]? ]? 6 N 4 + )Y LDA N 2+ )Y STA INY 0= ?] 7 N 5 + INC N 3 + INC ]] END-CODE 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 50 Dr 0 0 \ CMOVE> (CMOVE> cas08jan07 1 CODE CMOVE> ( FROM TO QUAN --) 2 3 # LDA SETUP JSR 3 CLC N 1+ LDA N 3 + ADC N 3 + STA 4 CLC N 1+ LDA N 5 + ADC N 5 + STA 5 N 1+ INC N LDY CLC CS ?[ 6 LABEL (CMOVE> 7 DEY N 4 + )Y LDA N 2+ )Y STA ]? 8 TYA (CMOVE> BNE 9 N 3 + DEC N 5 + DEC N 1+ DEC 10 (CMOVE> BNE 1 # LDY 11 NEXT JMP END-CODE 12 13 : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN 14 R> CMOVE ; 15 ATARIVF.FB Scr 51 Dr 0 0 \ PLACE COUNT ERASE 16FEB85BP/KS) cas08jan07 1 2 : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; 3 4 CODE COUNT ( ADDR -- ADDR+1 LEN) 5 SP X) LDA N STA CLC 1 # ADC SP X) STA 6 SP )Y LDA N 1+ STA 0 # ADC SP )Y STA 7 SP 2DEC (C@ JMP END-CODE 8 9 \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; 10 11 : ERASE ( ADDR QUAN --) 0 FILL ; 12 13 14 15 ATARIVF.FB Scr 52 Dr 0 0 \ FILL 11JUN85BP) 1 2 CODE FILL ( ADDR QUAN 8B -- ) 3 3 # LDA SETUP JSR DEY 4 N LDA N 3 + LDX 5 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] 6 N 5 + INC DEX 0= ?] 7 ]? N 2+ LDX 8 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] 9 ]? 1 # LDY 10 NEXT JMP END-CODE 11 12 \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP 13 IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; 14 15 ATARIVF.FB Scr 53 Dr 0 0 \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) cas08jan07 1 2 : HERE ( -- ADDR) DP @ ; 3 4 : PAD ( -- ADDR) HERE $42 + ; 5 6 : ALLOT ( N --) DP +! ; 7 8 : , ( 16B --) HERE ! 2 ALLOT ; 9 10 : C, ( 8B --) HERE C! 1 ALLOT ; 11 12 : COMPILE R> DUP 2+ >R @ , ; RESTRICT 13 14 15 ATARIVF.FB Scr 54 Dr 0 0 \ INPUT STRINGS 24DEC83KS) cas09jan07 1 2 VARIABLE #TIB 0 #TIB ! 3 VARIABLE >TIB $100 >TIB ! \ $80 ALLOT 4 VARIABLE >IN 0 >IN ! 5 VARIABLE SPAN 0 SPAN ! 6 7 : TIB ( -- ADDR ) >TIB @ ; 8 9 : QUERY TIB $80 EXPECT SPAN @ #TIB ! >IN OFF ; 10 11 12 13 14 15 ATARIVF.FB Scr 55 Dr 0 0 \ SCAN SKIP /STRING 12OCT84BP) cas08jan07 1 \ todo: combine scan and skip! 2 3 : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R 4 BEGIN DUP WHILE OVER C@ R@ - 5 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; 6 7 : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R 8 BEGIN DUP WHILE OVER C@ R@ = 9 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; 10 11 12 : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) 13 OVER UMIN ROT OVER + -ROT - ; 14 15 ATARIVF.FB Scr 56 Dr 0 0 \ CAPITAL 03APR85BP) cas08jan07 1 2 LABEL (CAPITAL \ FOR ASCII ONLY 3 ASCII a # CMP 4 CS ?[ ASCII z 1+ # CMP 5 CC ?[ SEC ASCII a ASCII A - # SBC 6 ]? ]? RTS END-CODE 7 8 CODE CAPITAL ( CHAR -- CHAR' ) 9 SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE 10 11 12 13 14 15 ATARIVF.FB Scr 57 Dr 0 0 \ CAPITALIZE 03APR85BP) cas08jan07 1 2 CODE CAPITALIZE ( STRING -- STRING ) 3 SP X) LDA N STA SP )Y LDA N 1+ STA 4 N X) LDA N 2+ STA DEY 5 [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? 6 INY N )Y LDA (CAPITAL JSR N )Y STA 7 ]] END-CODE 8 9 \\ : CAPITALIZE ( STRING -- STRING ) 10 DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; 11 12 \\ CAPITAL ( CHAR -- CHAR ) 13 ASCII A ASCII Z 1+ UWITHIN 14 IF I C@ [ ASCII A ASCII A - ] LITERAL - ; 15 ATARIVF.FB Scr 58 Dr 0 0 \ (WORD 08APR85BP) 1 2 | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) 3 \ N : LENGTH OF SOURCE 4 \ N+2 : PTR IN SOURCE / NEXT CHAR 5 \ N+4 : STRING START ADRESS 6 \ N+6 : STRING LENGTH 7 N 6 + STX \ 0 =: STRING_LENGTH 8 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 9 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA 10 \ >IN+ADR0 =: N+2 11 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA 12 \ LEN0->IN =: N 13 N 1+ LDA >IN 1+ SBC N 1+ STA 14 CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED 15 SP )Y LDA >IN 1+ STA ATARIVF.FB Scr 59 Dr 0 0 \ (WORD 08APR85BP) 1 2 ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 3 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 4 0= ?[[ N 2+ WINC N WDEC ]]? 5 N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS 6 N 3 + LDA N 5 + STA 7 [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR 8 N 2+ WINC N WDEC PLP 9 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH 10 N LDA N 1+ ORA 11 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) 12 SEC 2 # LDY 13 \ ADR_AFTER_STRING - ADR0 =: >IN) 14 N 2+ LDA SP )Y SBC >IN STA INY 15 N 3 + LDA SP )Y SBC >IN 1+ STA ATARIVF.FB Scr 60 Dr 0 0 \ (WORD 08APR85BP) cas08jan07 1 2 ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED 3 \ WHEN WORD CALLED) 4 CLC 4 # LDA SP ADC SP STA 5 CS ?[ SP 1+ INC ]? \ 2DROP 6 USER' DP # LDY UP )Y LDA 7 SP X) STA N STA INY 8 UP )Y LDA 1 # LDY 9 SP )Y STA N 1+ STA \ DP @ 10 DEY N 6 + LDA \ STORE COUNT BYTE FIRST 11 [[ N )Y STA N 4 + )Y LDA INY 12 N 6 + DEC 0< ?] 13 $20 # LDA N )Y STA \ ADD A BLANK 14 1 # LDY NEXT JMP END-CODE 15 ATARIVF.FB Scr 61 Dr 0 0 \ SOURCE WORD PARSE NAME 08APR85BP) cas21dec05 1 2 : SOURCE ( -- ADDR LEN) 3 TIB #TIB @ ; 4 5 : WORD ( CHAR -- ADDR) SOURCE (WORD ; 6 7 : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP 8 R> SCAN >R OVER - DUP R> 0<> - >IN +! ; 9 10 : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; 11 12 \\ : WORD ( CHAR -- ADDR) >R 13 SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> 14 SCAN >R ROT OVER SWAP - R> 0<> - >IN ! 15 OVER - HERE PLACE BL HERE COUNT + C! HERE ; ATARIVF.FB Scr 62 Dr 0 0 \ STATE ASCII ," (" " 24DEC83KS) 1 2 VARIABLE STATE 0 STATE ! 3 4 : ASCII BL WORD 1+ C@ STATE @ 5 IF [COMPILE] LITERAL THEN ; IMMEDIATE 6 7 : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; 8 9 : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT 10 11 : (" "LIT ; RESTRICT 12 13 : " COMPILE (" ," ; IMMEDIATE RESTRICT 14 15 ATARIVF.FB Scr 63 Dr 0 0 \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) cas08jan07 1 2 : (." "LIT COUNT TYPE ; RESTRICT 3 : ." COMPILE (." ," ; IMMEDIATE RESTRICT 4 : ( ASCII ) PARSE 2DROP ; IMMEDIATE 5 : .( ASCII ) PARSE TYPE ; IMMEDIATE 6 : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE 7 ' \ ALIAS \\ 8 9 : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; 10 11 : HEX $10 BASE ! ; : DECIMAL $0A BASE ! ; 12 13 14 15 ATARIVF.FB Scr 64 Dr 0 0 \ NUMBER CONV.: DIGIT? ACCUMULATE KS) cas08jan07 1 : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) 2 ASCII 0 - DUP 9 U> 3 IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> 4 IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN 5 BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; 6 7 : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) 8 SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; 9 10 : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 11 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; 12 13 | : END? ( -- FLAG ) PTR @ 0= ; 14 | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; 15 | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; ATARIVF.FB Scr 65 Dr 0 0 \ ?NONUM ?NUM FIXBASE? 13FEB85KS) cas08jan07 1 2 VARIABLE DPL -1 DPL ! 3 4 | : ?NONUM ( FLAG -- EXIT IF TRUE ) 5 IF RDROP 2DROP DROP RDROP FALSE THEN ; 6 7 | : ?NUM ( FLAG -- EXIT IF TRUE ) 8 IF RDROP DROP R> IF DNEGATE THEN 9 ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; 10 | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) 11 ASCII & CASE? IF $0A TRUE EXIT THEN 12 ASCII $ CASE? IF $10 TRUE EXIT THEN 13 ASCII H CASE? IF $10 TRUE EXIT THEN 14 ASCII % CASE? IF $02 TRUE EXIT THEN FALSE ; 15 ATARIVF.FB Scr 66 Dr 0 0 \ PUNCTUATION ?DPL PTR 13FEB85KS) cas08jan07 1 2 | : PUNCTUATION? ( CHAR -- FLAG) 3 ASCII , OVER = SWAP ASCII . = OR ; 4 5 | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; 6 7 | VARIABLE PTR \ POINTS INTO STRING 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 67 Dr 0 0 \ (NUMBER NUMBER 13FEB85KS) cas09jan07 1 : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) 2 BASE PUSH DUP COUNT PTR ! DPL ON 3 0 >R ( +SIGN) 4 0.0 ROT END? ?NONUM CHAR 5 ASCII - CASE? 6 IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? 7 IF BASE ! END? ?NONUM CHAR THEN 8 BEGIN DIGIT? 0= ?NONUM 9 BEGIN ACCUMULATE ?DPL END? ?NUM 10 CHAR DIGIT? 0= UNTIL 11 PREVIOUS PUNCTUATION? 0= ?NONUM 12 DPL OFF END? ?NUM CHAR REPEAT ; 13 DEFER 'NUMBER? ' NUMBER? IS 'NUMBER? 14 : NUMBER ( STRING -- D ) 15 'NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; ATARIVF.FB Scr 68 Dr 0 0 \ HIDE REVEAL IMMEDIATE RESTRICT KS) cas08jan07 1 VARIABLE LAST 0 LAST ! 2 3 | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; 4 5 : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; 6 7 : REVEAL LAST? IF 2- CURRENT @ ! THEN ; 8 9 : RECURSIVE REVEAL ; IMMEDIATE RESTRICT 10 11 | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; 12 13 : IMMEDIATE $40 FLAG! ; 14 : RESTRICT $80 FLAG! ; 15 ATARIVF.FB Scr 69 Dr 0 0 \ CLEARSTACK HALLOT HEAP HEAP?11FEB85BP) cas08jan07 1 2 CODE CLEARSTACK USER' S0 # LDY 3 UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 4 1 # LDY NEXT JMP END-CODE 5 6 : HALLOT ( QUAN -- ) S0 @ OVER - SWAP 7 SP@ 2+ DUP ROT - DUP S0 ! 8 2 PICK OVER - MOVE CLEARSTACK S0 ! ; 9 10 : HEAP ( -- ADDR) S0 @ 6+ ; 11 12 : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; 13 14 | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - 15 DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; ATARIVF.FB Scr 70 Dr 0 0 \ DOES> ; 30DEC84KS/BP) cas08jan07 1 2 LABEL (DODOES> RP 2DEC 3 IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP 4 CLC W X) LDA 3 # ADC IP STA 5 TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP 6 LABEL DOCREATE 7 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE 8 9 | : (;CODE R> LAST @ NAME> ! ; 10 11 : DOES> COMPILE (;CODE $4C C, 12 COMPILE (DODOES> ; IMMEDIATE RESTRICT 13 14 15 ATARIVF.FB Scr 71 Dr 0 0 \ 6502-ALIGN ?HEAD \ 08SEP84BP) cas08jan07 1 2 | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP $FF AND $FF = - ; 3 4 | : 6502-ALIGN/2 ( LFA -- LFA ) 5 HERE $FF AND $FF = 6 IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 7 1 LAST +! 1 ALLOT THEN ; 8 9 VARIABLE ?HEAD 0 ?HEAD ! 10 11 : | ?HEAD @ ?EXIT -1 ?HEAD ! ; 12 13 14 15 ATARIVF.FB Scr 72 Dr 0 0 \ WARNING CREATE 30DEC84BP) cas10jan07 1 2 VARIABLE WARNING 0 WARNING ! 3 4 | : EXISTS? 5 WARNING @ 0= ?EXIT 6 LAST @ CURRENT @ (FIND NIP 7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; 8 9 : CREATE HERE 0 , CURRENT @ @ , 10 NAME C@ DUP 1 $20 UWITHIN NOT ABORT" INVALID NAME" 11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ 12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE 13 HEAPMOVE $20 FLAG! 6502-ALIGN/1 DP ! 14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , 15 ;CODE DOCREATE JMP END-CODE ATARIVF.FB Scr 73 Dr 0 0 \ NFA? 30DEC84BP) 1 | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) 2 SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC 3 [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA 4 N 2+ ORA 0= ?[ PUTFALSE JMP ]? 5 N 2+ )Y LDA SP )Y STA N 1+ STA 6 N 2+ X) LDA SP X) STA N STA 7 N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK 8 N 2INC N X) LDA PHA SEC 01F # AND 9 N ADC N STA CS ?[ N 1+ INC ]? 10 PLA 020 # AND 0= NOT 11 ?[ N )Y LDA PHA 12 N X) LDA N STA PLA N 1+ STA ]? 13 N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 14 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY 15 ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT ATARIVF.FB Scr 74 Dr 0 0 \ >NAME NAME> >BODY .NAME 03FEB85BP) cas08jan07 1 2 : >NAME ( CFA -- NFA / FALSE) VOC-LINK 3 BEGIN @ DUP WHILE 2DUP 4 - SWAP 4 NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; 5 6 | : (NAME> ( NFA -- CFA) COUNT $1F AND + ; 7 8 : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ $20 AND IF @ THEN ; 9 10 : >BODY ( CFA -- PFA) 2+ ; 11 12 : .NAME ( NFA --) 13 ?DUP IF DUP HEAP? IF ." |" THEN COUNT $1F AND TYPE 14 ELSE ." ???" THEN SPACE ; 15 ATARIVF.FB Scr 75 Dr 0 0 \ CREATE: : ; CONSTANT VARIABLE 09JAN85KS/BP) cas10jan07 1 2 : CREATE: CREATE HIDE 0 ] ; 3 : : CREATE: ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE 4 RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA 5 W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA 6 NEXT JMP END-CODE 7 8 : ; 0 ?PAIRS COMPILE EXIT \ exit was unnest 9 [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT 10 11 : CONSTANT ( 16B --) CREATE , 12 ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY 13 W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE 14 15 : VARIABLE CREATE 2 ALLOT ; ATARIVF.FB Scr 76 Dr 0 0 \ UALLOT USER ALIAS 10JAN85KS/BP) cas08jan07 1 2 : UALLOT ( QUAN -- OFFSET) 3 DUP UDP @ + $FF U> ABORT" USERAREA FULL" 4 UDP @ SWAP UDP +! ; 5 6 : USER CREATE 2 UALLOT C, 7 ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA 8 TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE 9 10 : ALIAS ( CFA --) 11 CREATE LAST @ DUP C@ $20 AND 12 IF -2 ALLOT ELSE $20 FLAG! THEN (NAME> ! ; 13 14 15 ATARIVF.FB Scr 77 Dr 0 0 \ VOC-LINK VP CURRENT CONTEXT ALSO BP) cas08jan07 1 CREATE VP $10 ALLOT 2 3 VARIABLE CURRENT 4 5 : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; 6 7 | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; 8 \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : 9 \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER 10 11 : ALSO VP @ 12 $A > ERROR" VOCABULARY STACK FULL" 13 CONTEXT @ 2 VP +! CONTEXT ! ; 14 15 : TOSS -2 VP +! ; ATARIVF.FB Scr 78 Dr 0 0 \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) 1 2 : VOCABULARY CREATE 0 , 0 , 3 HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; 4 5 \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK 6 7 VOCABULARY FORTH 8 9 VOCABULARY ONLY 10 ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! 11 12 : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; 13 14 15 ATARIVF.FB Scr 79 Dr 0 0 \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) 1 2 : DEFINITIONS CONTEXT @ CURRENT ! ; 3 4 | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; 5 6 : ORDER 7 THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; 8 9 : WORDS CONTEXT @ 10 BEGIN @ DUP STOP? 0= AND 11 WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; 12 13 14 15 ATARIVF.FB Scr 80 Dr 0 0 \ (FIND 08APR85BP) 1 2 CODE (FIND ( STRING THREAD 3 -- STRING FALSE / NAMEFIELD TRUE) 4 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 5 N 2+ X) LDA 01F # AND N 4 + STA 6 LABEL FINDLOOP 0 # LDY 7 N )Y LDA TAX INY 8 N )Y LDA N 1+ STA N STX N ORA 9 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? 10 INY N )Y LDA 01F # AND N 4 + CMP 11 FINDLOOP BNE \ COUNTBYTE MATCH 12 CLC 2 # LDA N ADC N 5 + STA 13 0 # LDA N 1+ ADC N 6 + STA 14 N 4 + LDY 15 [[ N 2+ )Y LDA N 5 + )Y CMP ATARIVF.FB Scr 81 Dr 0 0 \ FIND (cont.) cas08jan07 1 FINDLOOP BNE DEY 0= ?] 2 3 # LDY N 6 + LDA SP )Y STA DEY 3 N 5 + LDA SP )Y STA 4 DEY 0 # LDX PUTTRUE JMP END-CODE 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 82 Dr 0 0 \ FOUND 29JAN85BP) cas08jan07 1 2 | CODE FOUND ( NFA -- CFA N ) 3 SP X) LDA N STA SP )Y LDA N 1+ STA 4 N X) LDA N 2+ STA $1F # AND SEC N ADC N STA 5 CS ?[ N 1+ INC ]? 6 N 2+ LDA $20 # AND 7 0= ?[ N LDA SP X) STA N 1+ LDA 8 ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA 9 SP 2DEC N 2+ LDA 0< ?[ INY ]? 10 .A ASL 11 0< NOT ?[ TYA $FF # EOR TAY INY ]? 12 TYA SP X) STA 13 0< ?[ $FF # LDA 24 C, ]? 14 TXA 1 # LDY SP )YSTA 15 NEXT JMP END-CODE ATARIVF.FB Scr 83 Dr 0 0 \\ cas08jan07 1 2 | : FOUND ( NFA -- CFA N ) 3 DUP C@ >R (NAME> 4 R@ $20 AND IF @ THEN 5 -1 R@ $80 AND IF 1- THEN 6 R> $40 AND IF NEGATE THEN ; 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 84 Dr 0 0 \ FIND ' ['] 13JAN85BP) cas21dec05 1 2 : FIND ( STRING -- CFA N / STRING FALSE) 3 CONTEXT DUP @ OVER 2- @ = IF 2- THEN 4 BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN 5 OVER VP 2+ U> 6 WHILE SWAP 2- REPEAT NIP FALSE ; 7 8 : ' ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ; 9 10 : [COMPILE] ' , ; IMMEDIATE RESTRICT 11 12 : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT 13 14 : NULLSTRING? ( STRING -- STRING FALSE / TRUE) 15 DUP C@ 0= DUP IF NIP THEN ; ATARIVF.FB Scr 85 Dr 0 0 \ >INTERPRET 28FEB85BP) cas08jan07 1 2 LABEL JUMP 3 INY CLC W )Y LDA 2 # ADC IP STA 4 INY W )Y LDA 0 # ADC IP 1+ STA 5 1 # LDY NEXT JMP END-CODE 6 VARIABLE >INTERPRET 7 8 JUMP ' >INTERPRET ! 9 10 \\ MAKE VARIABLE >INTERPRET TO SPECIAL 11 DEFER 12 13 14 15 ATARIVF.FB Scr 86 Dr 0 0 \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas21dec05 1 2 DEFER NOTFOUND 3 4 : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 5 6 ' NO.EXTENSIONS IS NOTFOUND 7 8 : INTERPRET >INTERPRET ; -2 ALLOT 9 10 | : INTERACTIVE ?STACK NAME FIND ?DUP 11 IF 1 AND IF EXECUTE >INTERPRET THEN 12 ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 13 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT 14 15 ' INTERACTIVE >INTERPRET ! ATARIVF.FB Scr 87 Dr 0 0 \ COMPILING [ ] 20DEC84BP) cas08jan07 1 2 | : COMPILING 3 ?STACK NAME FIND ?DUP 4 IF 0> IF EXECUTE >INTERPRET THEN 5 , >INTERPRET THEN 6 NULLSTRING? ?EXIT 'NUMBER? ?DUP 7 IF 0> IF SWAP [COMPILE] LITERAL THEN 8 [COMPILE] LITERAL 9 ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT 10 11 : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE 12 13 : ] ['] COMPILING IS >INTERPRET STATE ON ; 14 15 ATARIVF.FB Scr 88 Dr 0 0 \ PERFOM DEFER IS 03FEB85BP) cas08jan07 1 2 | : CRASH TRUE ABORT" CRASH" ; 3 4 : DEFER CREATE ['] CRASH , 5 ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA 6 W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE 7 8 : (IS R> DUP 2+ >R @ ! ; 9 10 | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = 11 SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; 12 13 : IS ( ADR -- ) ' DUP DEF? >BODY 14 STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE 15 ATARIVF.FB Scr 89 Dr 0 0 \ ?STACK 08SEP84KS) cas08jan07 1 | CREATE ALARM 1 ALLOT 0 ALARM C! 2 | : STACKFULL ( -- ) 3 DEPTH $20 > ABORT" TIGHT STACK" 4 ALARM C@ 0= IF -1 ALARM C! TRUE ABORT" DICTIONARY FULL" THEN 5 ." STILL FULL" ; 6 7 CODE ?STACK USER' DP # LDY 8 SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 9 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? alarm stx 10 USER' S0 # LDY UP )Y LDA SP CMP INY 11 UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? 12 ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT 13 14 \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN 15 SP@ S0 @ U> ABORT" STACK EMPTY" ; ATARIVF.FB Scr 90 Dr 0 0 \ .STATUS PUSH LOAD 08SEP84KS) cas08jan07 1 2 DEFER .STATUS ' NOOP IS .STATUS 3 4 | CREATE PULL 0 ] R> R> ! ; 5 6 : PUSH ( ADDR -- ) 7 R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 91 Dr 0 0 \ RDEPTH DEPTH cas08jan07 1 2 : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; 3 4 : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 92 Dr 0 0 \ QUIT (QUIT ABORT 07JUN85BP) cas08jab07 1 2 | : PROMPT STATE @ IF ." ] " EXIT THEN ." OK" ; 3 4 : (QUIT 5 BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT 6 7 DEFER 'QUIT ' (QUIT IS 'QUIT 8 9 : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT 10 11 : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; 12 13 DEFER 'ABORT ' NOOP IS 'ABORT 14 15 : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT ATARIVF.FB Scr 93 Dr 0 0 \ (ERROR ABORT" ERROR" 20MAR85BP) cas08jan07 1 2 VARIABLE R# 0 R# ! 3 4 : (ERROR ( STRING -- ) 5 STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR 6 QUIT ; -2 ALLOT 7 8 ' (ERROR ERRORHANDLER ! 9 10 : (ABORT" "LIT SWAP IF 11 >R CLEARSTACK R> ERRORHANDLER PERFORM 12 EXIT THEN DROP ; RESTRICT 13 14 15 ATARIVF.FB Scr 94 Dr 0 0 \ ABORT" ERROR" cas08jan07 1 2 | : (ERR" "LIT SWAP 3 IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT 4 5 : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT 6 7 : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 95 Dr 0 0 \ -TRAILING 08APR85BP) cas08jan07 1 2 $20 CONSTANT BL 3 4 CODE -TRAILING ( ADDR N1 -- ADR N2 ) 5 TYA SETUP JSR 6 SP X) LDA N 2+ STA CLC 7 SP )Y LDA N 1+ ADC N 3 + STA 8 N LDY CLC CS ?[ 9 LABEL (-TRAIL 10 DEY N 2+ )Y LDA BL # CMP 11 0<> ?[ INY 0= ?[ N 1+ INC ]? 12 TYA PHA N 1+ LDA PUSH JMP ]? 13 ]? TYA (-TRAIL BNE 14 N 3 + DEC N 1 + DEC (-TRAIL BPL 15 TYA PUSH0A JMP END-CODE ATARIVF.FB Scr 96 Dr 0 0 \ SPACE SPACES 29JAN85KS/BP) 1 2 : SPACE BL EMIT ; 3 4 : SPACES ( U --) 0 ?DO SPACE LOOP ; 5 6 \\ 7 : -TRAILING ( ADDR N1 -- ADDR N2) 8 2DUP BOUNDS 9 ?DO 2DUP + 1- C@ BL - 10 IF LEAVE THEN 1- LOOP ; 11 12 13 14 15 ATARIVF.FB Scr 97 Dr 0 0 \ HOLD <# #> SIGN # #S 24DEC83KS) cas08jan07 1 | : HLD ( -- ADDR) PAD 2- ; 2 3 : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; 4 5 : <# HLD HLD ! ; 6 7 : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; 8 9 : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; 10 11 : # ( +D1 -- +D2) BASE @ UD/MOD ROT $9 OVER < 12 IF [ ASCII A ASCII 9 - 1- ] LITERAL + 13 THEN ASCII 0 + HOLD ; 14 15 : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; ATARIVF.FB Scr 98 Dr 0 0 \ PRINT NUMBERS 24DEC83KS) 1 2 : D.R -ROT UNDER DABS <# #S ROT SIGN #> 3 ROT OVER MAX OVER - SPACES TYPE ; 4 5 : .R SWAP EXTEND ROT D.R ; 6 7 : U.R 0 SWAP D.R ; 8 9 : D. 0 D.R SPACE ; 10 11 : . EXTEND D. ; 12 13 : U. 0 D. ; 14 15 ATARIVF.FB Scr 99 Dr 0 0 \ .S C/L L/S 24DEC83KS) cas21cas08jan07 1 2 : .S SP@ S0 @ OVER - $20 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 3 4 &40 CONSTANT C/L \ SCREEN LINE LENGTH 5 &24 CONSTANT L/S \ LINES PER SCREEN 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 100 Dr 0 0 \ MULTITASKER PRIMITIVES BP03NOV85) cas08jan07 1 CODE PAUSE NEXT HERE 2- ! END-CODE 2 3 : LOCK ( ADDR --) 4 DUP @ UP@ = IF DROP EXIT THEN 5 BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; 6 7 : UNLOCK ( ADDR --) DUP LOCK OFF ; 8 9 LABEL WAKE WAKE >WAKE ! 10 PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 11 $4C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA 12 INY UP )Y LDA SP 1+ STA 1 # LDY 13 SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC 14 IP # LDX XPULL JMP END-CODE 15 ATARIVF.FB Scr 101 Dr 0 0 \ BUFFER MECHANISM 15DEC83KS) cas08jan07 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 102 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 103 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 104 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 105 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 106 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 107 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 108 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 109 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 110 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 111 Dr 0 0 \\ cas11aug06 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 112 Dr 0 0 \ LIMIT FIRST cas08jan07 1 2 $BC00 CONSTANT LIMIT 3 VARIABLE FIRST 4 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 113 Dr 0 0 \ ENDPOINTS OF FORGET 04JAN85BP/KS) cas08jan07 1 | : \? ( NFA -- FLAG ) C@ $20 AND ; 2 3 | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? 4 NAME> UNDER 1+ U< SWAP HEAP? OR ; 5 6 | : ENDPOINTS ( ADDR -- ADDR SYMB) 7 HEAP VOC-LINK @ >R 8 BEGIN R> @ ?DUP \ THROUGH ALL VOCABS 9 WHILE DUP >R 4 - >R \ LINK ON RETURNST. 10 BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR 11 SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR 12 WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP 13 R@ 2+ \? IF OVER R@ 2+ FORGET? 14 IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB 15 THEN REPEAT RDROP REPEAT ; ATARIVF.FB Scr 114 Dr 0 0 \ REMOVE 23JUL85WE 1 2 | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 3 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY 4 CLC UP )Y LDA 6 # ADC N 6 + STA 5 INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY 6 [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> 7 ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS 8 ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC 9 ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC 10 ]? CC 11 ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA 12 ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? 13 ]]? (DROP JMP END-CODE 14 15 ATARIVF.FB Scr 115 Dr 0 0 \ REMOVE- FORGET-WORDS 29APR85BP) 1 2 | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) 3 VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; 4 5 | : REMOVE-TASKS ( DIC --) 6 UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN 7 IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; 8 9 | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) 10 VOC-LINK REMOVE THRU.VOCSTACK 11 DO 2DUP I @ -ROT UWITHIN 12 IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 13 2DUP CURRENT @ -ROT UWITHIN 14 IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; 15 ATARIVF.FB Scr 116 Dr 0 0 \ FORGET-WORDS cas08jan07 1 2 DEFER CUSTOM-REMOVE 3 ' NOOP IS CUSTOM-REMOVE 4 5 6 | : FORGET-WORDS ( DIC SYMB --) 7 OVER REMOVE-TASKS REMOVE-VOCS 8 REMOVE-WORDS CUSTOM-REMOVE 9 HEAP SWAP - HALLOT DP ! 0 LAST ! ; 10 11 12 13 14 15 ATARIVF.FB Scr 117 Dr 0 0 \ DELETING WORDS FROM DICT. 13JAN83KS) 1 2 : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; 3 4 : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" 5 ENDPOINTS FORGET-WORDS ; 6 7 : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" 8 >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; 9 10 : EMPTY [ DP ] LITERAL @ 11 UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; 12 13 14 15 ATARIVF.FB Scr 118 Dr 0 0 \ SAVE BYE STOP? ?CR 20OCT84KS/BP) cas08jan07 1 2 : SAVE 3 HERE UP@ FORGET-WORDS VOC-LINK @ 4 BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL 5 UP@ ORIGIN $100 CMOVE ; 6 7 : BYE (BYE ; 8 9 | : END? KEY #CR = IF TRUE RDROP THEN ; 10 11 : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; 12 13 : ?CR COL C/L $A - U> IF CR THEN ; 14 15 ATARIVF.FB Scr 119 Dr 0 0 \ IN/OUTPUT STRUCTURE 02MAR85BP) cas08jan07 1 | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; 2 3 : OUTPUT: CREATE: DOES> OUTPUT ! ; 4 0 OUT: EMIT OUT: CR OUT: TYPE 5 OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP 6 7 : ROW ( -- ROW) AT? DROP ; 8 : COL ( -- COL) AT? NIP ; 9 10 | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; 11 12 : INPUT: CREATE: DOES> INPUT ! ; 13 14 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP 15 ATARIVF.FB Scr 120 Dr 0 0 \ ALIAS ONLY DEFINITIONEN 29JAN85BP) 1 2 ONLY DEFINITIONS FORTH 3 4 : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) 5 6 ' ONLY ALIAS ONLY 7 ' FORTH ALIAS FORTH 8 ' WORDS ALIAS WORDS 9 ' ALSO ALIAS ALSO 10 ' DEFINITIONS ALIAS DEFINITIONS 11 HOST TARGET 12 13 14 15 ATARIVF.FB Scr 121 Dr 0 0 \ 'COLD cas08jan07 1 | : INIT-VOCABULARYS VOC-LINK @ 2 BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; 3 4 DEFER 'COLD ' NOOP IS 'COLD 5 6 | : (COLD INIT-VOCABULARYS ONLYFORTH 'COLD PAGE LOGO COUNT TYPE 7 CR (RESTART ; -2 ALLOT 8 9 DEFER 'RESTART ' NOOP IS 'RESTART 10 11 | : (RESTART ['] (QUIT IS 'QUIT 12 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! 13 ['] NOOP IS 'ABORT ABORT ; -2 ALLOT 14 15 ATARIVF.FB Scr 122 Dr 0 0 \ COLD BOOTSYSTEM RESTART 09JUL85WE) cas08jan07 1 CODE COLD HERE >COLD ! 2 ' (COLD >BODY $100 U/MOD # LDA PHA # LDA PHA 3 LABEL BOOTSYSTEM CLI 0 # LDY 4 CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA 5 [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] 6 $C lda HERE 9 + sta $D lda HERE 5 + sta 7 LABEL WARMBOOT $e474 jsr BOOTNEXTLEN 1- # LDY 8 [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] 9 CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA 10 USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 11 USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 12 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA 13 PLA IP STA PLA IP 1+ STA 14 LABEL DOSINI 0 # lda $D sta 0 # lda $C sta 15 LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE ATARIVF.FB Scr 123 Dr 0 0 \ ( RESTART PARAM.-PASSING TO FORTH BP) cas08jan07 1 2 CODE RESTART HERE >RESTART ! 3 ' (RESTART >BODY $100 U/MOD 4 # LDA PHA # LDA PHA WARMBOOT JMP END-CODE 5 6 >RESTART @ $100 U/MOD DOSINI 1+ C! DOSINI 5 + C! 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 124 Dr 0 0 \ CODE FOR PARAMETER-PASSING TO FORTH cas11aug06 1 CR .( Include Atari 8bit IO definitions ) 2 include atariio.fb CR 3 4 HOST ' TRANSIENT 8 + @ 5 TRANSIENT FORTH CONTEXT @ 6 + ! 6 TARGET 7 8 FORTH ALSO DEFINITIONS 9 10 : FORTH-83 ; \ LAST WORD IN DICTIONARY 11 12 13 14 15 ATARIVF.FB Scr 125 Dr 0 0 \ SYSTEM DEPENDENT CONSTANTS BP/KS) 1 2 VOCABULARY ASSEMBLER 3 ASSEMBLER DEFINITIONS 4 TRANSIENT ASSEMBLER 5 PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK 6 PUSH0A CONSTANT PUSH0A \ PUT A ON STACK 7 PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK 8 RP CONSTANT RP 9 UP CONSTANT UP 10 SP CONSTANT SP 11 IP CONSTANT IP 12 N CONSTANT N 13 PUTA CONSTANT PUTA 14 W CONSTANT W 15 SETUP CONSTANT SETUP ATARIVF.FB Scr 126 Dr 0 0 \ NEXT XYNEXT LABELS cas11aug06 1 NEXT CONSTANT NEXT 2 XYNEXT CONSTANT XYNEXT 3 (2DROP CONSTANT POPTWO 4 (DROP CONSTANT POP 5 6 7 8 9 10 11 12 13 14 15 ATARIVF.FB Scr 127 Dr 0 0 \ SYSTEM PATCHUP cas11aug06 1 2 FORTH DEFINITIONS 3 4 $BC00 ' LIMIT >BODY ! $BC00 FIRST ! 5 $BA00 S0 ! $BB80 R0 ! 6 7 S0 @ DUP S0 2- ! 6 + S0 7 - ! 8 HERE DP ! 9 10 HOST TUDP @ TARGET UDP ! 11 HOST TVOC-LINK @ TARGET VOC-LINK ! 12 HOST MOVE-THREADS 13 14 15 ok