mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
1 line
132 KiB
Plaintext
1 line
132 KiB
Plaintext
ende 123 \ cas30dec06forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $2800 DISPLACE ! TARGET DEFINITIONS $2800 HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID 10JAN85BP) er14dez88 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ HIER BEGINNEN DIE KALTSTARTWERTE DER cas30dec06\ BENUTZERVARIABLEN 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT ," VOLKSFORTH-83 3.5 COMPILED 30DEC06CS" \ ZERO PAGE VARIABLES & NEXT 03APR85BP) CAS20JAN07 D0 DUP >LABEL RP 2+ .( 02 durch D0 ersetzt ) 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 \ HERE 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 24MAY84KS) CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ HANDGESTRICKTE VORWAERTS REFERENZ FUER \ DEN JMP-BEFEHL COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES 17MAR84KS) cas30dec06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER USER S0 $7000 S0 ! USER R0 $7500 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) 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 \ CODE 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 \ CODE 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 SWAP 24MAY84KS) 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 \ CODE 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) 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 ( 16B -- 16B 16B / FALSE) DUP IF DUP THEN ; : DUP SP@ @ ; \ OVER ROT 13JUN84KS) 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 >R SWAP R> SWAP ; : OVER >R DUP R> SWAP ; \ er14dez88CODE 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) : -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 \ CODE 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) | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) NEGATE 0< ; : 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 KS) | : 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 \ CODE 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) CAS20JAN07 : SOURCE ( -- ADDR LEN) 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?11FEB85BP) 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) DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" HAEH?" ; \ 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) | : 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) CAS20JAN07 : .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 \ 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) USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ PHYSIKALISCHE GROESSE \\ STRUCTUR EINES BUFFERS: 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) CAS20JAN07 \ " 11JUN85BP) CAS20JAN07 \\ (CORE? 23SEP85BP CAS20JAN07 \ (DISKERR 11JUN85BP) CAS20JAN07 \ BACKUP EMPTYBUF READBLK 11JUN85BP) CAS20JAN07 \ TAKE MARK UPDATES? FULL? CORE? BP) CAS20JAN07 \ BLOCK & BUFFER MANIPULATION 11JUN85BP) CAS20JAN07 \ BLOCK & BUFFER MANIPULATION 09SEP84KS) CAS20JAN07 \ MOVING BLOCKS 15DEC83KS) CAS20JAN07 \ ALLOCATING BUFFERS 23SEP83KS) CAS20JAN07 7400 CONSTANT LIMIT VARIABLE FIRST \ 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 ( 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) CAS20JAN07 : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE 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) cas21jan07| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS PAGE 'COLD ONLYFORTH ." VolksForth-83 REV 3.5" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) cas21jan07CODE COLD HERE >COLD ! SEI $E2 C, $30 C, SEC $FB C, ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM 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 CAS20JAN07 include serial.scr HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET \ KOTZ WUERG ! 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) cas30dec06 FORTH DEFINITIONS 7000 ' LIMIT >BODY ! $7800 S0 ! $7B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS |