1 line
132 KiB
Plaintext
1 line
132 KiB
Plaintext
ende 123 \ volksFORTH Loadscreen for py65 target cas 02aug2020forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $1000 CONSTANT BASEADDR \ change target base address here BASEADDR DISPLACE ! TARGET DEFINITIONS BASEADDR HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED \ if this prints unresolved \ definitions, check code CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID cas 26jan06 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ Coldstartvalues and user variables cas 02aug2020\ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VolksForth-83 3.8.1 py65 02aug2020 CS" \ ZERO PAGE VARIABLES & NEXT cas 26jan06\ adjust this to match your architecture 20 DUP >LABEL RP 2+ DUP >LABEL UP 2+ DUP >LABEL PUTA 1+ DUP >LABEL SP 2+ DUP >LABEL NEXT DUP 5 + >LABEL IP 13 + >LABEL W W 8 + >LABEL N \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) LABEL BOOTNEXT -1 STA \ -1 IS DUMMY SP IP )Y LDA W 1+ STA -1 LDA W STA \ -1 IS DUMMY IP CLC IP LDA 2 # ADC IP STA CS NOT ?[ LABEL WJMP -1 ) JMP ]? IP 1+ INC WJMP BCS END-CODE \ Bootnext and Endtrace cas 26jan06HERE BOOTNEXT - >LABEL BOOTNEXTLEN CODE END-TRACE ( PATCH NEXT FOR TRACE ) 0A5 # LDA NEXT 0A + STA IP # LDA NEXT 0B + STA 069 # LDA NEXT 0C + STA 02 # LDA NEXT 0D + STA NEXT JMP END-CODE \ ;C: NOOP cas 26jan06 CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ manual forward reference for JMP command COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES cas 26jan06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 $5000 S0 ! USER R0 $5500 R0 ! USER DP USER OFFSET 0 OFFSET ! USER BASE &10 BASE ! USER OUTPUT USER INPUT USER ERRORHANDLER \ POINTER FOR ABORT" -CODE USER VOC-LINK USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020 CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA N # LDX LABEL XPUSH SP 2DEC 1 ,X LDA SP )Y STA 0 ,X LDA 0 # LDX PUTA JMP END-CODE CODE SP! ( ADDR --) SP X) LDA TAX SP )Y LDA SP 1+ STA SP STX 0 # LDX NEXT JMP END-CODE \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06CODE UP@ ( -- ADDR) UP # LDX XPUSH JMP END-CODE CODE UP! ( ADDR --) UP # LDX LABEL XPULL SP )Y LDA 1 ,X STA DEY SP )Y LDA 0 ,X STA LABEL (XYDROP 0 # LDX 1 # LDY LABEL (DROP SP 2INC NEXT JMP END-CODE RESTRICT \ MANIPULATE RETURNSTACK 16FEB85BP/KS) CODE RP@ ( -- ADDR ) RP # LDX XPUSH JMP END-CODE CODE RP! ( ADDR -- ) RP # LDX XPULL JMP END-CODE RESTRICT CODE >R ( 16B -- ) RP 2DEC SP X) LDA RP X) STA SP )Y LDA RP )Y STA (DROP JMP END-CODE RESTRICT \ R> (RDROP (NRDROP cas 26jan06CODE R> ( -- 16B) SP 2DEC RP X) LDA SP X) STA RP )Y LDA SP )Y STA LABEL (RDROP 2 # LDA LABEL (NRDROP CLC RP ADC RP STA CS ?[ RP 1+ INC ]? NEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT 08APR85BP) CODE R@ ( -- 16B) SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP END-CODE CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT CODE EXIT RP X) LDA IP STA RP )Y LDA IP 1+ STA (RDROP JMP END-CODE \ EXECUTE PERFORM 08APR85BP) CODE ?EXIT ( FLAG -- ) SP X) LDA SP )Y ORA PHP SP 2INC PLP ' EXIT @ BNE NEXT JMP END-CODE CODE EXECUTE ( ADDR --) SP X) LDA W STA SP )Y LDA W 1+ STA SP 2INC W 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; \ C@ C! CTOGGLE 10JAN85BP) CODE C@ ( ADDR -- 8B) SP X) LDA N STA SP )Y LDA N 1+ STA LABEL (C@ 0 # LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE C! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA DEY LABEL (2DROP SP LDA CLC 4 # ADC SP STA CS ?[ SP 1+ INC ]? NEXT JMP END-CODE \ @ ! +! 08APR85BP) er14dez88 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; CODE @ ( ADDR -- 16B) SP X) LDA N STA SP )Y LDA N 1+ STA N )Y LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE ! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA INY SP )Y LDA 1 # LDY LABEL (! N )Y STA (2DROP JMP END-CODE \ +! DROP cas 26jan06 CODE +! ( N ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA CLC N X) ADC N X) STA INY SP )Y LDA 1 # LDY N )Y ADC (! JMP END-CODE CODE DROP ( 16B --) (DROP HERE 2- ! END-CODE \ SWAP cas 26jan06CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) SP )Y LDA TAX 3 # LDY SP )Y LDA N STA TXA SP )Y STA N LDA 1 # LDY SP )Y STA INY 0 # LDX SP )Y LDA N STA SP X) LDA SP )Y STA DEY N LDA PUTA JMP END-CODE \ DUP ?DUP 08MAY85BP) cas 26jan06 CODE DUP ( 16B -- 16B 16B) SP 2DEC 3 # LDY SP )Y LDA 1 # LDY SP )Y STA INY SP )Y LDA DEY PUTA JMP END-CODE CODE ?DUP ( 16B -- 16B 16B / FALSE) SP X) LDA SP )Y ORA 0= ?[ NEXT JMP ]? ' DUP @ JMP END-CODE \\ ?DUP and DUP in FORTH \ : ?DUP ( 16B -- 16B 16B / FALSE) \ DUP IF DUP THEN ; \ : DUP SP@ @ ; \ OVER ROT 13JUN84KS) cas 26jan06 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) SP 2DEC 4 # LDY SP )Y LDA SP X) STA INY SP )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ ROT OVER in FORTH \ : ROT >R SWAP R> SWAP ; \ : OVER >R DUP R> SWAP ; \ ROT cas 26jan06CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY SP )Y LDA N 1+ STA 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 5 # LDY SP )Y LDA N STA N 1+ LDA SP )Y STA 1 # LDY N LDA SP )Y STA INY SP )Y LDA N 1+ STA SP X) LDA SP )Y STA 4 # LDY SP )Y LDA SP X) STA N 1+ LDA SP )Y STA 1 # LDY NEXT JMP END-CODE \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) ROT ROT ; : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \\ : -ROLL ( N --) >R DUP SP@ DUP 2+ DUP 2+ SWAP R@ 2* CMOVE R> 1+ 2* + ! ; \ DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; CODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE : 2DUP ( 32B -- 32B 32B) OVER OVER ; \ : 2DROP ( 32B -- ) DROP DROP ; \ + AND OR XOR 08APR85BP) COMPILER ASSEMBLER ALSO DEFINITIONS H : DYADOP ( OPCODE --) T INY SP X) LDA DUP C, SP C, SP )Y STA DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA (XYDROP JMP H ; TARGET CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE \ - NOT NEGATE 24DEC83KS) CODE - ( N1 N2 -- N3) INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE CODE NOT ( 16B1 -- 16B2) CLC LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; \ DNEGATE SETUP D+ 14JUN84KS) CODE DNEGATE ( D1 -- -D1) INY SEC TXA SP )Y SBC SP )Y STA INY TXA SP )Y SBC SP )Y STA TXA SP X) SBC SP X) STA 1 # LDY TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE LABEL SETUP ( QUAN IN A) .A ASL TAX TAY DEY [[ SP )Y LDA N ,Y STA DEY 0< ?] TXA CLC SP ADC SP STA CS ?[ SP 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE \ D+ cas 26jan06CODE D+ ( D1 D2 -- D3) 2 # LDA SETUP JSR INY SP )Y LDA CLC N 2+ ADC SP )Y STA INY SP )Y LDA N 3 + ADC SP )Y STA SP X) LDA N ADC SP X) STA 1 # LDY SP )Y LDA N 1+ ADC SP )Y STA NEXT JMP END-CODE \ 1+ 2+ 3+ 1- 2- 08APR85BP) CODE 1+ ( N1 -- N2) 1 # LDA LABEL N+ CLC SP X) ADC CS NOT ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # ADC SP )Y STA NEXT JMP END-CODE CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE \ NUMBER CONSTANTS 24DEC83KS) CODE 1- ( N1 -- N2) SEC LABEL (1- SP X) LDA 1 # SBC CS ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # SBC SP )Y STA NEXT JMP END-CODE CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE ' TRUE ALIAS -1 ' FALSE ALIAS 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 CODE CLIT ( -- 8B) SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC NEXT JMP END-CODE RESTRICT CODE LIT ( -- 16B) SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT : LITERAL ( 16B --) DUP 0FF00 AND IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; \ COMPARISION CODE WORDS 13JUN84KS) CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ LABEL PUTTRUE 0FF # LDA 024 C, ]? LABEL PUTFALSE TXA SP )Y STA PUTA JMP END-CODE CODE 0= ( 16B -- FLAG) SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP SP )Y LDA N 3 + SBC PUTTRUE BCS ]? PUTFALSE JMP END-CODE \ COMPARISION CODE WORDS 13JUN84KS) CODE < ( N1 N2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC N 1+ LDA SP )Y EOR ' 0< @ BMI SP X) LDA N CMP SP )Y LDA N 1+ SBC ' 0< @ 2+ JMP END-CODE CODE U< ( U1 U2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ PUTTRUE JMP ]? PUTFALSE JMP END-CODE \ COMPARISION WORDS 24DEC83KS) cas 02aug2020 | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; : D0= ( D -- FLAG) OR 0= ; : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; : D< ( D1 D2 -- FLAG) ROT 2DUP - IF > NIP NIP ELSE 2DROP U< THEN ; \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 | : MINIMAX ( N1 N2 FLAG -- N3) RDROP IF SWAP THEN DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; : ABS ( N -- U) EXTEND IF NEGATE THEN ; \ LOOP PRIMITIVES 08FEB85BP/KS) | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX \ LIMIT \ ADR.OF.DO" ON RETURN-STACK \ (LOOP (+LOOP 08APR85BP) CODE (LOOP CLC 1 # LDA RP X) ADC RP X) STA CS ?[ RP )Y LDA 0 # ADC RP )Y STA CS ?[ NEXT JMP ]? ]? LABEL DOLOOP 5 # LDY RP )Y LDA IP 1+ STA DEY RP )Y LDA IP STA 1 # LDY NEXT JMP END-CODE RESTRICT CODE (+LOOP CLC SP X) LDA RP X) ADC RP X) STA SP )Y LDA RP )Y ADC RP )Y STA .A ROR SP )Y EOR PHP SP 2INC PLP DOLOOP BPL NEXT JMP END-CODE RESTRICT \ LOOP INDICES 08APR85BP) CODE I ( -- N) 0 # LDY LABEL LOOPINDEX SP 2DEC CLC RP )Y LDA INY INY RP )Y ADC SP X) STA DEY RP )Y LDA INY INY RP )Y ADC 1 # LDY SP )Y STA NEXT JMP END-CODE RESTRICT CODE J ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 24DEC83KS) CODE BRANCH CLC IP LDA IP X) ADC N STA IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA NEXT JMP END-CODE RESTRICT CODE ?BRANCH SP X) LDA SP )Y ORA PHP SP 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : <MARK ( -- ADDR) HERE ; : <RESOLVE ( ADDR --) HERE - , ; : ?PAIRS ( N1 N2 -- ) - ABORT" UNSTRUCTURED" ; \ CASE? 04MAY85BP) LABEL PUSHA 0 # CMP 0< ?[ PHA 0FF # LDA ][ LABEL PUSH0A PHA 0 # LDA ]? LABEL PUSH TAX SP 2DEC TXA 1 # LDY SP )Y STA PLA 0 # LDX PUTA JMP CODE CASE? ( 16B1 16B2 -- 16B1 FALSE / TRUE ) 1 # LDA SETUP JSR N LDA SP X) CMP 0= ?[ N 1+ LDA SP )Y CMP 0= ?[ PUTTRUE JMP ]? ]? TXA PUSH0A JMP END-CODE \\ : CASE? ( 16B1 16B2 -- 16B1 FALSE / TRUE ) OVER = DUP IF NIP THEN ; \ BRANCHING 03FEB85BP) : IF COMPILE ?BRANCH >MARK 1 ; IMMEDIATE RESTRICT : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ELSE 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : BEGIN <MARK 2 ; IMMEDIATE RESTRICT : WHILE 2 ?PAIRS 2 COMPILE ?BRANCH >MARK -2 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL <RESOLVE BEGIN DUP -2 = WHILE DROP >RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ LOOPS 29JAN85KS/BP) : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : LOOP 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +LOOP 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ RETURNSTACK: CALLADR \ INDEX LIMIT \ ADR OF DO \ UM* BP/KS13.2.85) CODE UM* ( U1 U2 -- UD) SP )Y LDA N STA SP X) LDA N 1+ STA INY N 2 + STX N 3 + STX 010 # LDX [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA INY SP )Y LDA DEY N 2 + ADC N 2 + STA CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? DEX 0= ?] N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY N LDA SP )Y STA N 1+ LDA SP X) STA NEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; \ M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R IF NEGATE THEN SWAP DUP 0< IF NEGATE R> NOT >R THEN UM* R> IF DNEGATE THEN ; : * ( N N -- PROD) UM* DROP ; CODE 2* ( N1 -- N2) SP X) LDA .A ASL SP X) STA SP )Y LDA .A ROL SP )Y STA NEXT JMP END-CODE | : 2* DUP + ; \ UM/MOD 04JUL84KS) | : DIVOVL TRUE ABORT" DIVISION OVERFLOW" ; CODE UM/MOD ( UD U -- UREM UQUOT) SP X) LDA N 5 + STA SP )Y LDA N 4 + STA SP 2INC SP X) LDA N 1+ STA SP )Y LDA N STA INY SP )Y LDA N 3 + STA INY SP )Y LDA N 2+ STA 011 # LDX CLC [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC TAY N LDA N 4 + SBC CS NOT ?[ N 6 + ROL ]? CS ?[ N STA N 1+ STY ]? \ N 3 + ROL N 2+ ROL N 1+ ROL N ROL DEX 0= ?] 1 # LDY N ROR N 1+ ROR CS ?[ ;C: DIVOVL ; ASSEMBLER ]? N 2+ LDA SP )Y STA INY N 1+ LDA SP )Y STA INY N LDA SP )Y STA 1 # LDY N 3 + LDA PUTA JMP END-CODE \ 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< IF UNDER + SWAP THEN UM/MOD R@ 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- THEN THEN RDROP ; CODE 2/ ( N1 -- N2) SP )Y LDA .A ASL SP )Y LDA .A ROR SP )Y STA SP X) LDA .A ROR PUTA JMP END-CODE \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; : / ( N1 N2 -- QUOT) /MOD NIP ; : MOD ( N1 N2 -- REM) /MOD DROP ; : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; : UD/MOD ( UD1 U2 -- UREM UDQUOT) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ CMOVE CMOVE> (CMOVE> BP 08APR85) CODE CMOVE ( FROM TO QUAN --) 3 # LDA SETUP JSR DEY [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 1 # LDY NEXT JMP ]? ]? N 4 + )Y LDA N 2+ )Y STA INY 0= ?] N 5 + INC N 3 + INC ]] END-CODE \ CMOVE> MOVE cas 26jan06CODE CMOVE> ( FROM TO QUAN --) 3 # LDA SETUP JSR CLC N 1+ LDA N 3 + ADC N 3 + STA CLC N 1+ LDA N 5 + ADC N 5 + STA N 1+ INC N LDY CLC CS ?[ LABEL (CMOVE> DEY N 4 + )Y LDA N 2+ )Y STA ]? TYA (CMOVE> BNE N 3 + DEC N 5 + DEC N 1+ DEC (CMOVE> BNE 1 # LDY NEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN R> CMOVE ; \ PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; CODE COUNT ( ADDR -- ADDR+1 LEN) SP X) LDA N STA CLC 1 # ADC SP X) STA SP )Y LDA N 1+ STA 0 # ADC SP )Y STA SP 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; \ FILL 11JUN85BP) CODE FILL ( ADDR QUAN 8B -- ) 3 # LDA SETUP JSR DEY N LDA N 3 + LDX 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] N 5 + INC DEX 0= ?] ]? N 2+ LDX 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] ]? 1 # LDY NEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE 042 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT \ INPUT STRINGS 24DEC83KS) VARIABLE #TIB 0 #TIB ! VARIABLE >TIB $100 >TIB ! \ 050 ALLOT VARIABLE >IN 0 >IN ! VARIABLE BLK 0 BLK ! VARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; \ SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL 03APR85BP) (C LABEL (CAPITAL \ FOR COMMODORE ONLY PHA 0DF # AND \ 2ND UPPER TO LOWER ASCII A # CMP CS ?[ ASCII Z 1+ # CMP CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS ]? ]? PLA RTS END-CODE ) LABEL (CAPITAL \ FOR ASCII ONLY ASCII a # CMP CS ?[ ASCII z 1+ # CMP CC ?[ SEC ASCII a ASCII A - # SBC ]? ]? RTS END-CODE CODE CAPITAL ( CHAR -- CHAR' ) SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE \ CAPITALIZE 03APR85BP) CODE CAPITALIZE ( STRING -- STRING ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA DEY [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? INY N )Y LDA (CAPITAL JSR N )Y STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; \\ CAPITAL ( CHAR -- CHAR ) ASCII A ASCII Z 1+ UWITHIN IF I C@ [ ASCII A ASCII A - ] LITERAL - ; \ (WORD 08APR85BP) | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ N : LENGTH OF SOURCE \ N+2 : PTR IN SOURCE / NEXT CHAR \ N+4 : STRING START ADRESS \ N+6 : STRING LENGTH N 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA \ >IN+ADR0 =: N+2 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA \ LEN0->IN =: N N 1+ LDA >IN 1+ SBC N 1+ STA CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED SP )Y LDA >IN 1+ STA \ (WORD 08APR85BP) ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 0= ?[[ N 2+ WINC N WDEC ]]? N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS N 3 + LDA N 5 + STA [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR N 2+ WINC N WDEC PLP 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH N LDA N 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) N 2+ LDA SP )Y SBC >IN STA INY N 3 + LDA SP )Y SBC >IN 1+ STA \ (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA SP ADC SP STA CS ?[ SP 1+ INC ]? \ 2DROP USER' DP # LDY UP )Y LDA SP X) STA N STA INY UP )Y LDA 1 # LDY SP )Y STA N 1+ STA \ DP @ DEY N 6 + LDA \ STORE COUNT BYTE FIRST [[ N )Y STA N 4 + )Y LDA INY N 6 + DEC 0< ?] 020 # LDA N )Y STA \ ADD A BLANK 1 # LDY NEXT JMP END-CODE \ SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; : WORD ( CHAR -- ADDR) SOURCE (WORD ; : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; \\ : WORD ( CHAR -- ADDR) >R SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R ROT OVER SWAP - R> 0<> - >IN ! OVER - HERE PLACE BL HERE COUNT + C! HERE ; \ STATE ASCII ," (" " 24DEC83KS) VARIABLE STATE 0 STATE ! : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT : (" "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ASCII ) PARSE 2DROP ; IMMEDIATE : .( ASCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; \ NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ASCII 0 - DUP 9 U> IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; | : END? ( -- FLAG ) PTR @ 0= ; | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; \ ?NONUM ?NUM FIXBASE? 13FEB85KS) VARIABLE DPL -1 DPL ! | : ?NONUM ( FLAG -- EXIT IF TRUE ) IF RDROP 2DROP DROP RDROP FALSE THEN ; | : ?NUM ( FLAG -- EXIT IF TRUE ) IF RDROP DROP R> IF DNEGATE THEN ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ASCII & CASE? IF 0A TRUE EXIT THEN ASCII $ CASE? IF 10 TRUE EXIT THEN ASCII H CASE? IF 10 TRUE EXIT THEN ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ (NUMBER NUMBER 13FEB85KS) : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0.0 ROT END? ?NONUM CHAR ASCII - CASE? IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? IF BASE ! END? ?NONUM CHAR THEN BEGIN DIGIT? 0= ?NONUM BEGIN ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= UNTIL PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR REPEAT ; : NUMBER ( STRING -- D ) NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; \ HIDE REVEAL IMMEDIATE RESTRICT KS) VARIABLE LAST 0 LAST ! | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; : REVEAL LAST? IF 2- CURRENT @ ! THEN ; : RECURSIVE REVEAL ; IMMEDIATE RESTRICT | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; : IMMEDIATE 040 FLAG! ; : RESTRICT 080 FLAG! ; \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 CODE CLEARSTACK USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY NEXT JMP END-CODE : HALLOT ( QUAN -- ) S0 @ OVER - SWAP SP@ 2+ DUP ROT - DUP S0 ! 2 PICK OVER - MOVE CLEARSTACK S0 ! ; : HEAP ( -- ADDR) S0 @ 6+ ; : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; \ DOES> ; 30DEC84KS/BP) LABEL (DODOES> RP 2DEC IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP CLC W X) LDA 3 # ADC IP STA TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP LABEL DOCREATE 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE | : (;CODE R> LAST @ NAME> ! ; : DOES> COMPILE (;CODE 04C C, COMPILE (DODOES> ; IMMEDIATE RESTRICT \ 6502-ALIGN ?HEAD \ 08SEP84BP) | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; | : 6502-ALIGN/2 ( LFA -- LFA ) HERE 0FF AND 0FF = IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT THEN ; VARIABLE ?HEAD 0 ?HEAD ! : | ?HEAD @ ?EXIT -1 ?HEAD ! ; \ WARNING CREATE 30DEC84BP) VARIABLE WARNING 0 WARNING ! | : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; : CREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , ;CODE DOCREATE JMP END-CODE \ NFA? 30DEC84BP) | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA N 2+ ORA 0= ?[ PUTFALSE JMP ]? N 2+ )Y LDA SP )Y STA N 1+ STA N 2+ X) LDA SP X) STA N STA N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK N 2INC N X) LDA PHA SEC 01F # AND N ADC N STA CS ?[ N 1+ INC ]? PLA 020 # AND 0= NOT ?[ N )Y LDA PHA N X) LDA N STA PLA N 1+ STA ]? N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT \ >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK BEGIN @ DUP WHILE 2DUP 4 - SWAP NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE ELSE ." ???" THEN SPACE ; \ : ; CONSTANT VARIABLE 09JAN85KS/BP) : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA NEXT JMP END-CODE : ; 0 ?PAIRS COMPILE EXIT [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : CONSTANT ( 16B --) CREATE , ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE : VARIABLE CREATE 2 ALLOT ; \ UALLOT USER ALIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + 0FF U> ABORT" USERAREA FULL" UDP @ SWAP UDP +! ; : USER CREATE 2 UALLOT C, ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE : ALIAS ( CFA --) CREATE LAST @ DUP C@ 020 AND IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; \ VOC-LINK VP CURRENT CONTEXT ALSO BP) CREATE VP 10 ALLOT VARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER : ALSO VP @ 0A > ERROR" VOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) : VOCABULARY CREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK VOCABULARY FORTH VOCABULARY ONLY ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ BEGIN @ DUP STOP? 0= AND WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; \ (FIND 08APR85BP) CODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] N 2+ X) LDA 01F # AND N 4 + STA LABEL FINDLOOP 0 # LDY N )Y LDA TAX INY N )Y LDA N 1+ STA N STX N ORA 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? INY N )Y LDA 01F # AND N 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA N ADC N 5 + STA 0 # LDA N 1+ ADC N 6 + STA N 4 + LDY [[ N 2+ )Y LDA N 5 + )Y CMP \ FINDLOOP BNE DEY 0= ?] 3 # LDY N 6 + LDA SP )Y STA DEY N 5 + LDA SP )Y STA DEY 0 # LDX PUTTRUE JMP END-CODE \ FOUND 29JAN85BP) | CODE FOUND ( NFA -- CFA N ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA 01F # AND SEC N ADC N STA CS ?[ N 1+ INC ]? N 2+ LDA 020 # AND 0= ?[ N LDA SP X) STA N 1+ LDA ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA SP 2DEC N 2+ LDA 0< ?[ INY ]? .A ASL 0< NOT ?[ TYA 0FF # EOR TAY INY ]? TYA SP X) STA 0< ?[ 0FF # LDA 24 C, ]? TXA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ | : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ 020 AND IF @ THEN -1 R@ 080 AND IF 1- THEN R> 040 AND IF NEGATE THEN ; \ FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = IF 2- THEN BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN OVER VP 2+ U> WHILE SWAP 2- REPEAT NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ABORT" HAEH?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ >INTERPRET 28FEB85BP) LABEL JUMP INY CLC W )Y LDA 2 # ADC IP STA INY W )Y LDA 0 # ADC IP 1+ STA 1 # LDY NEXT JMP END-CODE VARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE VARIABLE >INTERPRET TO SPECIAL DEFER \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 ' NO.EXTENSIONS IS NOTFOUND : INTERPRET >INTERPRET ; -2 ALLOT | : INTERACTIVE ?STACK NAME FIND ?DUP IF 1 AND IF EXECUTE >INTERPRET THEN ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT ' INTERACTIVE >INTERPRET ! \ COMPILING [ ] 20DEC84BP) | : COMPILING ?STACK NAME FIND ?DUP IF 0> IF EXECUTE >INTERPRET THEN , >INTERPRET THEN NULLSTRING? ?EXIT NUMBER? ?DUP IF 0> IF SWAP [COMPILE] LITERAL THEN [COMPILE] LITERAL ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE : ] ['] COMPILING IS >INTERPRET STATE ON ; \ PERFOM DEFER IS 03FEB85BP) | : CRASH TRUE ABORT" CRASH" ; : DEFER CREATE ['] CRASH , ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE : (IS R> DUP 2+ >R @ ! ; | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; : IS ( ADR -- ) ' DUP DEF? >BODY STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE \ ?STACK 08SEP84KS) cas 15july2020 | : STACKFULL ( -- ) DEPTH 20 > ABORT" TIGHT STACK" REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; CODE ?STACK USER' DP # LDY SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? USER' S0 # LDY UP )Y LDA SP CMP INY UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN SP@ S0 @ U> ABORT" STACK EMPTY" ; \ .STATUS PUSH LOAD 08SEP84KS) DEFER .STATUS ' NOOP IS .STATUS | CREATE PULL 0 ] R> R> ! ; : PUSH ( ADDR -- ) R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT : LOAD ( BLK --) ?DUP 0= ?EXIT BLK PUSH BLK ! >IN PUSH >IN OFF .STATUS INTERPRET ; \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) : +LOAD ( OFFSET --) BLK @ + LOAD ; : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; \ QUIT (QUIT ABORT 07JUN85BP) | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; : (QUIT BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT DEFER 'QUIT ' (QUIT IS 'QUIT : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; DEFER 'ABORT ' NOOP IS 'ABORT : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT \ (ERROR ABORT" ERROR" 20MAR85BP) VARIABLE SCR 1 SCR ! VARIABLE R# 0 R# ! : (ERROR ( STRING -- ) STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT ' (ERROR ERRORHANDLER ! : (ABORT" "LIT SWAP IF >R CLEARSTACK R> ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ -TRAILING 08APR85BP) 020 CONSTANT BL CODE -TRAILING ( ADDR N1 -- ADR N2 ) TYA SETUP JSR SP X) LDA N 2+ STA CLC SP )Y LDA N 1+ ADC N 3 + STA N LDY CLC CS ?[ LABEL (-TRAIL DEY N 2+ )Y LDA BL # CMP 0<> ?[ INY 0= ?[ N 1+ INC ]? TYA PHA N 1+ LDA PUSH JMP ]? ]? TYA (-TRAIL BNE N 3 + DEC N 1 + DEC (-TRAIL BPL TYA PUSH0A JMP END-CODE \ SPACE SPACES 29JAN85KS/BP) : SPACE BL EMIT ; : SPACES ( U --) 0 ?DO SPACE LOOP ; \\ : -TRAILING ( ADDR N1 -- ADDR N2) 2DUP BOUNDS ?DO 2DUP + 1- C@ BL - IF LEAVE THEN 1- LOOP ; \ HOLD <# #> SIGN # #S 24DEC83KS) | : HLD ( -- ADDR) PAD 2- ; : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; : <# HLD HLD ! ; : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < IF [ ASCII A ASCII 9 - 1- ] LITERAL + THEN ASCII 0 + HOLD ; : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; \ PRINT NUMBERS 24DEC83KS) : D.R -ROT UNDER DABS <# #S ROT SIGN #> ROT OVER MAX OVER - SPACES TYPE ; : .R SWAP EXTEND ROT D.R ; : U.R 0 SWAP D.R ; : D. 0 D.R SPACE ; : . EXTEND D. ; : U. 0 D. ; \ .S LIST C/L L/S 24DEC83KS) : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 40 CONSTANT C/L \ SCREEN LINE LENGTH 10 CONSTANT L/S \ LINES PER SCREEN : LIST ( BLK --) SCR ! ." SCR " SCR @ DUP U. ." DR " DRV? . L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK I C/L * + C/L -TRAILING TYPE LOOP CR ; \ MULTITASKER PRIMITIVES BP03NOV85) CODE PAUSE NEXT HERE 2- ! END-CODE : LOCK ( ADDR --) DUP @ UP@ = IF DROP EXIT THEN BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; : UNLOCK ( ADDR --) DUP LOCK OFF ; LABEL WAKE WAKE >WAKE ! PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC IP # LDX XPULL JMP END-CODE \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ size of buffer \\ structure of buffer (same for all volksFORTH ) cas 26jan06 0 : LINK 2 : FILE 6 : BLOCKNR 8 : STATUSFLAGS 0A : DATA .. 1 KB .. STATUSFLAG BITS: 15 1 -> UPDATED FILE = -1 EMPTY BUFFER = 0 NO FCB , DIRECT ACCESS = ELSE ADR OF FCB ( SYSTEM DEPENDENT ) \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) LABEL THISBUFFER? 2 # LDY [[ N 4 + )Y LDA N 2- ,Y CMP 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) \ N-AREA : 0 BLK 2 FILE 4 BUFFER \ 6 PREDECESSOR 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ \ " 11JUN85BP) LABEL BLOCKFOUND SP 2INC 1 # LDY 8 # LDA CLC N 4 + ADC SP X) STA N 5 + LDA 0 # ADC SP )Y STA ' EXIT @ JMP ]? [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA N 6 + X) LDA N 4 + STA 1 # LDY N 6 + )Y LDA N 5 + STA N 4 + ORA 0= ?[ ( LIST EMPTY ) NEXT JMP ]? THISBUFFER? JSR 0= ?] \ FOUND, RELINK N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA BLOCKFOUND JMP END-CODE \\ (CORE? 23SEP85BP | : this? ( blk file bufadr -- flag ) DUP 4+ @ SWAP 2+ @ D= ; | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) BEGIN OVER OFFSET @ + OVER PREV @ THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN 2DUP >R OFFSET @ + >R PREV @ BEGIN DUP @ ?DUP 0= IF RDROP RDROP DROP EXIT THEN DUP R> R> 2DUP >R >R ROT THIS? 0= WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! RDROP RDROP REPEAT ; -2 ALLOT \ (DISKERR 11JUN85BP) : (DISKERR ." ERROR ! R TO RETRY " KEY DUP ASCII R = SWAP ASCII R = OR NOT ABORT" ABORTED" ; DEFER DISKERR ' (DISKERR IS DISKERR DEFER R/W \ BACKUP EMPTYBUF READBLK 11JUN85BP) | : BACKUP ( BUFADDR --) DUP 6+ @ 0< IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 IF INPUT PUSH OUTPUT PUSH STANDARDI/O BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W WHILE ." WRITE " DISKERR REPEAT THEN 080 OVER 4+ 1+ CTOGGLE THEN DROP ; | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W WHILE ." READ " DISKERR REPEAT R> ; \ TAKE MARK UPDATES? FULL? CORE? BP) | : TAKE ( -- BUFADDR) PREV BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL BUFFERS LOCK DUP BACKUP ; | : MARK ( BLK FILE BUFADDR -- BLK FILE ) 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! R> 4+ OFF BUFFERS UNLOCK ; | : UPDATES? ( -- BUFADDR / FLAG) PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; \ BLOCK & BUFFER MANIPULATION 11JUN85BP) : (BUFFER ( BLK FILE -- ADDR) BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT : (BLOCK ( BLK FILE -- ADDR) BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT | CODE FILE@ ( -- N ) USER' FILE # LDY UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; \ BLOCK & BUFFER MANIPULATION 09SEP84KS) : UPDATE 080 PREV @ 6+ 1+ C! ; : SAVE-BUFFERS BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT BUFFERS UNLOCK ; : EMPTY-BUFFERS BUFFERS LOCK PREV BEGIN @ ?DUP WHILE DUP EMPTYBUF REPEAT BUFFERS UNLOCK ; : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; \ MOVING BLOCKS 15DEC83KS) cas 26jan06| : (COPY ( FROM TO --) DUP FILE@ CORE? IF PREV @ EMPTYBUF THEN FULL? IF SAVE-BUFFERS THEN OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R OVER R@ + OVER U> >R 2DUP U< R> AND IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP THEN SAVE-BUFFERS 2DROP ; : COPY ( FROM TO --) 1 BLKMOVE ; : CONVEY ( [BLK1 BLK2] [TO.BLK --) SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; \ ALLOCATING BUFFERS 23SEP83KS) 12jan13py F000 CONSTANT LIMIT VARIABLE FIRST : ALLOTBUFFER ( -- ) FIRST @ R0 @ - B/BUF 2+ U< ?EXIT B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF PREV @ OVER ! PREV ! ; : FREEBUFFER ( -- ) FIRST @ LIMIT B/BUF - U< IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; \ ENDPOINTS OF FORGET 04JAN85BP/KS) | : \? ( NFA -- FLAG ) C@ 020 AND ; | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? NAME> UNDER 1+ U< SWAP HEAP? OR ; | : ENDPOINTS ( ADDR -- ADDR SYMB) HEAP VOC-LINK @ >R BEGIN R> @ ?DUP \ THROUGH ALL VOCABS WHILE DUP >R 4 - >R \ LINK ON RETURNST. BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP R@ 2+ \? IF OVER R@ 2+ FORGET? IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB THEN REPEAT RDROP REPEAT ; \ REMOVE 23JUL85WE | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY CLC UP )Y LDA 6 # ADC N 6 + STA INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC ]? CC ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? ]]? (DROP JMP END-CODE \ REMOVE- FORGET-WORDS 29APR85BP) | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; | : REMOVE-TASKS ( DIC --) UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) VOC-LINK REMOVE THRU.VOCSTACK DO 2DUP I @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 2DUP CURRENT @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ DELETING WORDS FROM DICT. 13JAN83KS) : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" ENDPOINTS FORGET-WORDS ; : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; : EMPTY [ DP ] LITERAL @ UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; \ SAVE BYE STOP? ?CR 20OCT84KS/BP) : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE FLUSH EMPTY (BYE ; | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; : ?CR COL C/L 0A - U> IF CR THEN ; \ IN/OUTPUT STRUCTURE 02MAR85BP) | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; : OUTPUT: CREATE ] DOES> OUTPUT ! ; 0 OUT: EMIT OUT: CR OUT: TYPE OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP : ROW ( -- ROW) AT? DROP ; : COL ( -- COL) AT? NIP ; | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; : INPUT: CREATE ] DOES> INPUT ! ; 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP \ ALIAS ONLY DEFINITIONEN 29JAN85BP) ONLY DEFINITIONS FORTH : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) ' ONLY ALIAS ONLY ' FORTH ALIAS FORTH ' WORDS ALIAS WORDS ' ALSO ALIAS ALSO ' DEFINITIONS ALIAS DEFINITIONS HOST TARGET \ 'COLD 07JUN85BP) cas 02aug2020| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH ." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) CODE COLD HERE >COLD ! ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM CLI 0 # LDY CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] LABEL WARMBOOT BOOTNEXTLEN 1- # LDY [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA PLA IP STA PLA IP 1+ STA LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 \ Include system dependent Input / Output code \ (Keyboard and Screen) include systemio.fb HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET FORTH ALSO DEFINITIONS : FORTH-83 ; \ LAST WORD IN DICTIONARY \ SYSTEM DEPENDENT CONSTANTS BP/KS) VOCABULARY ASSEMBLER ASSEMBLER DEFINITIONS TRANSIENT ASSEMBLER PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK PUSH0A CONSTANT PUSH0A \ PUT A ON STACK PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK RP CONSTANT RP UP CONSTANT UP SP CONSTANT SP IP CONSTANT IP N CONSTANT N PUTA CONSTANT PUTA W CONSTANT W SETUP CONSTANT SETUP \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ SYSTEM PATCHUP 05JAN85BP) cas 26jan06 FORTH DEFINITIONS \ change memory layout for stacks and buffers here 6000 ' LIMIT >BODY ! $5800 S0 ! $5B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS |