\ *** Block No. 0 Hexblock 0 ende 123 \ *** Block No. 1 Hexblock 1 \ volksFORTH Loadscreen cas2013apr05 forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $0300 CONSTANT BASEADDR \ base address of forth image $7F00 CONSTANT TOPADDR 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) \ *** Block No. 2 Hexblock 2 \ FORTH PREAMBLE AND ID cas20130405 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ *** Block No. 3 Hexblock 3 \ Coldstartvalues and user variables cas2013apr05 \ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VolksForth-83 3.8 COMPILED 05apr13CS" \ *** Block No. 4 Hexblock 4 \ 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 \ *** Block No. 5 Hexblock 5 \ 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 \ *** Block No. 6 Hexblock 6 \ Bootnext and Endtrace cas 26jan06 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 \ *** Block No. 7 Hexblock 7 \ ;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 \ *** Block No. 8 Hexblock 8 \ USER VARIABLES cas2013apr05 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 TOPADDR $F00 - S0 ! USER R0 TOPADDR $480 - 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 \ *** Block No. 9 Hexblock 9 \ 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 \ *** Block No. 10 Hexblock A \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06 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 \ *** Block No. 11 Hexblock B \ 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 \ *** Block No. 12 Hexblock C \ R> (RDROP (NRDROP cas 26jan06 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 \ *** Block No. 13 Hexblock D \ 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 \ *** Block No. 14 Hexblock E \ 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 ; \ *** Block No. 15 Hexblock F \ 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 \ *** Block No. 16 Hexblock 10 \ @ ! +! 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 \ *** Block No. 17 Hexblock 11 \ +! 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 \ *** Block No. 18 Hexblock 12 \ SWAP cas 26jan06 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 \ *** Block No. 19 Hexblock 13 \ 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@ @ ; \ *** Block No. 20 Hexblock 14 \ 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 ; \ *** Block No. 21 Hexblock 15 \ ROT cas 26jan06 CODE 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 \ *** Block No. 22 Hexblock 16 \ -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* + ! ; \ *** Block No. 23 Hexblock 17 \ 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 ; \ *** Block No. 24 Hexblock 18 \ + 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 \ *** Block No. 25 Hexblock 19 \ - 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 + ; \ *** Block No. 26 Hexblock 1A \ 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 \ *** Block No. 27 Hexblock 1B \ D+ cas 26jan06 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 \ *** Block No. 28 Hexblock 1C \ 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 \ *** Block No. 29 Hexblock 1D \ 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 ! ; \ *** Block No. 30 Hexblock 1E \ 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@ ; \ *** Block No. 31 Hexblock 1F \ 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 \ *** Block No. 32 Hexblock 20 \ 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 \ *** Block No. 33 Hexblock 21 \ 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 ; \ *** Block No. 34 Hexblock 22 \ 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 ; \ *** Block No. 35 Hexblock 23 \ 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 \ *** Block No. 36 Hexblock 24 \ (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 \ *** Block No. 37 Hexblock 25 \ 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 \ *** Block No. 38 Hexblock 26 \ 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 \ *** Block No. 39 Hexblock 27 \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : 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 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ *** Block No. 42 Hexblock 2A \ 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 \ *** Block No. 43 Hexblock 2B \ 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 ; \ *** Block No. 44 Hexblock 2C \ 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 + ; \ *** Block No. 45 Hexblock 2D \ 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 ]? \ *** Block No. 46 Hexblock 2E \ 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 \ *** Block No. 47 Hexblock 2F \ 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 \ *** Block No. 48 Hexblock 30 \ /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> ; \ *** Block No. 49 Hexblock 31 \ 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 \ *** Block No. 50 Hexblock 32 \ CMOVE> MOVE cas 26jan06 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 ; \ *** Block No. 51 Hexblock 33 \ 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 ; \ *** Block No. 52 Hexblock 34 \ 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 ; \ *** Block No. 53 Hexblock 35 \ 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 \ *** Block No. 54 Hexblock 36 \ 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 ; \ *** Block No. 55 Hexblock 37 \ 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 - ; \ *** Block No. 56 Hexblock 38 \ 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 \ *** Block No. 57 Hexblock 39 \ 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 - ; \ *** Block No. 58 Hexblock 3A \ (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 \ *** Block No. 59 Hexblock 3B \ (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 \ *** Block No. 60 Hexblock 3C \ (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 \ *** Block No. 61 Hexblock 3D \ 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 ; \ *** Block No. 62 Hexblock 3E \ 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 \ *** Block No. 63 Hexblock 3F \ ." ( .( \ \\ 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 ! ; \ *** Block No. 64 Hexblock 40 \ 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 ; \ *** Block No. 65 Hexblock 41 \ ?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 ; \ *** Block No. 66 Hexblock 42 \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ *** Block No. 67 Hexblock 43 \ (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 ; \ *** Block No. 68 Hexblock 44 \ 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! ; \ *** Block No. 69 Hexblock 45 \ 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 ; \ *** Block No. 70 Hexblock 46 \ 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 \ *** Block No. 71 Hexblock 47 \ 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 ! ; \ *** Block No. 72 Hexblock 48 \ 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 \ *** Block No. 73 Hexblock 49 \ 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 \ *** Block No. 74 Hexblock 4A \ >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 ; \ *** Block No. 75 Hexblock 4B \ : ; 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 ; \ *** Block No. 76 Hexblock 4C \ 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> ! ; \ *** Block No. 77 Hexblock 4D \ 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 +! ; \ *** Block No. 78 Hexblock 4E \ 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 ; \ *** Block No. 79 Hexblock 4F \ 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 ; \ *** Block No. 80 Hexblock 50 \ (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 \ *** Block No. 81 Hexblock 51 \ 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 \ *** Block No. 82 Hexblock 52 \ 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 \ *** Block No. 83 Hexblock 53 \\ | : 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 ; \ *** Block No. 84 Hexblock 54 \ FIND ' ['] 13JAN85BP) cas2013apr05 : 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" WHAT?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ *** Block No. 85 Hexblock 55 \ >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 \ *** Block No. 86 Hexblock 56 \ 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 ! \ *** Block No. 87 Hexblock 57 \ 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 ; \ *** Block No. 88 Hexblock 58 \ 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 \ *** Block No. 89 Hexblock 59 \ ?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" ; \ *** Block No. 90 Hexblock 5A \ .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 ; \ *** Block No. 91 Hexblock 5B \ +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/ ; \ *** Block No. 92 Hexblock 5C \ 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 \ *** Block No. 93 Hexblock 5D \ (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 \ *** Block No. 94 Hexblock 5E \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ *** Block No. 95 Hexblock 5F \ -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 \ *** Block No. 96 Hexblock 60 \ 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 ; \ *** Block No. 97 Hexblock 61 \ 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 ; \ *** Block No. 98 Hexblock 62 \ 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. ; \ *** Block No. 99 Hexblock 63 \ .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 ; \ *** Block No. 100 Hexblock 64 \ 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 \ *** Block No. 101 Hexblock 65 \ 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 \ *** Block No. 102 Hexblock 66 \\ 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 ) \ *** Block No. 103 Hexblock 67 \ 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= ?[ \ *** Block No. 104 Hexblock 68 \ " 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 \ *** Block No. 105 Hexblock 69 \\ (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 \ *** Block No. 106 Hexblock 6A \ (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 \ *** Block No. 107 Hexblock 6B \ 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> ; \ *** Block No. 108 Hexblock 6C \ 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 No. 109 Hexblock 6D \ 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 No. 110 Hexblock 6E \ 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 ; \ *** Block No. 111 Hexblock 6F \ 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 ; \ *** Block No. 112 Hexblock 70 \ ALLOCATING BUFFERS 23SEP83KS) cas2013apr04 7F00 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 ; \ *** Block No. 113 Hexblock 71 \ 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 ; \ *** Block No. 114 Hexblock 72 \ 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 \ *** Block No. 115 Hexblock 73 \ 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 ; \ *** Block No. 116 Hexblock 74 \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ *** Block No. 117 Hexblock 75 \ 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 ! ; \ *** Block No. 118 Hexblock 76 \ 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 ; \ *** Block No. 119 Hexblock 77 \ 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 \ *** Block No. 120 Hexblock 78 \ 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 \ *** Block No. 121 Hexblock 79 \ 'COLD 07JUN85BP) cas2013apr05 | : 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.7 05apr13 CS" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ *** Block No. 122 Hexblock 7A \ 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 \ *** Block No. 123 Hexblock 7B \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ *** Block No. 124 Hexblock 7C \ 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 \ *** Block No. 125 Hexblock 7D \ 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 \ *** Block No. 126 Hexblock 7E \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ *** Block No. 127 Hexblock 7F \ SYSTEM PATCHUP 05JAN85BP) cas2013apr05 FORTH DEFINITIONS \ change memory layout for stacks and buffers here TOPADDR ' LIMIT >BODY ! TOPADDR $F00 - S0 ! TOPADDR $480 - R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS ) \ *** Block No. 128 Hexblock 80 \ *** Block No. 129 Hexblock 81 \ *** Block No. 130 Hexblock 82 \ *** Block No. 131 Hexblock 83