diff --git a/.gitignore b/.gitignore index 384673c..519a541 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.fossil *.log +/.DS_Store diff --git a/sources/Apple1/2words.fth b/sources/Apple1/2words.fth new file mode 100644 index 0000000..d71d3fb --- /dev/null +++ b/sources/Apple1/2words.fth @@ -0,0 +1,68 @@ +\ *** Block No. 0 Hexblock 0 +\ Additional definitions for 32bit values cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ 2Words Loadscreen cas 26jan06 + +hex + &2 &3 thru +decimal + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE) + +CODE 2! ( D ADR --) + TYA SETUP JSR 3 # LDY + [[ SP )Y LDA N )Y STA DEY 0< ?] + 1 # LDY POPTWO JMP END-CODE + +CODE 2@ ( ADR -- D) + SP X) LDA N STA SP )Y LDA N 1+ STA + SP 2DEC 3 # LDY + [[ N )Y LDA SP )Y STA DEY 0< ?] + XYNEXT JMP END-CODE + + + + +\ *** Block No. 3 Hexblock 3 +\ + +: 2VARIABLE ( --) CREATE 4 ALLOT ; + ( -- ADR) + +: 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ; + +\ 2DUP EXISTS +\ 2SWAP EXISTS +\ 2DROP EXISTS + + + + + + diff --git a/sources/Apple1/6502f83.fth b/sources/Apple1/6502f83.fth new file mode 100644 index 0000000..85cb140 --- /dev/null +++ b/sources/Apple1/6502f83.fth @@ -0,0 +1,2244 @@ +\ *** 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 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/as65.fth b/sources/Apple1/as65.fth new file mode 100644 index 0000000..1db870a --- /dev/null +++ b/sources/Apple1/as65.fth @@ -0,0 +1,204 @@ +\ *** Block No. 0 Hexblock 0 +\ FORTH-6502 ASSEMBLER WFR ) cas 26jan06 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) + +Load from Screen 1 for the transient assembler: +This 6502 Forth Assembler can be loaded into the heap +and then not be saved in the final binary to save memory. + +Load from Screen 2 for the regular assembler: +This 6502 Forth Assembler will be loaded into normal +memory and will be saved into the final binary. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) + +( INTERNAL LOADING 04MAY85BP/RE) +hex +\ HERE $200 HALLOT HEAP DP ! + &10 LOAD + &11 LOAD + 3 &8 THRU + &9 LOAD \ for System-Assembler + +\ DP ! + +ONLYFORTH +decimal + +\ *** Block No. 2 Hexblock 2 +\ FORTH-65 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) +ONLYFORTH +Vocabulary tassembler +TASSEMBLER ALSO DEFINITIONS +hex + + 8 +load \ relocate +1 6 +THRU +\ 7 +load \ System Assembler +decimal + + + + + +\ *** Block No. 3 Hexblock 3 +\ FORTH-83 6502-ASSEMBLER ) er14dez88 +: END-CODE CONTEXT 2- @ CONTEXT ! ; +CREATE INDEX +09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c, +09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c, +80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c, +80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c, + +| VARIABLE MODE + +: MODE: ( N -) CREATE C, DOES> ( -) C@ MODE ! ; + +0 MODE: .A 1 MODE: # 2 | MODE: MEM 3 MODE: ,X +4 MODE: ,Y 5 MODE: X) 6 MODE: )Y 0F MODE: ) +6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +\ *** Block No. 4 Hexblock 4 +\ UPMODE CPU ) er14dez88 +| : UPMODE ( ADDR0 F0 - ADDR1 F1) + IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F AND ?DUP IF + 0 DO DUP + LOOP THEN OVER 1+ @ AND 0= ; + +: CPU ( 8B -) CREATE C, DOES> ( -) C@ >c, MEM ; + + 00 CPU BRK 18 CPU CLC D8 CPU CLD + 58 CPU CLI B8 CPU CLV CA CPU DEX + 88 CPU DEY E8 CPU INX C8 CPU INY + EA CPU NOP 48 CPU PHA 08 CPU PHP + 68 CPU PLA 28 CPU PLP 40 CPU RTI + 60 CPU RTS 38 CPU SEC F8 CPU SED + 78 CPU SEI AA CPU TAX A8 CPU TAY + BA CPU TSX 8A CPU TXA 9A CPU TXS + 98 CPU TYA +\ *** Block No. 5 Hexblock 5 +\ M/CPU ) er14dez88 + +: M/CPU ( MODE OPCODE -) CREATE C, , DOES> + DUP 1+ @ 80 AND IF 10 MODE +! THEN OVER FF00 AND UPMODE UPMODE + IF MEM TRUE ABORT" INVALID" THEN + C@ MODE @ INDEX + C@ + >c, MODE @ 7 AND + IF MODE @ 0F AND 7 < IF >c, ELSE >, THEN THEN MEM ; + + 1C6E 60 M/CPU ADC 1C6E 20 M/CPU AND 1C6E C0 M/CPU CMP + 1C6E 40 M/CPU EOR 1C6E A0 M/CPU LDA 1C6E 00 M/CPU ORA + 1C6E E0 M/CPU SBC 1C6C 80 M/CPU STA 0D0D 01 M/CPU ASL + 0C0C C1 M/CPU DEC 0C0C E1 M/CPU INC 0D0D 41 M/CPU LSR + 0D0D 21 M/CPU ROL 0D0D 61 M/CPU ROR 0414 81 M/CPU STX + 0486 E0 M/CPU CPX 0486 C0 M/CPU CPY 1496 A2 M/CPU LDX + 0C8E A0 M/CPU LDY 048C 80 M/CPU STY 0480 14 M/CPU JSR + 8480 40 M/CPU JMP 0484 20 M/CPU BIT +\ *** Block No. 6 Hexblock 6 +\ ASSEMBLER CONDITIONALS ) er14dez88 + +| : RANGE? ( BRANCH -- BRANCH ) + DUP ABS 07F U> ABORT" OUT OF RANGE " ; + +: [[ ( BEGIN) >here ; +: ?] ( UNTIL) >c, >here 1+ - RANGE? >c, ; +: ?[ ( IF) >c, >here 0 >c, ; +: ?[[ ( WHILE) ?[ SWAP ; +: ]? ( THEN) >here OVER >c@ IF SWAP >! + ELSE OVER 1+ - RANGE? SWAP >c! THEN ; +: ][ ( ELSE) >here 1+ 1 JMP + SWAP >here OVER 1+ - RANGE? SWAP >c! ; +: ]] ( AGAIN) JMP ; +: ]]? ( REPEAT) JMP ]? ; + +\ *** Block No. 7 Hexblock 7 +\ ASSEMBLER CONDITIONALS ) er14dez88 + +90 CONSTANT CS B0 CONSTANT CC +D0 CONSTANT 0= F0 CONSTANT 0<> +10 CONSTANT 0< 30 CONSTANT 0>= +50 CONSTANT VS 70 CONSTANT VC + +: NOT 20 [ FORTH ] XOR ; + +: BEQ 0<> ?] ; : BMI 0>= ?] ; +: BNE 0= ?] ; : BPL 0< ?] ; +: BCC CS ?] ; : BVC VS ?] ; +: BCS CC ?] ; : BVS VC ?] ; + + + +\ *** Block No. 8 Hexblock 8 +\ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88 + +: 2INC + DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ; + +: 2DEC + DUP LDA SEC 2 # SBC DUP STA CC ?[ SWAP 1+ DEC ]? ; + +: WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; + +: WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; + +: ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; + + + +\ *** Block No. 9 Hexblock 9 +\ ;CODE CODE CODE> BP 03 02 85) er14dez88 +ONLYFORTH + +: ASSEMBLER ASSEMBLER [ ASSEMBLER ] MEM ; + +: ;CODE [COMPILE] DOES> -3 >allot + [COMPILE] ; -2 >allot ASSEMBLER ; IMMEDIATE + +: CODE CREATE >here DUP 2- >! ASSEMBLER ; + +: >LABEL ( ADR -) + >here | CREATE SWAP , 4 HALLOT + HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE + HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ; + +: LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ; +\ *** Block No. 10 Hexblock A +\ Code generating primitives er14dez88 + +Variable >codes +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate nrc >codes ! ; nonrelocate + +| : >exec Create c, + Does> c@ >codes @ + @ execute ; + +| 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +| 6 >exec >here | 8 >exec >allot | $0A >exec >! +| $0C >exec >c! + + + +\ *** Block No. 11 Hexblock B +\ FORTH-65 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) +ONLYFORTH + +ASSEMBLER ALSO DEFINITIONS + + + + + + + + + + + diff --git a/sources/Apple1/assemble.fth b/sources/Apple1/assemble.fth new file mode 100644 index 0000000..d52fb7e --- /dev/null +++ b/sources/Apple1/assemble.fth @@ -0,0 +1,323 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Assembler *** 25may86we + +Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. +Der Assembler basiert auf dem von Michael Perry fr F83 entwik- +kelten, enth„lt aber einige zus„tzliche Features. +Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels +verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler +kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner +Tat die Code-Worte mit einem Disassembler zu berprfen. + +Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten +Assembler auf den Heap laden kann, damit er w„hrend der Kompila- +tionszeit zur Verfgung steht, aber keinen Platz im Dictionary +verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, +wenn er nicht mehr ben”tigt wird. + +\ *** Block No. 1 Hexblock 1 +\ 68000 Assembler Load Screen 26oct86we + +Onlyforth +Vocabulary Assembler Assembler also definitions + +: end-code context 2- @ context ! ; +' swap | Alias *swap + +base @ 4 $11 +thru base ! + +: reg) size push .l 0 *swap FP DI) ; +: Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp + >here next-link @ , next-link ! ; + +2 3 +thru Onlyforth + +\ *** Block No. 2 Hexblock 2 +\ Internal Assembler 09sep86we + +Onlyforth + +here + $1300 hallot heap dp ! -1 +load +dp ! + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Extended adressing modes 09sep86we + +: R#) ( addr -- ) size push + [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) + [ Forth ] exit THEN .w FP D) ; + + +| : inrange? ( addr -- offset f ) [ Forth ] + >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN + dup >here negate > ; +: pcrel) ( addr -- ) \ pc-relativ adressing mode + inrange? [ Forth ] 0= abort" out of range" pcd) ; + +: ;c: 0 recover R#) jsr end-code ] ; + + +\ *** Block No. 4 Hexblock 4 +\ Assembler Forth words 09sep86we +Forth definitions +: Assembler Assembler [ Assembler ] .w ; +: Code Create here dup 2- ! Assembler ; + +| : (;code r> last @ name> ! ; +: ;Code 0 ?pairs compile (;code [compile] [ reveal + Assembler ; immediate restrict + +: >label ( addr -- ) here | Create swap , immediate + 4 hallot >here 4- heap 4 cmove + heap last @ count $1F and + even ! dp ! + Does> ( -- addr ) @ + state @ IF [compile] Literal THEN ; +: Label [ Assembler ] >here [ Forth ] 1 and + [ Assembler ] >allot >here >label Assembler ; +\ *** Block No. 5 Hexblock 5 +\ Code generating primitives 26oct86we + +Variable >codes +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate nrc >codes ! ; nonrelocate + +| : >exec Create c, + Does> c@ >codes @ + @ execute ; + +| 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +| 6 >exec >here | 8 >exec >allot | $0A >exec >! +| $0C >exec >c! + + + +\ *** Block No. 6 Hexblock 6 +\ 68000 Meta Assembler 04sep86we + +| : ?, IF >, THEN >, ; +| : 2, >, >, ; +8 base ! +Variable size +: .b 10000 size ! ; +: .w 30100 size ! ; .w +: .l 24600 size ! ; + +| : Sz Constant Does> @ size @ and or ; +00300 | Sz sz3 00400 | Sz sz4 +04000 | Sz sz40 30000 | Sz sz300 + +| : long? size @ 24600 = ; +| : -sz1 long? IF 100 or THEN ; +\ *** Block No. 7 Hexblock 7 +\ addressing modes 09sep86we + +| : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; +| : Mode Constant Does> @ *swap 7007 and or ; +0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 +0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 +0220 Mode ) \ address register indirect +0330 Mode )+ \ adr reg ind post-increment +0440 Mode -) \ adr reg ind pre-decrement +0550 Mode D) \ adr reg ind displaced +0660 Mode (DI) \ adr reg ind displaced indexed s.u. +0770 Constant #) \ immediate address +1771 Constant L#) \ immediate long address +2772 Constant pcD) \ pc relative displaced +3773 Constant (pcDI) \ pc relative displaced indexed +4774 Constant # \ immediate data +\ *** Block No. 8 Hexblock 8 +\ fields and register assignments 08sep86we + +| : Field Constant Does> @ and ; +7000 | Field rd 0007 | Field rs +0070 | Field ms 0077 | Field eas +0377 | Field low +| : dn? ( ea -- ea flag ) dup ms 0= ; +| : src ( ea instr -- ea instr' ) over eas or ; +| : dst ( ea instr -- ea instr' ) *swap rd or ; + +| : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; +| : ??an ( mod -- mod ) dup ms 1 = + abort" needs Adress-Register" ; + +A6 Constant SP A5 Constant RP A4 Constant IP +A3 Constant FP +\ *** Block No. 9 Hexblock 9 +\ extended addressing 09sep86we +: DI) (DI) size @ *swap ; +: pcDI) (pcDI) size @ *swap ; + +| : double? ( mode -- flag) dup L#) = *swap + # = long? and or ; +| : index? ( {n} mode -- {m} mode ) + dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or + IF size @ >r size ! + dup rd 10 * *swap ms IF 100000 or THEN + sz40 *swap low or r> size ! + THEN r> ; + +| : more? ( ea -- ea flag ) dup ms 0040 > ; +| : ,more ( ea -- ) more? + IF index? double? ?, ELSE drop THEN ; +\ *** Block No. 10 Hexblock A +\ extended addressing extras 09sep86we + +| Create extra here 5 dup allot erase \ temporary storage area + +| : extra? ( {n} mode -- mode ) more? + IF >r r@ index? double? extra 1+ *swap + IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> + ELSE 0 extra ! + THEN ; + +| : ,extra ( -- ) extra c@ ?dup + IF extra 1+ *swap 1 = + IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase + THEN ; + + +\ *** Block No. 11 Hexblock B +\ immediates & address register specific 15jan86we +| : Imm Constant Does> @ >r extra? eas r> or + sz3 >, long? ?, ,extra ; ( n ea) +0000 Imm ori 1000 Imm andi +2000 Imm subi 3000 Imm addi +5000 Imm eori 6000 Imm cmpi +| : Immsr Constant Does> @ sz3 2, ; ( n ) +001074 Immsr andi>sr +005074 Immsr eori>sr +000074 Immsr ori>sr +| : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or + r> or sz3 >, ,extra ; ( n ea ) +050000 Iq addq 050400 Iq subq +| : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) +150300 Ieaa adda 130300 Ieaa cmpa +040700 Ieaa lea 110300 Ieaa suba +\ *** Block No. 12 Hexblock C +\ shifts, rotates, and bit manipulation 15jan86we +| : Isr Constant Does> @ >r dn? + IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN + rd *swap rs or r> or 160000 or sz3 >, + ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or + 160000 or >, ,more + THEN ; ( dm dn ) ( m # dn ) ( ea ) +400 Isr asl 000 Isr asr +410 Isr lsl 010 Isr lsr +420 Isr roxl 020 Isr roxr +430 Isr rol 030 Isr ror +| : Ibit Constant does> @ >r extra? dn? + IF rd src 400 ELSE drop dup eas 4000 THEN + or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) +000 Ibit btst 100 Ibit bchg +200 Ibit bclr 300 Ibit bset +\ *** Block No. 13 Hexblock D +\ branch, loop, and set conditionals 15jan86we + +| : Setclass ' *swap 0 DO I over execute LOOP drop ; +| : Ibra 400 * 060000 or Constant ( label ) + Does> @ *swap >here 2+ - dup abs 200 < + IF low or >, ELSE *swap 2, THEN ; +20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq + bvc bvs bpl bmi bge blt bgt ble +| : Idbr 400 * 050310 or Constant ( label \ dn - ) + Does> @ *swap rs or >, >here - >, ; +20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq + dbvc dbvs dbpl dbmi dbge dblt dbgt dble +| : Iset 400 * 050300 or Constant ( ea ) + Does> @ src >, ,more ; +20 Setclass Iset set sno shi sls scc scs sne seq + svc svs spl smi sge slt sgt sle +\ *** Block No. 14 Hexblock E +\ moves 15jan86we + +: move extra? 7700 and src sz300 >, + ,more ,extra ; ( ea ea ) +: moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) +: move>usp ??an rs 047140 or >, ; ( an ) +: move, ; ( an ) +: movem> + extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) +: movem< + extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) +: movep dn? IF rd *swap rs or 410 or + ELSE rs rot rd or 610 or THEN -sz1 2, ; + ( dm d an ) ( d an dm ) +: lmove 7700 and *swap eas or 20000 or >, ; + ( long reg move ) +\ *** Block No. 15 Hexblock F +\ odds and ends 15jan86we + +: cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) +: exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r + ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap + THEN rs dst r> or >, ; ( rn rm ) +: ext ??dn rs 044200 or -sz1 >, ; ( dn ) +: swap ??dn rs 044100 or >, ; ( dn ) +: stop 47162 2, ; ( n ) +: trap 17 and 47100 or >, ; ( n ) +: link ??an rs 047120 or 2, ; ( n an ) +: unlk ??an rs 047130 or >, ; ( an ) +: eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) +: cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) + + +\ *** Block No. 16 Hexblock 10 +\ arithmetic and logic 15jan86we +| : Ibcd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) +140400 Ibcd abcd 100400 Ibcd sbcd +| : Idd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) +150400 Idd addx 110400 Idd subx +| : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) + IF rd src r> or sz3 >, ,more + ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; +150000 Idea add 110000 Idea sub +140000 Idea and 100000 Idea or +| : Iead Constant Does> @ >r ??dn r> dst src + >, ,more ; ( ea dn) +040600 Iead chk 100300 Iead divu 100700 Iead divs +140300 Iead mulu 140700 Iead muls +\ *** Block No. 17 Hexblock 11 +\ arithmetic and control 15jan86we + +| : Iea Constant Does> @ src >, ,more ; ( ea ) +047200 Iea jsr 047300 Iea jmp +042300 Iea move>ccr +040300 Iea movesr +044000 Iea nbcd 044100 Iea pea +045300 Iea tas +| : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) +041000 Ieas clr 043000 Ieas not +042000 Ieas neg 040000 Ieas negx +045000 Ieas tst +| : Icon Constant Does> @ >, ; +47160 Icon reset 47161 Icon nop +47163 Icon rte 47165 Icon rts +47166 Icon trapv 47167 Icon rtr +\ *** Block No. 18 Hexblock 12 +\ structured conditionals +/- 256 bytes 15jan86we +: THEN >here over 2+ - *swap 1+ >c! ; +: IF >, >here 2- ; hex +: ELSE 6000 IF *swap THEN ; +: BEGIN >here ; +: UNTIL >, >here - >here 1- >c! ; +: AGAIN 6000 UNTIL ; +: WHILE IF *swap ; +: REPEAT AGAIN THEN ; +: DO >here *swap ; +: LOOP dbra ; +6600 Constant 0= 6700 Constant 0<> +6A00 Constant 0< 6B00 Constant 0>= +6C00 Constant < 6D00 Constant >= +6E00 Constant <= 6F00 Constant > +6500 Constant CC 6400 Constant CS diff --git a/sources/Apple1/ccompile.fth b/sources/Apple1/ccompile.fth new file mode 100644 index 0000000..74f658e --- /dev/null +++ b/sources/Apple1/ccompile.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\ Crosscompile Script for 6502 Target cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for cross-compiler cas 26jan06 + +include assemble.fb \ load 68000 assembler +2 loadfrom as65.fb page \ load 6502 assembler +include crostarg.fb page \ load target compiler +include 6502f83.fb \ load Forth Kernel Source + +save-target f6502.com \ save new forth as f6502.com +key drop page .( Ready ) cr \ wait for keypress +bye \ and exit forth + + + + + + diff --git a/sources/Apple1/crostarg.fth b/sources/Apple1/crostarg.fth new file mode 100644 index 0000000..9f0e056 --- /dev/null +++ b/sources/Apple1/crostarg.fth @@ -0,0 +1,680 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** volksFORTH-84 Target-Compiler *** cas 26jan06 + +This Target Compiler can be used to create a new Forth System +using the Sourcecode 6502F82.FB. + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr 09sep86we +\ Idea and first Implementation by ks/bp +\ Implemented on 6502 by ks/bp +\ ultraFORTH83-Version by bp/we +\ Atari 520 ST - Version by we +Onlyforth Assembler nonrelocate +07 Constant imagepage \ Virtual memory bank +Vocabulary Ttools +Vocabulary Defining +: .stat .blk .s ; ' .stat Is .status +\ : 65( [compile] ( ; immediate +: 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| + 1 $14 +thru \ Target compiler +$15 $17 +thru \ Target Tools +$18 $1A +thru \ Redefinitions +save $1B $24 +thru \ Predefinitions +\ *** Block No. 2 Hexblock 2 +\ Target header pointers bp05mar86we + +Variable tdp : there tdp @ ; +Variable displace +Variable ?thead 0 ?thead ! +Variable tlast 0 tlast ! +Variable glast' 0 glast' ! +Variable tdoes> +Variable >in: +Variable tvoc 0 tvoc ! +Variable tvoc-link 0 tvoc-link ! +Variable tnext-link 0 tnext-link ! + +: c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + +\ *** Block No. 3 Hexblock 3 +\ Image and byteorder 15sep86we + +: >image ( addr1 - addr2 ) displace @ - ; + +: >heap ( from quan - ) + heap over - 1 and + \ 68000-align + dup hallot heap swap cmove ; +\\ +: >ascii 2drop ; ' noop Alias C64>ascii + +Code Lc@ ( laddr -- 8b ) +.l SP )+ A0 move .w D0 clr .b A0 ) D0 move +.w D0 SP -) move Next end-code +Code Lc! ( 8b addr -- ) +.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move +Next end-code +\ *** Block No. 4 Hexblock 4 +\ Ghost-creating 05mar86we + +0 | Constant 0 | Constant + +| : Make.ghost ( - cfa.ghost ) + here dup 1 and allot here + state @ IF context @ ELSE current THEN @ + dup @ , name + dup c@ 1 $1F uwithin not abort" inval.Gname" + dup c@ 1+ over c! + c@ dup 1+ allot 1 and 0= IF bl c, THEN + here 2 pick - -rot + , 0 , 0 , + swap here over - >heap + heap swap ! swap dp ! + heap + ; +\ *** Block No. 5 Hexblock 5 +\ ghost words 05mar86we + +: gfind ( string - cfa tf / string ff ) + dup count + 1+ bl swap c! + dup >r 1 over c+! find -1 r> c+! ; + +: ghost ( - cfa ) + >in @ name gfind IF nip exit THEN + drop >in ! Make.ghost ; + +: Word, ghost execute ; + +: gdoes> ( cfa.ghost - cfa.does ) + 4+ dup @ IF @ exit THEN + here dup , 0 , 4 >heap + dp ! heap dup rot ! ; +\ *** Block No. 6 Hexblock 6 +\ ghost utilities 04dec85we + +: g' name gfind 0= abort" ?" ; + +: '. + g' dup @ case? + IF ." forw" ELSE - abort" ??" ." res" THEN + 2+ dup @ 5 u.r + 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + +' ' Alias h' + + +\ *** Block No. 7 Hexblock 7 +\ .unresolved 05mar86we + +| : forward? ( cfa - cfa / exit&true ) + dup @ = over 2+ @ and IF drop true rdrop exit THEN ; + +| : unresolved? ( addr - f ) + 2+ dup c@ $1F and over + c@ BL = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + +: .unresolved voc-link @ + BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; +\ *** Block No. 8 Hexblock 8 +\ Extending Vocabularys for Target-Compilation 05mar86we + +: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + +Vocabulary Transient 0 tvoc ! + +Only definitions Forth also + +: T Transient ; immediate +: H Forth ; immediate + +definitions + + + + +\ *** Block No. 9 Hexblock 9 +\ Transient primitives 05mar86we + +Code byte> ( 8bh 8bl -- 16b ) + SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move + .w D0 SP ) move Next end-code +Code >byte ( 16b -- 8bl 8bh ) + SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr + D0 SP -) move D1 SP -) move Next end-code + +Transient definitions +: c@ H >image imagepage lc@ ; +: c! H >image imagepage lc! ; +: @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; +: ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; +: cmove ( from.mem to.target quan -) + bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +\ *** Block No. 10 Hexblock A +\ Transient primitives bp05mar86we + +: here there ; +: allot Tdp +! ; +: c, T here c! 1 allot H ; +: , T here ! 2 allot H ; + +: ," Ascii " parse dup T c, + under there swap cmove + .( dup 1 and 0= IF 1+ THEN ) allot H ; + +: fill ( addr quan 8b -) + -rot bounds ?DO dup I T c! H LOOP drop ; +: erase 0 T fill ; +: blank bl T fill ; +: here! H Tdp ! ; +\ *** Block No. 11 Hexblock B +\ Resolving 08dec85we +Forth definitions +: resolve ( cfa.ghost cfa.target -) + over dup @ = + IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN + >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! + H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + +: resdoes> ( cfa.ghost cfa.target -) + swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +' >body ! +] Does> [ here 4- 0 ] @ T , H ; +' >body ! +\ *** Block No. 12 Hexblock C +\ move-threads 68000-align cas 26jan06 + +: move-threads Tvoc @ Tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + error" some undef. Target-Vocs left" drop ; + +| : tlatest ( - addr) current @ 6 + ; + +\\ +not used for the 6502 architecture + +| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; + + + +\ *** Block No. 13 Hexblock D +\ save-target 09sep86we + +Dos definitions + +Code (filewrite ( buff len handle -- n) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + .l 0 imagepage # D1 move .w SP )+ D1 move + .l D1 A7 -) move \ buffer adress + .l D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $40 # A7 -) move \ call WRITE + 1 trap $0C # A7 adda + .w D0 SP -) move Next end-code Forth definitions + + + +\ *** Block No. 14 Hexblock E +\ save Target-System 09sep86we + +: save-target [ Dos ] + bl word count dup 0= abort" missing filename" + over + off (createfile dup >r 0< abort" no device " + T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header + 0 there r@ (filewrite there - abort" write error" + r> (closefile 0< abort" close error" ; + + + + + + + + +\ *** Block No. 15 Hexblock F +\\ 6502-ALIGN ?HEAD \ 08SEP84BP) + +| : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ; + + +| : 6502-align/2 ( lfa -- lfa ) + there 0FF and 0FF = + IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid + 1 tlast +! 1 tallot THEN ; + + + + + + + +\ *** Block No. 16 Hexblock 10 +\\ 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. 17 Hexblock 11 +\ compiling names into targ. 05mar86we + +: (theader + ?thead @ IF 1 ?thead +! + there $FF and $FF = IF 1 T allot H THEN exit THEN + >in @ name swap >in ! + dup c@ 1 $20 uwithin not abort" inval. Tname" + dup c@ 3 + there + $FF and $FF = + there 2+ $FF and $FF = or IF 1 T allot H THEN + blk @ T , H there tlatest dup @ T , H ! there dup tlast ! + over c@ 1+ .( even ) dup T allot cmove H ; + +: Theader tlast off + (theader Ghost dup glast' ! + there resolve ; + +\ *** Block No. 18 Hexblock 12 +\ prebuild defining words bp27jun85we + +| : executable? ( adr - adr f ) dup ; +| : tpfa, there , ; +| : (prebuild ( cfa.adr -- ) + >in @ Create >in ! here 2- ! ; + +: prebuild ( adr 0.from.: - 0 ) + 0 ?pairs executable? dup >r + IF [compile] Literal compile (prebuild ELSE drop THEN + compile Theader Ghost gdoes> , + r> IF compile tpfa, THEN 0 ; immediate restrict + + + + +\ *** Block No. 19 Hexblock 13 +\ code portion of def.words bp11sep86we + +: dummy 0 ; + +: DO> ( - adr.of.jmp.dodoes> 0 ) + [compile] Does> here 4- compile @ 0 ] ; + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ the 68000 Assembler 11sep86we + +Forth definitions +| Create relocate ] T c, , c@ here allot ! c! H [ + +Transient definitions + +: Assembler H [ Tassembler ] relocate >codes ! Tassembler ; +: >label ( 16b -) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; +: Label T .( here 1 and allot ) here >label Assembler H ; +: Code H Theader there 2+ T , Assembler H ; + + + + +\ *** Block No. 21 Hexblock 15 +\ immed. restr. ' \ compile bp05mar86we + +: ?pairs ( n1 n2 -- ) H - abort" unstructured" ; +: >mark ( - addr ) H there T 0 , H ; +: >resolve ( addr - ) H there over - swap T ! H ; +: - cfa ) H g' dup @ - abort" ?" 2+ @ ; +: | H ?thead @ ?exit ?thead on ; +: compile H Ghost , ; immediate restrict + + +\ *** Block No. 22 Hexblock 16 +\ Target tools ks05mar86we + +Onlyforth Ttools also definitions + +| : ttype ( adr n -) bounds ?DO I T c@ H dup + bl > IF emit ELSE drop Ascii . emit THEN LOOP ; +: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + ELSE ." ??? " THEN space ?cr ; +| : nfa? ( cfa lfa - nfa / cfa ff) + BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = + IF 2+ nip exit THEN + T @ H REPEAT ; +: >name ( cfa - nfa / ff) + Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup + IF nip exit THEN + swap REPEAT nip ; +\ *** Block No. 23 Hexblock 17 +\ Ttools for decompiling ks05mar86we + +| : ?: dup 4 u.r ." :" ; +| : @? dup T @ H 6 u.r ; +| : c? dup T c@ H 3 .r ; + +: s ( addr - addr+ ) ?: space c? 3 spaces + dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + +: n ( addr - addr+2 ) ?: @? 2 spaces + dup T @ H [ Ttools ] >name .name H 2+ ; + +: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP + 2 spaces -rot ttype ; + + +\ *** Block No. 24 Hexblock 18 +\ Tools for decompiling bp05mar86we + +: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; + +: c ( addr -- addr+1 ) 1 d ; + +: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; + +: dump ( adr n -) bounds ?DO cr I $10 d drop + stop? IF LEAVE THEN $10 +LOOP ; + +: view T ' H [ Ttools ] >name ?dup + IF 4- T @ H l THEN ; + + + +\ *** Block No. 25 Hexblock 19 +\ reinterpretation def.-words 05mar86we + +Onlyforth + +: redefinition + tdoes> @ IF >in push [ ' >interpret >body ] Literal push + state push context push >in: @ >in ! + name [ ' Transient 2+ ] Literal (find nip 0= + IF cr ." Redefinition: " here .name + >in: @ >in ! : Defining interpret THEN + THEN 0 tdoes> ! ; + + + + + +\ *** Block No. 26 Hexblock 1A +\ Create..does> structure bp05mar86we + +| : (;tcode + Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; +| : changecfa compile lit tdoes> @ , compile (;tcode ; + +Defining definitions + +: ;code 0 ?pairs changecfa reveal rdrop ; + immediate restrict + +Defining ' ;code Alias does> immediate restrict + +: ; [compile] ; rdrop ; immediate restrict + + +\ *** Block No. 27 Hexblock 1B +\ redefinition conditionals bp27jun85we + +' DO Alias DO immediate restrict +' ?DO Alias ?DO immediate restrict +' LOOP Alias LOOP immediate restrict +' IF Alias IF immediate restrict +' THEN Alias THEN immediate restrict +' ELSE Alias ELSE immediate restrict +' BEGIN Alias BEGIN immediate restrict +' UNTIL Alias UNTIL immediate restrict +' WHILE Alias WHILE immediate restrict +' REPEAT Alias REPEAT immediate restrict + + + + +\ *** Block No. 28 Hexblock 1C +\ clear Liter. Ascii ['] ." bp05mar86we + +Onlyforth Transient definitions + +: clear true abort" There are ghosts" ; +: Literal ( n -) T compile lit , H ; immediate +: Ascii H bl word 1+ c@ state @ + IF T [compile] Literal H THEN ; immediate +: ['] T ' [compile] Literal H ; immediate restrict +: " T compile (" ," H ; immediate restrict +: ." T compile (." ," H ; immediate restrict + + + + + +\ *** Block No. 29 Hexblock 1D +\ Target compilation ] [ bp05mar86we + +Forth definitions + +: tcompile + ?stack >in @ name find ?dup + IF 0> IF nip execute >interpret THEN + drop dup >in ! name + THEN gfind IF nip execute >interpret THEN + nullstring? IF drop exit THEN + number? ?dup IF 0> IF swap T [compile] Literal THEN + [compile] Literal H drop >interpret THEN + drop >in ! Word, >interpret ; + +Transient definitions +: ] H state on ['] tcompile is >interpret ; +\ *** Block No. 30 Hexblock 1E +\ Target conditionals bp05mar86we + +: IF T compile ?branch >mark H 1 ; immediate restrict +: THEN abs 1 T ?pairs >resolve H ; immediate restrict +: ELSE T 1 ?pairs compile branch >mark swap >resolve + H -1 ; immediate restrict +: BEGIN T mark -2 H 2swap ; + immediate restrict +| : (repeat T 2 ?pairs resolve H REPEAT ; +: UNTIL T compile ?branch (repeat H ; immediate restrict +: REPEAT T compile branch (repeat H ; immediate restrict + + + +\ *** Block No. 31 Hexblock 1F +\ Target conditionals bp27jun85we + +: DO T compile (do >mark H 3 ; immediate restrict +: ?DO T compile (?do >mark H 3 ; immediate restrict +: LOOP T 3 ?pairs compile (loop compile endloop + >resolve H ; immediate restrict +: +LOOP T 3 ?pairs compile (+loop compile endloop + >resolve H ; immediate restrict + + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ predefinitions bp05mar86we + +: abort" T compile (abort" ," H ; immediate +: error" T compile (err" ," H ; immediate + +Forth definitions + +Variable torigin +Variable tudp 0 Tudp ! + +: >user T c@ H torigin @ + ; + + + + + +\ *** Block No. 33 Hexblock 21 +\ Datatypes bp05mar86we + +Transient definitions +: origin! H torigin ! ; +: user' ( -- n ) T ' >body c@ H ; +: uallot ( n -- ) H tudp @ swap tudp +! ; + + DO> >user ; +: User prebuild User 2 T uallot c, ; + + DO> ; +: Create prebuild Create ; + + DO> T @ H ; +: Constant prebuild Constant T , ; +: Variable Create 2 T allot ; +\ *** Block No. 34 Hexblock 22 +\ Datatypes bp05mar86we + +dummy +: Vocabulary + H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + here H tvoc-link @ T , H tvoc-link ! ; + + + + + + + + + + +\ *** Block No. 35 Hexblock 23 +\ target defining words bp08sep86we + + Do> ; +: Defer prebuild Defer 2 T allot ; +: Is T ' H >body state @ IF T compile (is , H + ELSE T ! H THEN ; immediate +| : dodoes> T compile (;code H Glast' @ + there resdoes> there tdoes> ! ; + +: ;code 0 T ?pairs dodoes> Assembler H [compile] [ + redefinition ; immediate restrict + +: does> T dodoes> $04C C, + compile (dodoes> H ; immediate restrict + + +\ *** Block No. 36 Hexblock 24 +\ : Alias ; bp25mar86we + +: Create: T Create H current @ context ! T ] H 0 ; + +dummy +: : H tdoes> off >in @ >in: ! T prebuild : + H current @ context ! T ] H 0 ; + +: Alias ( n -- ) H Tlast off (theader Ghost over resolve + tlast @ T c@ H $20 or tlast @ T c! , H ; + +: ; T 0 ?pairs compile exit .( unnest gegen exit getauscht) + [compile] [ H redefinition ; immediate restrict + + + +\ *** Block No. 37 Hexblock 25 +\ predefinitions bp11sep86we + +: compile T compile compile H ; immediate restrict +: Host H Onlyforth Ttools also ; +: Compiler T Host H Transient also definitions ; +: [compile] H Word, ; immediate restrict +: Onlypatch H there 3 - 0 tdoes> ! 0 ; + +Onlyforth +: Target Onlyforth Transient also definitions ; + +Transient definitions +Ghost c, drop + + + +\ *** Block No. 38 Hexblock 26 + + + + + + + + + + + + + + + + +\ *** Block No. 39 Hexblock 27 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/systemio.fth b/sources/Apple1/systemio.fth new file mode 100644 index 0000000..42d6f4d --- /dev/null +++ b/sources/Apple1/systemio.fth @@ -0,0 +1,187 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for system IO for Apple1 cas2013apr05 + + + 1 9 +thru + + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ 65KEY? GETKEY cas2013apr05 +| $D010 Constant KBDDTA +| $D011 Constant KBDCTL + +| CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]? + push0a jmp end-code + +| CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND + push0a jmp end-code + +| CODE CURON ( --) NEXT JMP END-CODE + +| CODE CUROFF ( --) NEXT JMP END-CODE + +: 65KEY ( -- 8B) + CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ; +\ *** Block No. 3 Hexblock 3 +\ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05 +08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC + +: 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2) + #BS CASE? IF DUP IF DEL 1- THEN EXIT THEN + #CR CASE? IF DUP SPAN ! EXIT THEN + >R 2DUP + R@ SWAP C! R> EMIT 1+ ; + +: 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0 + BEGIN DUP SPAN @ U< + WHILE KEY DECODE + REPEAT 2DROP SPACE ; + +INPUT: KEYBOARD [ HERE INPUT ! ] + 65KEY 65KEY? 65DECODE 65EXPECT [ + +\ *** Block No. 4 Hexblock 4 +\ senden? (emit 65emit 25JAN85RE) cas2013apr05 + +| $D012 Constant DSP + +| Code send? ( -- flg ) + DSP lda $80 # AND $80 # EOR push0a jmp end-code + +Code (emit ( 8b -- ) + SP X) LDA DSP sta (drop jmp end-code + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05 + +| Variable out 0 out ! | &40 Constant c/row + +: 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ; + +: 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ; + +: 65DEL ASCII _ 65emit -1 out +! ; + +: 65PAGE &24 0 DO CR LOOP out off ; + +: 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ; + +: 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ; + +\ *** Block No. 6 Hexblock 6 +\ er14dez88 + +: 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ; + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88 + +OUTPUT: DISPLAY [ HERE OUTPUT ! ] + 65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [ + + +| : (bye ; + + + + + + + + + +\ *** Block No. 8 Hexblock 8 +\ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88 + +$400 CONSTANT B/BLK + +$0AA CONSTANT BLK/DRV + +| VARIABLE (DRV 0 (DRV ! + +| : DISK ( -- DEV.NO ) (DRV @ 8 + ; + +: DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ; + + + + + +\ *** Block No. 9 Hexblock 9 +\ er14dez88 +: >DRIVE ( BLOCK DRV# -- BLOCK' ) + BLK/DRV * + OFFSET @ - ; +: DRV? ( BLOCK -- DRV# ) + OFFSET @ + BLK/DRV / ; + +: DRVINIT NOOP ; +.( fuer reads. u. writes. ist errorhandler erforderlich ) +| : readserial ( adr blk -- ) + &27 emit .( rb ) space base push decimal . cr + $400 bounds DO key I c! LOOP ; + +| : writeserial ( adr blk -- ) + &27 emit .( wb ) space base push decimal . cr + $400 bounds DO I c@ emit LOOP ; + +\ *** Block No. 10 Hexblock A +\ (r/w er14decas + +: (R/W ( ADR BLK FILE R/WF -- FLAG) + swap abort" no file" + IF readserial ELSE writeserial THEN false ; + +' (R/W IS R/W + + + + + + + + + diff --git a/sources/Apple1/tasker.fth b/sources/Apple1/tasker.fth new file mode 100644 index 0000000..2f70960 --- /dev/null +++ b/sources/Apple1/tasker.fth @@ -0,0 +1,170 @@ +\ *** Block No. 0 Hexblock 0 +\ Multitasking Extension to volksFORTH cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Tasker Loadscreen + +\NEEDS CODE abort( Assembler needed ) +hex + 1 5 +thru \ load Tasker + 7 load \ Task-Demo +decimal + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ MULTITASKER BP 13.9.84 ) + +CODE STOP + SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA + SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA + 6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA + 1 # LDY TYA CLC UP ADC W STA + TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE + +| CREATE TASKPAUSE ASSEMBLER + 2C # LDA UP X) STA ' STOP @ JMP END-CODE + +: SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ; + +: MULTITASK TASKPAUSE ['] PAUSE ! ; + +\ *** Block No. 3 Hexblock 3 +\ PASS ACTIVATE KS 8 MAY 84 ) + +: PASS ( N0 .. NR-1 TADR R -- ) + BEGIN [ ROT ( TRICK ! ) ] + SWAP 02C OVER C! \ AWAKE TASK + R> -ROT \ IP R ADDR + 8 + >R \ S0 OF TASK + R@ 2+ @ SWAP \ IP R0 R + 2+ 2* \ BYTES ON TASKSTACK + \ INCL. R0 & IP + R@ @ OVER - \ NEW SP + DUP R> 2- ! \ INTO SSAVE + SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT + + + +\ *** Block No. 4 Hexblock 4 +\ + +: ACTIVATE ( TADR --) + 0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT + +: SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE + +: WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE + +| : TASKERROR ( STRING -) + STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE + MULTITASK STOP ; + + + + +\ *** Block No. 5 Hexblock 5 +\ BUILDING A TASK BP 13.9.84 ) + +: TASK ( RLEN SLEN -- ) + ALLOT \ STACK + HERE 00FF AND 0FE = + IF 1 ALLOT THEN \ 6502-ALIGN + UP@ HERE 100 CMOVE \ INIT USER AREA + HERE 04C C, \ JMP OPCODE TO SLEEP TASK + UP@ 1+ @ , + DUP UP@ 1+ ! \ LINK TASK + 3 ALLOT \ ALLOT JSR WAKE + DUP 6 - DUP , , \ SSAVE AND S0 + 2DUP + , \ HERE + RLEN = R0 + UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER + [ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ; + +\ *** Block No. 6 Hexblock 6 +\ MORE TASKS KS/BP 26APR85RE) + +: RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ; + +| : STATESMART STATE @ IF [COMPILE] LITERAL THEN ; + +: 'S ( TADR - ADR.OF.TASKUSERVAR) + ' >BODY C@ + STATESMART ; IMMEDIATE + +\ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY + +: TASKS ( -) ." MAIN " CR UP@ DUP 1+ @ + BEGIN 2DUP - WHILE + DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME + DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ; + +\ *** Block No. 7 Hexblock 7 +\ TASKDEMO 27APR85RE) +: TASKMARK ; + +VARIABLE COUNTER COUNTER OFF + +100 100 TASK BACKGROUND + +: >COUNT ( N -) BACKGROUND 1 PASS COUNTER ! + BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP + WHILE PAUSE 0 <# #S #> type REPEAT stop ; + +: WAIT BACKGROUND SLEEP ; + +: GO BACKGROUND WAKE ; + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/tools.fth b/sources/Apple1/tools.fth new file mode 100644 index 0000000..8459e2d --- /dev/null +++ b/sources/Apple1/tools.fth @@ -0,0 +1,255 @@ +\ *** Block No. 0 Hexblock 0 +\ Development Tools cas 26jan06 + +Interactive Tracer + +One-Step Debugger + +Traps + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ TOOLS LOADSCREEN 22MAR85RE) + +ONLYFORTH + +\NEEDS CODE abort( Assembler is needed ) + +VOCABULARY TOOLS + +TOOLS ALSO DEFINITIONS +hex +1 &11 +THRU +decimal +ONLYFORTH + + + +\ *** Block No. 2 Hexblock 2 +\ HANDLE STEPS BP 10 02 85) + +ASSEMBLER ALSO DEFINITIONS + +ONLY FORTH ALSO TOOLS ALSO DEFINITIONS +| VARIABLE (W | VARIABLE RPT + +| CODE STEP + RPT DEC RP X) LDA IP STA + RP )Y LDA IP 1+ STA RP 2INC + (W LDA W STA (W 1+ LDA W 1+ STA + W 1- JMP END-CODE + +| CREATE NEXTSTEP ] STEP [ + + +\ *** Block No. 3 Hexblock 3 +\ THROW STATUS ON R-STACK B 23JUL85RE) + +| CREATE NPULL 0 ] + RP@ COUNT 2DUP + RP! R> SWAP CMOVE ; + +: NPUSH ( ADDR LEN -) + R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE + NPULL >R >R ; + +| : ONELINE .STATUS SPACE QUERY INTERPRET + -82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ TRAP AND DISPLAY KS 26MAR85RE) +LABEL TNEXT + IP 2INC RP LDA RPT CMP 0<> ?[ + [[ W 1- JMP SWAP ]? + RP 1+ LDA RPT 1+ CMP 0= ?] +LABEL DOTRACE + RPT INC ( DISABLE TRACER ) + W LDA (W STA W 1+ LDA (W 1+ STA + ;C: R@ NEXTSTEP >R + INPUT PUSH KEYBOARD + OUTPUT PUSH DISPLAY + CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES + >NAME .NAME 1C COL - 0 MAX SPACES .S + STATE PUSH BLK PUSH >IN PUSH + [ ' 'QUIT >BODY ] LITERAL PUSH + [ ' >INTERPRET >BODY ] LITERAL PUSH +\ *** Block No. 5 Hexblock 5 +\ + #TIB PUSH TIB #TIB @ NPUSH R0 PUSH + RP@ R0 ! 082 ALLOT + ['] ONELINE IS 'QUIT QUIT ; -2 ALLOT + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ TRACER COMMANDS BP 23JUL85RE) + +| CODE (TRACE TNEXT 0 100 M/MOD + # LDA NEXT 0C + STA + # LDA NEXT 0B + STA + 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + +: TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ; + +: BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT + +: TRACEL: CREATE , DOES> @ RPT +! ; + +-6 TRACEL: +DO 6 TRACEL: -DO +-2 TRACEL: +R 2 TRACEL: -R +-6 TRACEL: +PUSH 6 TRACEL: -PUSH +\ *** Block No. 7 Hexblock 7 +\ WATCH TRAP BP 10 02 85 ) + +| VARIABLE WATCHPT 2 ALLOT + +LABEL WNEXT IP 2INC + WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA + N X) LDA WATCHPT 2+ CMP 0<> ?[ + [[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA + ( SET TO TNEXT) TNEXT 0 100 M/MOD + # LDA NEXT 0C + STA # LDA NEXT 0B + STA + DOTRACE JMP SWAP ]? + N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE + + + + +\ *** Block No. 8 Hexblock 8 +\ WATCH COMMANDS BP 10 02 85 ) + +| CODE (WATCH WNEXT 0 100 M/MOD + # LDA NEXT 0C + STA + # LDA NEXT 0B + STA + 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + +: WATCH' ( ADR -- ) + DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ; + +: CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ; + +( SYNTAX : WATCH' ) + + + +\ *** Block No. 9 Hexblock 9 +\ TOOLS FOR DECOMPILING, KS 4 APR 83 ) +( INTERACTIVE USE ) +| : ?: DUP 4 U.R ." :" ; +| : @? DUP @ 6 U.R ; +| : C? DUP C@ 3 .R ; +| : BL 024 COL - 0 MAX SPACES ; + +: S ( ADR - ADR+) ( PRINT LITERAL STRING) + ?: SPACE C? 4 SPACES DUP COUNT TYPE + DUP C@ + 1+ BL ; ( COUNT + RE) + +: N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA) + ?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ; + +: L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ; + +\ *** Block No. 10 Hexblock A +\ TOOLS FOR DECOMPILING, INTERACTIVE ) + +: D ( ADR N - ADR+N) ( DUMP N BYTES) + 2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP + 4 SPACES -ROT TYPE BL ; + +: C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ; + +: B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION ) + ?: @? DUP @ OVER + 6 U.R 2+ BL ; + +( USED FOR : ) +( NAME STRING LITERAL DUMP CLIT BRANCH ) +( - - - - - - ) + + +\ *** Block No. 11 Hexblock B +\ DEBUGGING UTILITIES BP 19 02 85 ) + +: UNRAVEL \ UNRAVEL PERFORM (ABORT" + RDROP RDROP RDROP CR ." TRACE DUMP IS " CR + + BEGIN RP@ R0 @ - + WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR + REPEAT (ERROR ; + +' UNRAVEL ERRORHANDLER ! + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + +