diff --git a/6502/Apple1/source/Makefile b/6502/Apple1/source/Makefile new file mode 100644 index 0000000..57c7be9 --- /dev/null +++ b/6502/Apple1/source/Makefile @@ -0,0 +1,11 @@ + +blk_files = $(wildcard *.fb) +fth_files = $(patsubst %.fb, %.fth, $(blk_files)) + +# Target to convert all .fb blk sources into .fth files. +fth: $(fth_files) + +# Generic rule for converting .fb blk sources into .fth files. + +%.fth: %.fb fb2fth.py + ../../../tools/fb2fth.py $< $@ diff --git a/sources/Apple1/2words.fb.src b/sources/Apple1/2words.fb.src new file mode 100644 index 0000000..80852df --- /dev/null +++ b/sources/Apple1/2words.fb.src @@ -0,0 +1,68 @@ +Screen 0 not modified + 0 \ Additional definitions for 32bit values cas 26jan06 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ 2Words Loadscreen cas 26jan06 + 1 + 2 hex + 3 &2 &3 thru + 4 decimal + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 2 not modified + 0 \ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE) + 1 + 2 CODE 2! ( D ADR --) + 3 TYA SETUP JSR 3 # LDY + 4 [[ SP )Y LDA N )Y STA DEY 0< ?] + 5 1 # LDY POPTWO JMP END-CODE + 6 + 7 CODE 2@ ( ADR -- D) + 8 SP X) LDA N STA SP )Y LDA N 1+ STA + 9 SP 2DEC 3 # LDY +10 [[ N )Y LDA SP )Y STA DEY 0< ?] +11 XYNEXT JMP END-CODE +12 +13 +14 +15 +Screen 3 not modified + 0 \ + 1 + 2 : 2VARIABLE ( --) CREATE 4 ALLOT ; + 3 ( -- ADR) + 4 + 5 : 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ; + 6 + 7 \ 2DUP EXISTS + 8 \ 2SWAP EXISTS + 9 \ 2DROP EXISTS +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/6502f83.fb.src b/sources/Apple1/6502f83.fb.src new file mode 100644 index 0000000..c90ddc5 --- /dev/null +++ b/sources/Apple1/6502f83.fb.src @@ -0,0 +1,2244 @@ +Screen 0 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 ende 123 +14 +15 +Screen 1 not modified + 0 \ volksFORTH Loadscreen cas2013apr05 + 1 forth definitions + 2 : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE + 3 + 4 $0300 CONSTANT BASEADDR \ base address of forth image + 5 $7F00 CONSTANT TOPADDR + 6 BASEADDR DISPLACE ! + 7 TARGET DEFINITIONS BASEADDR HERE! + 8 + 9 hex &01 &126 +THRU +10 decimal +11 \ ASSEMBLER NONRELOCATE +12 +13 .UNRESOLVED \ if this prints unresolved +14 \ definitions, check code +15 CR .( SAVE-TARGET 6502-FORTH83) +Screen 2 not modified + 0 \ FORTH PREAMBLE AND ID cas20130405 + 1 + 2 + 3 ASSEMBLER + 4 NOP 0 JMP HERE 2- >LABEL >COLD + 5 NOP 0 JMP HERE 2- >LABEL >RESTART + 6 + 7 HERE DUP ORIGIN! + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 3 not modified + 0 \ Coldstartvalues and user variables cas2013apr05 + 1 \ + 2 + 3 0 JMP 0 JSR HERE 2- >LABEL >WAKE + 4 END-CODE + 5 + 6 0D6 ALLOT + 7 + 8 \ Bootlabel + 9 ," VolksForth-83 3.8 COMPILED 05apr13CS" +10 +11 +12 +13 +14 +15 +Screen 4 not modified + 0 \ ZERO PAGE VARIABLES & NEXT cas 26jan06 + 1 \ adjust this to match your architecture + 2 + 3 + 4 20 DUP >LABEL RP 2+ + 5 DUP >LABEL UP 2+ + 6 DUP >LABEL PUTA 1+ + 7 DUP >LABEL SP 2+ + 8 DUP >LABEL NEXT + 9 DUP 5 + >LABEL IP +10 13 + >LABEL W +11 +12 W 8 + >LABEL N +13 +14 +15 +Screen 5 not modified + 0 \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) + 1 + 2 LABEL BOOTNEXT + 3 -1 STA \ -1 IS DUMMY SP + 4 IP )Y LDA W 1+ STA + 5 -1 LDA W STA \ -1 IS DUMMY IP + 6 CLC IP LDA 2 # ADC IP STA + 7 CS NOT ?[ LABEL WJMP -1 ) JMP ]? + 8 IP 1+ INC WJMP BCS END-CODE + 9 +10 +11 +12 +13 +14 +15 +Screen 6 not modified + 0 \ Bootnext and Endtrace cas 26jan06 + 1 HERE BOOTNEXT - >LABEL BOOTNEXTLEN + 2 + 3 CODE END-TRACE ( PATCH NEXT FOR TRACE ) + 4 0A5 # LDA NEXT 0A + STA + 5 IP # LDA NEXT 0B + STA + 6 069 # LDA NEXT 0C + STA + 7 02 # LDA NEXT 0D + STA + 8 NEXT JMP END-CODE + 9 +10 +11 +12 +13 +14 +15 +Screen 7 not modified + 0 \ ;C: NOOP cas 26jan06 + 1 + 2 CREATE RECOVER ASSEMBLER + 3 PLA W STA PLA W 1+ STA + 4 W WDEC 0 JMP END-CODE + 5 + 6 HERE 2- >LABEL >RECOVER + 7 \ manual forward reference for JMP command + 8 + 9 +10 COMPILER ASSEMBLER ALSO DEFINITIONS +11 H : ;C: 0 T RECOVER JSR +12 END-CODE ] H ; +13 TARGET +14 CODE NOOP NEXT HERE 2- ! END-CODE +15 +Screen 8 not modified + 0 \ USER VARIABLES cas2013apr05 + 1 + 2 CONSTANT ORIGIN 8 UALLOT DROP + 3 \ FOR MULTITASKER + 4 + 5 \ Adjust memory values for data stack and return stack here + 6 USER S0 TOPADDR $F00 - S0 ! USER R0 TOPADDR $480 - R0 ! + 7 USER DP USER OFFSET 0 OFFSET ! + 8 USER BASE &10 BASE ! USER OUTPUT + 9 USER INPUT +10 USER ERRORHANDLER \ POINTER FOR ABORT" -CODE +11 USER VOC-LINK +12 USER UDP \ POINTS TO NEXT FREE ADDR IN USER +13 +14 +15 +Screen 9 not modified + 0 \ MANIPULATE SYSTEM POINTERS 29JAN85BP) + 1 + 2 CODE SP@ ( -- ADDR) + 3 SP LDA N STA SP 1+ LDA N 1+ STA + 4 N # LDX + 5 LABEL XPUSH + 6 SP 2DEC 1 ,X LDA SP )Y STA + 7 0 ,X LDA 0 # LDX PUTA JMP END-CODE + 8 + 9 CODE SP! ( ADDR --) +10 SP X) LDA TAX SP )Y LDA +11 SP 1+ STA SP STX 0 # LDX +12 NEXT JMP END-CODE +13 +14 +15 +Screen 10 not modified + 0 \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06 + 1 CODE UP@ ( -- ADDR) + 2 UP # LDX XPUSH JMP END-CODE + 3 + 4 CODE UP! ( ADDR --) UP # LDX + 5 LABEL XPULL SP )Y LDA 1 ,X STA + 6 DEY SP )Y LDA 0 ,X STA + 7 LABEL (XYDROP 0 # LDX 1 # LDY + 8 LABEL (DROP SP 2INC NEXT JMP + 9 END-CODE RESTRICT +10 +11 +12 +13 +14 +15 +Screen 11 not modified + 0 \ MANIPULATE RETURNSTACK 16FEB85BP/KS) + 1 CODE RP@ ( -- ADDR ) + 2 RP # LDX XPUSH JMP END-CODE + 3 + 4 CODE RP! ( ADDR -- ) + 5 RP # LDX XPULL JMP END-CODE RESTRICT + 6 + 7 CODE >R ( 16B -- ) + 8 RP 2DEC SP X) LDA RP X) STA + 9 SP )Y LDA RP )Y STA (DROP JMP +10 END-CODE RESTRICT +11 +12 +13 +14 +15 +Screen 12 not modified + 0 \ R> (RDROP (NRDROP cas 26jan06 + 1 CODE R> ( -- 16B) + 2 SP 2DEC RP X) LDA SP X) STA + 3 RP )Y LDA SP )Y STA + 4 LABEL (RDROP 2 # LDA + 5 + 6 LABEL (NRDROP CLC RP ADC RP STA + 7 CS ?[ RP 1+ INC ]? + 8 NEXT JMP END-CODE RESTRICT + 9 +10 +11 +12 +13 +14 +15 +Screen 13 not modified + 0 \ R@ RDROP EXIT ?EXIT 08APR85BP) + 1 + 2 CODE R@ ( -- 16B) + 3 SP 2DEC RP )Y LDA SP )Y STA + 4 RP X) LDA PUTA JMP + 5 END-CODE + 6 CODE RDROP (RDROP HERE 2- ! + 7 END-CODE RESTRICT + 8 + 9 CODE EXIT +10 RP X) LDA IP STA +11 RP )Y LDA IP 1+ STA +12 (RDROP JMP END-CODE +13 +14 +15 +Screen 14 not modified + 0 \ EXECUTE PERFORM 08APR85BP) + 1 + 2 CODE ?EXIT ( FLAG -- ) + 3 SP X) LDA SP )Y ORA + 4 PHP SP 2INC PLP + 5 ' EXIT @ BNE NEXT JMP + 6 END-CODE + 7 + 8 CODE EXECUTE ( ADDR --) + 9 SP X) LDA W STA +10 SP )Y LDA W 1+ STA +11 SP 2INC W 1- JMP END-CODE +12 +13 : PERFORM ( ADDR -- ) @ EXECUTE ; +14 +15 +Screen 15 not modified + 0 \ C@ C! CTOGGLE 10JAN85BP) + 1 + 2 CODE C@ ( ADDR -- 8B) + 3 + 4 SP X) LDA N STA SP )Y LDA N 1+ STA + 5 LABEL (C@ 0 # LDA SP )Y STA + 6 N X) LDA PUTA JMP END-CODE + 7 + 8 CODE C! ( 16B ADDR --) + 9 SP X) LDA N STA SP )Y LDA N 1+ STA +10 INY SP )Y LDA N X) STA DEY +11 LABEL (2DROP +12 SP LDA CLC 4 # ADC SP STA +13 CS ?[ SP 1+ INC ]? +14 NEXT JMP END-CODE +15 +Screen 16 not modified + 0 \ @ ! +! 08APR85BP) er14dez88 + 1 + 2 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; + 3 + 4 CODE @ ( ADDR -- 16B) + 5 SP X) LDA N STA SP )Y LDA N 1+ STA + 6 N )Y LDA SP )Y STA + 7 N X) LDA PUTA JMP END-CODE + 8 + 9 CODE ! ( 16B ADDR --) +10 SP X) LDA N STA SP )Y LDA N 1+ STA +11 INY SP )Y LDA N X) STA +12 INY SP )Y LDA 1 # LDY +13 LABEL (! +14 N )Y STA (2DROP JMP END-CODE +15 +Screen 17 not modified + 0 \ +! DROP cas 26jan06 + 1 + 2 CODE +! ( N ADDR --) + 3 SP X) LDA N STA SP )Y LDA N 1+ STA + 4 INY SP )Y LDA CLC N X) ADC N X) STA + 5 INY SP )Y LDA 1 # LDY N )Y ADC + 6 (! JMP END-CODE + 7 + 8 CODE DROP ( 16B --) + 9 (DROP HERE 2- ! END-CODE +10 +11 +12 +13 +14 +15 +Screen 18 not modified + 0 \ SWAP cas 26jan06 + 1 CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) + 2 SP )Y LDA TAX + 3 3 # LDY SP )Y LDA N STA + 4 TXA SP )Y STA + 5 N LDA 1 # LDY SP )Y STA + 6 INY 0 # LDX + 7 SP )Y LDA N STA SP X) LDA SP )Y STA + 8 DEY + 9 N LDA PUTA JMP END-CODE +10 +11 +12 +13 +14 +15 +Screen 19 not modified + 0 \ DUP ?DUP 08MAY85BP) cas 26jan06 + 1 + 2 CODE DUP ( 16B -- 16B 16B) + 3 SP 2DEC + 4 3 # LDY SP )Y LDA 1 # LDY SP )Y STA + 5 INY SP )Y LDA DEY + 6 PUTA JMP END-CODE + 7 + 8 CODE ?DUP ( 16B -- 16B 16B / FALSE) + 9 SP X) LDA SP )Y ORA +10 0= ?[ NEXT JMP ]? +11 ' DUP @ JMP END-CODE +12 \\ ?DUP and DUP in FORTH +13 \ : ?DUP ( 16B -- 16B 16B / FALSE) +14 \ DUP IF DUP THEN ; +15 \ : DUP SP@ @ ; +Screen 20 not modified + 0 \ OVER ROT 13JUN84KS) cas 26jan06 + 1 + 2 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) + 3 SP 2DEC 4 # LDY SP )Y LDA SP X) STA + 4 INY SP )Y LDA 1 # LDY SP )Y STA + 5 NEXT JMP END-CODE + 6 + 7 \\ ROT OVER in FORTH + 8 \ : ROT >R SWAP R> SWAP ; + 9 \ : OVER >R DUP R> SWAP ; +10 +11 +12 +13 +14 +15 +Screen 21 not modified + 0 \ ROT cas 26jan06 + 1 CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) + 2 3 # LDY SP )Y LDA N 1+ STA + 3 1 # LDY SP )Y LDA 3 # LDY SP )Y STA + 4 5 # LDY SP )Y LDA N STA + 5 N 1+ LDA SP )Y STA + 6 1 # LDY N LDA SP )Y STA + 7 INY SP )Y LDA N 1+ STA + 8 SP X) LDA SP )Y STA + 9 4 # LDY SP )Y LDA SP X) STA +10 N 1+ LDA SP )Y STA +11 1 # LDY NEXT JMP END-CODE +12 +13 +14 +15 +Screen 22 not modified + 0 \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06 + 1 : -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) + 2 ROT ROT ; + 3 + 4 : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; + 5 + 6 : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; + 7 + 8 : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; + 9 +10 : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; +11 +12 \\ : -ROLL ( N --) +13 >R DUP SP@ DUP 2+ DUP 2+ SWAP +14 R@ 2* CMOVE R> 1+ 2* + ! ; +15 +Screen 23 not modified + 0 \ DOUBLE WORD STACK MANIP. 21APR83KS) + 1 + 2 : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; + 3 + 4 CODE 2DROP ( 32B -- ) + 5 (2DROP HERE 2- ! END-CODE + 6 + 7 : 2DUP ( 32B -- 32B 32B) OVER OVER ; + 8 + 9 \ : 2DROP ( 32B -- ) DROP DROP ; +10 +11 +12 +13 +14 +15 +Screen 24 not modified + 0 \ + AND OR XOR 08APR85BP) + 1 COMPILER ASSEMBLER ALSO DEFINITIONS + 2 + 3 H : DYADOP ( OPCODE --) T + 4 INY SP X) LDA DUP C, SP C, SP )Y STA + 5 DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA + 6 (XYDROP JMP H ; + 7 TARGET + 8 + 9 CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE +10 +11 CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE +12 +13 CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE +14 +15 CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE +Screen 25 not modified + 0 \ - NOT NEGATE 24DEC83KS) + 1 + 2 CODE - ( N1 N2 -- N3) + 3 INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA + 4 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE + 5 + 6 CODE NOT ( 16B1 -- 16B2) CLC + 7 LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA + 8 NEXT JMP END-CODE + 9 +10 CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE +11 +12 \ : - NEGATE + ; +13 +14 +15 +Screen 26 not modified + 0 \ DNEGATE SETUP D+ 14JUN84KS) + 1 + 2 CODE DNEGATE ( D1 -- -D1) + 3 INY SEC + 4 TXA SP )Y SBC SP )Y STA INY + 5 TXA SP )Y SBC SP )Y STA + 6 TXA SP X) SBC SP X) STA 1 # LDY + 7 TXA SP )Y SBC SP )Y STA + 8 NEXT JMP END-CODE + 9 LABEL SETUP ( QUAN IN A) +10 .A ASL TAX TAY DEY +11 [[ SP )Y LDA N ,Y STA DEY 0< ?] +12 TXA CLC SP ADC SP STA +13 CS ?[ SP 1+ INC ]? +14 0 # LDX 1 # LDY RTS END-CODE +15 +Screen 27 not modified + 0 \ D+ cas 26jan06 + 1 CODE D+ ( D1 D2 -- D3) + 2 2 # LDA SETUP JSR INY + 3 SP )Y LDA CLC N 2+ ADC SP )Y STA INY + 4 SP )Y LDA N 3 + ADC SP )Y STA + 5 SP X) LDA N ADC SP X) STA 1 # LDY + 6 SP )Y LDA N 1+ ADC SP )Y STA + 7 NEXT JMP END-CODE + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 28 not modified + 0 \ 1+ 2+ 3+ 1- 2- 08APR85BP) + 1 + 2 CODE 1+ ( N1 -- N2) 1 # LDA + 3 LABEL N+ CLC SP X) ADC + 4 CS NOT ?[ PUTA JMP ]? + 5 SP X) STA SP )Y LDA 0 # ADC SP )Y STA + 6 NEXT JMP END-CODE + 7 + 8 CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE + 9 +10 CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE +11 +12 | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE +13 +14 | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE +15 +Screen 29 not modified + 0 \ NUMBER CONSTANTS 24DEC83KS) + 1 CODE 1- ( N1 -- N2) SEC + 2 LABEL (1- SP X) LDA 1 # SBC + 3 CS ?[ PUTA JMP ]? + 4 SP X) STA SP )Y LDA 0 # SBC SP )Y STA + 5 NEXT JMP END-CODE + 6 CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE + 7 + 8 -1 CONSTANT TRUE 0 CONSTANT FALSE + 9 ' TRUE ALIAS -1 ' FALSE ALIAS 0 +10 +11 1 CONSTANT 1 2 CONSTANT 2 +12 3 CONSTANT 3 4 CONSTANT 4 +13 +14 : ON ( ADDR -- ) TRUE SWAP ! ; +15 : OFF ( ADDR -- ) FALSE SWAP ! ; +Screen 30 not modified + 0 \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 + 1 + 2 CODE CLIT ( -- 8B) + 3 SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC + 4 NEXT JMP END-CODE RESTRICT + 5 + 6 CODE LIT ( -- 16B) + 7 SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA + 8 LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT + 9 : LITERAL ( 16B --) DUP 0FF00 AND +10 IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; +11 IMMEDIATE RESTRICT +12 +13 \\ : LIT R> DUP 2+ >R @ ; +14 : CLIT R> DUP 1+ >R C@ ; +15 +Screen 31 not modified + 0 \ COMPARISION CODE WORDS 13JUN84KS) + 1 CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ + 2 LABEL PUTTRUE 0FF # LDA 024 C, ]? + 3 LABEL PUTFALSE TXA SP )Y STA + 4 PUTA JMP END-CODE + 5 + 6 CODE 0= ( 16B -- FLAG) + 7 SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE + 8 + 9 CODE UWITHIN ( U1 [LOW UP[ -- FLAG) +10 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP +11 SP )Y LDA N 1+ SBC +12 CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP +13 SP )Y LDA N 3 + SBC +14 PUTTRUE BCS ]? +15 PUTFALSE JMP END-CODE +Screen 32 not modified + 0 \ COMPARISION CODE WORDS 13JUN84KS) + 1 + 2 CODE < ( N1 N2 -- FLAG) + 3 SP X) LDA N STA SP )Y LDA N 1+ STA + 4 SP 2INC + 5 N 1+ LDA SP )Y EOR ' 0< @ BMI + 6 SP X) LDA N CMP SP )Y LDA N 1+ SBC + 7 ' 0< @ 2+ JMP END-CODE + 8 + 9 CODE U< ( U1 U2 -- FLAG) +10 SP X) LDA N STA SP )Y LDA N 1+ STA +11 SP 2INC +12 SP X) LDA N CMP SP )Y LDA N 1+ SBC +13 CS NOT ?[ PUTTRUE JMP ]? +14 PUTFALSE JMP END-CODE +15 +Screen 33 not modified + 0 \ COMPARISION WORDS 24DEC83KS) + 1 + 2 | : 0< 8000 AND 0<> ; + 3 + 4 : > ( N1 N2 -- FLAG) SWAP < ; + 5 : 0> ( N -- FLAG) NEGATE 0< ; + 6 : 0<> ( N -- FLAG) 0= NOT ; + 7 : U> ( U1 U2 -- FLAG) SWAP U< ; + 8 : = ( N1 N2 -- FLAG) - 0= ; + 9 : D0= ( D -- FLAG) OR 0= ; +10 : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; +11 : D< ( D1 D2 -- FLAG) ROT 2DUP - +12 IF > NIP NIP ELSE 2DROP U< THEN ; +13 +14 +15 +Screen 34 not modified + 0 \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 + 1 + 2 | : MINIMAX ( N1 N2 FLAG -- N3) + 3 RDROP IF SWAP THEN DROP ; + 4 + 5 : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT + 6 : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT + 7 : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT + 8 : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT + 9 +10 : EXTEND ( N -- D) DUP 0< ; +11 +12 : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; +13 : ABS ( N -- U) EXTEND IF NEGATE THEN ; +14 +15 +Screen 35 not modified + 0 \ LOOP PRIMITIVES 08FEB85BP/KS) + 1 + 2 | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; + 3 + 4 + 5 : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT + 6 + 7 : (?DO ( LIMIT START -- ) + 8 OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT + 9 +10 : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; +11 +12 CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT +13 +14 \\ DODO PUTS "INDEX \ LIMIT \ +15 ADR.OF.DO" ON RETURN-STACK +Screen 36 not modified + 0 \ (LOOP (+LOOP 08APR85BP) + 1 CODE (LOOP + 2 CLC 1 # LDA RP X) ADC RP X) STA + 3 CS ?[ RP )Y LDA 0 # ADC RP )Y STA + 4 CS ?[ NEXT JMP ]? ]? + 5 LABEL DOLOOP 5 # LDY + 6 RP )Y LDA IP 1+ STA DEY + 7 RP )Y LDA IP STA 1 # LDY + 8 NEXT JMP END-CODE RESTRICT + 9 +10 CODE (+LOOP +11 CLC SP X) LDA RP X) ADC RP X) STA +12 SP )Y LDA RP )Y ADC RP )Y STA +13 .A ROR SP )Y EOR +14 PHP SP 2INC PLP DOLOOP BPL +15 NEXT JMP END-CODE RESTRICT +Screen 37 not modified + 0 \ LOOP INDICES 08APR85BP) + 1 + 2 CODE I ( -- N) 0 # LDY + 3 LABEL LOOPINDEX SP 2DEC CLC + 4 RP )Y LDA INY INY + 5 RP )Y ADC SP X) STA DEY + 6 RP )Y LDA INY INY + 7 RP )Y ADC 1 # LDY SP )Y STA + 8 NEXT JMP END-CODE RESTRICT + 9 +10 CODE J ( -- N) +11 6 # LDY LOOPINDEX BNE +12 END-CODE RESTRICT +13 +14 +15 +Screen 38 not modified + 0 \ BRANCHING 24DEC83KS) + 1 + 2 CODE BRANCH + 3 CLC IP LDA IP X) ADC N STA + 4 IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA + 5 NEXT JMP END-CODE RESTRICT + 6 + 7 CODE ?BRANCH + 8 SP X) LDA SP )Y ORA PHP SP 2INC PLP + 9 ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT +10 +11 \\ : BRANCH R> DUP @ + >R ; RESTRICT +12 +13 : ?BRANCH +14 0= R> OVER NOT OVER 2+ AND -ROT +15 DUP @ + AND OR >R ; RESTRICT +Screen 39 not modified + 0 \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) + 1 + 2 : >MARK ( -- ADDR) HERE 0 , ; + 3 + 4 : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; + 5 + 6 : MARK 1 ; IMMEDIATE RESTRICT + 3 : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT + 4 : ELSE 1 ?PAIRS COMPILE BRANCH >MARK + 5 SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT + 6 : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT + 9 | : (REPTIL RESOLVE REPEAT ; +11 +12 : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT +13 +14 : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT +15 +Screen 42 not modified + 0 \ LOOPS 29JAN85KS/BP) + 1 + 2 : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT + 3 + 4 : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT + 5 + 6 : LOOP 3 ?PAIRS COMPILE (LOOP + 7 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT + 8 + 9 : +LOOP 3 ?PAIRS COMPILE (+LOOP +10 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT +11 +12 : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT +13 +14 \\ RETURNSTACK: CALLADR \ INDEX +15 LIMIT \ ADR OF DO +Screen 43 not modified + 0 \ UM* BP/KS13.2.85) + 1 CODE UM* ( U1 U2 -- UD) + 2 SP )Y LDA N STA SP X) LDA N 1+ STA + 3 INY N 2 + STX N 3 + STX 010 # LDX + 4 [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL + 5 CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA + 6 INY SP )Y LDA DEY N 2 + ADC N 2 + STA + 7 CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? + 8 DEX 0= ?] + 9 N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY +10 N LDA SP )Y STA N 1+ LDA SP X) STA +11 NEXT JMP END-CODE +12 +13 \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 +14 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN +15 >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; +Screen 44 not modified + 0 \ M* 2* 04JUL84KS) + 1 + 2 : M* ( N1 N2 -- D) + 3 DUP 0< DUP >R IF NEGATE THEN + 4 SWAP DUP 0< IF NEGATE R> NOT >R THEN + 5 UM* R> IF DNEGATE THEN ; + 6 + 7 : * ( N N -- PROD) UM* DROP ; + 8 + 9 CODE 2* ( N1 -- N2) +10 SP X) LDA .A ASL SP X) STA +11 SP )Y LDA .A ROL SP )Y STA +12 NEXT JMP END-CODE +13 | : 2* DUP + ; +14 +15 +Screen 45 not modified + 0 \ UM/MOD 04JUL84KS) + 1 + 2 | : DIVOVL + 3 TRUE ABORT" DIVISION OVERFLOW" ; + 4 + 5 CODE UM/MOD ( UD U -- UREM UQUOT) + 6 SP X) LDA N 5 + STA + 7 SP )Y LDA N 4 + STA SP 2INC + 8 SP X) LDA N 1+ STA + 9 SP )Y LDA N STA INY +10 SP )Y LDA N 3 + STA INY +11 SP )Y LDA N 2+ STA 011 # LDX CLC +12 [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC +13 TAY N LDA N 4 + SBC +14 CS NOT ?[ N 6 + ROL ]? +15 CS ?[ N STA N 1+ STY ]? +Screen 46 not modified + 0 \ + 1 N 3 + ROL N 2+ ROL N 1+ ROL N ROL + 2 DEX 0= ?] + 3 1 # LDY N ROR N 1+ ROR + 4 CS ?[ ;C: DIVOVL ; ASSEMBLER ]? + 5 N 2+ LDA SP )Y STA INY + 6 N 1+ LDA SP )Y STA INY + 7 N LDA SP )Y STA 1 # LDY + 8 N 3 + LDA + 9 PUTA JMP END-CODE +10 +11 +12 +13 +14 +15 +Screen 47 not modified + 0 \ 2/ M/MOD 24DEC83KS) + 1 + 2 : M/MOD ( D N -- MOD QUOT) + 3 DUP >R ABS OVER + 4 0< IF UNDER + SWAP THEN + 5 UM/MOD R@ + 6 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- + 7 THEN THEN RDROP ; + 8 + 9 CODE 2/ ( N1 -- N2) +10 SP )Y LDA .A ASL +11 SP )Y LDA .A ROR SP )Y STA +12 SP X) LDA .A ROR +13 PUTA JMP END-CODE +14 +15 +Screen 48 not modified + 0 \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) + 1 + 2 : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; + 3 + 4 : / ( N1 N2 -- QUOT) /MOD NIP ; + 5 + 6 : MOD ( N1 N2 -- REM) /MOD DROP ; + 7 + 8 : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; + 9 +10 : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; +11 +12 : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; +13 +14 : UD/MOD ( UD1 U2 -- UREM UDQUOT) +15 >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; +Screen 49 not modified + 0 \ CMOVE CMOVE> (CMOVE> BP 08APR85) + 1 + 2 CODE CMOVE ( FROM TO QUAN --) + 3 3 # LDA SETUP JSR DEY + 4 [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ + 5 1 # LDY NEXT JMP ]? ]? + 6 N 4 + )Y LDA N 2+ )Y STA INY 0= ?] + 7 N 5 + INC N 3 + INC ]] END-CODE + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 50 not modified + 0 \ CMOVE> MOVE cas 26jan06 + 1 CODE CMOVE> ( FROM TO QUAN --) + 2 3 # LDA SETUP JSR + 3 CLC N 1+ LDA N 3 + ADC N 3 + STA + 4 CLC N 1+ LDA N 5 + ADC N 5 + STA + 5 N 1+ INC N LDY CLC CS ?[ + 6 LABEL (CMOVE> + 7 DEY N 4 + )Y LDA N 2+ )Y STA ]? + 8 TYA (CMOVE> BNE + 9 N 3 + DEC N 5 + DEC N 1+ DEC +10 (CMOVE> BNE 1 # LDY +11 NEXT JMP END-CODE +12 +13 : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN +14 R> CMOVE ; +15 +Screen 51 not modified + 0 \ PLACE COUNT ERASE 16FEB85BP/KS) + 1 + 2 : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; + 3 + 4 CODE COUNT ( ADDR -- ADDR+1 LEN) + 5 SP X) LDA N STA CLC 1 # ADC SP X) STA + 6 SP )Y LDA N 1+ STA 0 # ADC SP )Y STA + 7 SP 2DEC (C@ JMP END-CODE + 8 + 9 \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; +10 +11 : ERASE ( ADDR QUAN --) 0 FILL ; +12 +13 +14 +15 +Screen 52 not modified + 0 \ FILL 11JUN85BP) + 1 + 2 CODE FILL ( ADDR QUAN 8B -- ) + 3 3 # LDA SETUP JSR DEY + 4 N LDA N 3 + LDX + 5 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] + 6 N 5 + INC DEX 0= ?] + 7 ]? N 2+ LDX + 8 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] + 9 ]? 1 # LDY +10 NEXT JMP END-CODE +11 +12 \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP +13 IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; +14 +15 +Screen 53 not modified + 0 \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) + 1 + 2 : HERE ( -- ADDR) DP @ ; + 3 + 4 : PAD ( -- ADDR) HERE 042 + ; + 5 + 6 : ALLOT ( N --) DP +! ; + 7 + 8 : , ( 16B --) HERE ! 2 ALLOT ; + 9 +10 : C, ( 8B --) HERE C! 1 ALLOT ; +11 +12 : COMPILE R> DUP 2+ >R @ , ; RESTRICT +13 +14 +15 +Screen 54 not modified + 0 \ INPUT STRINGS 24DEC83KS) + 1 + 2 VARIABLE #TIB 0 #TIB ! + 3 VARIABLE >TIB $100 >TIB ! \ 050 ALLOT + 4 VARIABLE >IN 0 >IN ! + 5 VARIABLE BLK 0 BLK ! + 6 VARIABLE SPAN 0 SPAN ! + 7 + 8 : TIB ( -- ADDR ) >TIB @ ; + 9 +10 : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; +11 +12 +13 +14 +15 +Screen 55 not modified + 0 \ SCAN SKIP /STRING 12OCT84BP) + 1 + 2 : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R + 3 BEGIN DUP WHILE OVER C@ R@ - + 4 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; + 5 + 6 : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R + 7 BEGIN DUP WHILE OVER C@ R@ = + 8 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; + 9 +10 +11 : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) +12 OVER UMIN ROT OVER + -ROT - ; +13 +14 +15 +Screen 56 not modified + 0 \ CAPITAL 03APR85BP) + 1 (C LABEL (CAPITAL \ FOR COMMODORE ONLY + 2 PHA 0DF # AND \ 2ND UPPER TO LOWER + 3 ASCII A # CMP + 4 CS ?[ ASCII Z 1+ # CMP + 5 CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS + 6 ]? ]? PLA RTS END-CODE ) + 7 + 8 LABEL (CAPITAL \ FOR ASCII ONLY + 9 ASCII a # CMP +10 CS ?[ ASCII z 1+ # CMP +11 CC ?[ SEC ASCII a ASCII A - # SBC +12 ]? ]? RTS END-CODE +13 +14 CODE CAPITAL ( CHAR -- CHAR' ) +15 SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE +Screen 57 not modified + 0 \ CAPITALIZE 03APR85BP) + 1 + 2 CODE CAPITALIZE ( STRING -- STRING ) + 3 SP X) LDA N STA SP )Y LDA N 1+ STA + 4 N X) LDA N 2+ STA DEY + 5 [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? + 6 INY N )Y LDA (CAPITAL JSR N )Y STA + 7 ]] END-CODE + 8 + 9 \\ : CAPITALIZE ( STRING -- STRING ) +10 DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; +11 +12 \\ CAPITAL ( CHAR -- CHAR ) +13 ASCII A ASCII Z 1+ UWITHIN +14 IF I C@ [ ASCII A ASCII A - ] LITERAL - ; +15 +Screen 58 not modified + 0 \ (WORD 08APR85BP) + 1 + 2 | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) + 3 \ N : LENGTH OF SOURCE + 4 \ N+2 : PTR IN SOURCE / NEXT CHAR + 5 \ N+4 : STRING START ADRESS + 6 \ N+6 : STRING LENGTH + 7 N 6 + STX \ 0 =: STRING_LENGTH + 8 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] + 9 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA +10 \ >IN+ADR0 =: N+2 +11 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA +12 \ LEN0->IN =: N +13 N 1+ LDA >IN 1+ SBC N 1+ STA +14 CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED +15 SP )Y LDA >IN 1+ STA +Screen 59 not modified + 0 \ (WORD 08APR85BP) + 1 + 2 ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S + 3 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 + 4 0= ?[[ N 2+ WINC N WDEC ]]? + 5 N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS + 6 N 3 + LDA N 5 + STA + 7 [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR + 8 N 2+ WINC N WDEC PLP + 9 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH +10 N LDA N 1+ ORA +11 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) +12 SEC 2 # LDY +13 \ ADR_AFTER_STRING - ADR0 =: >IN) +14 N 2+ LDA SP )Y SBC >IN STA INY +15 N 3 + LDA SP )Y SBC >IN 1+ STA +Screen 60 not modified + 0 \ (WORD 08APR85BP) + 1 + 2 ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED + 3 \ WHEN WORD CALLED) + 4 CLC 4 # LDA SP ADC SP STA + 5 CS ?[ SP 1+ INC ]? \ 2DROP + 6 USER' DP # LDY UP )Y LDA + 7 SP X) STA N STA INY + 8 UP )Y LDA 1 # LDY + 9 SP )Y STA N 1+ STA \ DP @ +10 DEY N 6 + LDA \ STORE COUNT BYTE FIRST +11 [[ N )Y STA N 4 + )Y LDA INY +12 N 6 + DEC 0< ?] +13 020 # LDA N )Y STA \ ADD A BLANK +14 1 # LDY NEXT JMP END-CODE +15 +Screen 61 not modified + 0 \ SOURCE WORD PARSE NAME 08APR85BP) + 1 + 2 : SOURCE ( -- ADDR LEN) + 3 BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; + 4 + 5 : WORD ( CHAR -- ADDR) SOURCE (WORD ; + 6 + 7 : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP + 8 R> SCAN >R OVER - DUP R> 0<> - >IN +! ; + 9 +10 : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; +11 +12 \\ : WORD ( CHAR -- ADDR) >R +13 SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> +14 SCAN >R ROT OVER SWAP - R> 0<> - >IN ! +15 OVER - HERE PLACE BL HERE COUNT + C! HERE ; +Screen 62 not modified + 0 \ STATE ASCII ," (" " 24DEC83KS) + 1 + 2 VARIABLE STATE 0 STATE ! + 3 + 4 : ASCII BL WORD 1+ C@ STATE @ + 5 IF [COMPILE] LITERAL THEN ; IMMEDIATE + 6 + 7 : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; + 8 + 9 : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT +10 +11 : (" "LIT ; RESTRICT +12 +13 : " COMPILE (" ," ; IMMEDIATE RESTRICT +14 +15 +Screen 63 not modified + 0 \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) + 1 : (." "LIT COUNT TYPE ; RESTRICT + 2 + 3 : ." COMPILE (." ," ; IMMEDIATE RESTRICT + 4 + 5 : ( ASCII ) PARSE 2DROP ; IMMEDIATE + 6 + 7 : .( ASCII ) PARSE TYPE ; IMMEDIATE + 8 + 9 : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE +10 +11 : \\ B/BLK >IN ! ; IMMEDIATE +12 +13 : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; +14 +15 : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; +Screen 64 not modified + 0 \ NUMBER CONV.: DIGIT? ACCUMULATE KS) + 1 : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) + 2 ASCII 0 - DUP 9 U> + 3 IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> + 4 IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN + 5 BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; + 6 + 7 : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) + 8 SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; + 9 +10 : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) +11 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; +12 +13 | : END? ( -- FLAG ) PTR @ 0= ; +14 | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; +15 | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; +Screen 65 not modified + 0 \ ?NONUM ?NUM FIXBASE? 13FEB85KS) + 1 + 2 VARIABLE DPL -1 DPL ! + 3 + 4 | : ?NONUM ( FLAG -- EXIT IF TRUE ) + 5 IF RDROP 2DROP DROP RDROP FALSE THEN ; + 6 + 7 | : ?NUM ( FLAG -- EXIT IF TRUE ) + 8 IF RDROP DROP R> IF DNEGATE THEN + 9 ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; +10 | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) +11 ASCII & CASE? IF 0A TRUE EXIT THEN +12 ASCII $ CASE? IF 10 TRUE EXIT THEN +13 ASCII H CASE? IF 10 TRUE EXIT THEN +14 ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; +15 +Screen 66 not modified + 0 \ 13FEB85KS) + 1 + 2 | : PUNCTUATION? ( CHAR -- FLAG) + 3 ASCII , OVER = SWAP ASCII . = OR ; + 4 + 5 | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; + 6 + 7 | VARIABLE PTR \ POINTS INTO STRING + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 67 not modified + 0 \ (NUMBER NUMBER 13FEB85KS) + 1 : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) + 2 BASE PUSH DUP COUNT PTR ! DPL ON + 3 0 >R ( +SIGN) + 4 0.0 ROT END? ?NONUM CHAR + 5 ASCII - CASE? + 6 IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? + 7 IF BASE ! END? ?NONUM CHAR THEN + 8 BEGIN DIGIT? 0= ?NONUM + 9 BEGIN ACCUMULATE ?DPL END? ?NUM +10 CHAR DIGIT? 0= UNTIL +11 PREVIOUS PUNCTUATION? 0= ?NONUM +12 DPL OFF END? ?NUM CHAR +13 REPEAT ; +14 : NUMBER ( STRING -- D ) +15 NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; +Screen 68 not modified + 0 \ HIDE REVEAL IMMEDIATE RESTRICT KS) + 1 VARIABLE LAST 0 LAST ! + 2 + 3 | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; + 4 + 5 : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; + 6 + 7 : REVEAL LAST? IF 2- CURRENT @ ! THEN ; + 8 + 9 : RECURSIVE REVEAL ; IMMEDIATE RESTRICT +10 +11 | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; +12 +13 : IMMEDIATE 040 FLAG! ; +14 +15 : RESTRICT 080 FLAG! ; +Screen 69 not modified + 0 \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 + 1 + 2 CODE CLEARSTACK USER' S0 # LDY + 3 UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA + 4 1 # LDY NEXT JMP END-CODE + 5 + 6 : HALLOT ( QUAN -- ) S0 @ OVER - SWAP + 7 SP@ 2+ DUP ROT - DUP S0 ! + 8 2 PICK OVER - MOVE CLEARSTACK S0 ! ; + 9 +10 : HEAP ( -- ADDR) S0 @ 6+ ; +11 +12 : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; +13 +14 | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - +15 DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; +Screen 70 not modified + 0 \ DOES> ; 30DEC84KS/BP) + 1 + 2 LABEL (DODOES> RP 2DEC + 3 IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP + 4 CLC W X) LDA 3 # ADC IP STA + 5 TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP + 6 LABEL DOCREATE + 7 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE + 8 + 9 | : (;CODE R> LAST @ NAME> ! ; +10 +11 : DOES> COMPILE (;CODE 04C C, +12 COMPILE (DODOES> ; IMMEDIATE RESTRICT +13 +14 +15 +Screen 71 not modified + 0 \ 6502-ALIGN ?HEAD \ 08SEP84BP) + 1 + 2 | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; + 3 + 4 + 5 | : 6502-ALIGN/2 ( LFA -- LFA ) + 6 HERE 0FF AND 0FF = + 7 IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID + 8 1 LAST +! 1 ALLOT THEN ; + 9 +10 VARIABLE ?HEAD 0 ?HEAD ! +11 +12 : | ?HEAD @ ?EXIT -1 ?HEAD ! ; +13 +14 +15 +Screen 72 not modified + 0 \ WARNING CREATE 30DEC84BP) + 1 + 2 VARIABLE WARNING 0 WARNING ! + 3 + 4 | : EXISTS? + 5 WARNING @ ?EXIT + 6 LAST @ CURRENT @ (FIND NIP + 7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; + 8 + 9 : CREATE HERE BLK @ , CURRENT @ @ , +10 NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" +11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ +12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE +13 HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! +14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , +15 ;CODE DOCREATE JMP END-CODE +Screen 73 not modified + 0 \ NFA? 30DEC84BP) + 1 | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) + 2 SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC + 3 [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA + 4 N 2+ ORA 0= ?[ PUTFALSE JMP ]? + 5 N 2+ )Y LDA SP )Y STA N 1+ STA + 6 N 2+ X) LDA SP X) STA N STA + 7 N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK + 8 N 2INC N X) LDA PHA SEC 01F # AND + 9 N ADC N STA CS ?[ N 1+ INC ]? +10 PLA 020 # AND 0= NOT +11 ?[ N )Y LDA PHA +12 N X) LDA N STA PLA N 1+ STA ]? +13 N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 +14 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY +15 ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT +Screen 74 not modified + 0 \ >NAME NAME> >BODY .NAME 03FEB85BP) + 1 + 2 : >NAME ( CFA -- NFA / FALSE) VOC-LINK + 3 BEGIN @ DUP WHILE 2DUP 4 - SWAP + 4 NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; + 5 + 6 | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; + 7 + 8 : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; + 9 +10 : >BODY ( CFA -- PFA) 2+ ; +11 +12 : .NAME ( NFA --) +13 ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE +14 ELSE ." ???" THEN SPACE ; +15 +Screen 75 not modified + 0 \ : ; CONSTANT VARIABLE 09JAN85KS/BP) + 1 + 2 : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 + 3 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE + 4 RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA + 5 W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA + 6 NEXT JMP END-CODE + 7 + 8 : ; 0 ?PAIRS COMPILE EXIT + 9 [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT +10 +11 : CONSTANT ( 16B --) CREATE , +12 ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY +13 W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE +14 +15 : VARIABLE CREATE 2 ALLOT ; +Screen 76 not modified + 0 \ UALLOT USER ALIAS 10JAN85KS/BP) + 1 + 2 : UALLOT ( QUAN -- OFFSET) + 3 DUP UDP @ + 0FF U> ABORT" USERAREA FULL" + 4 UDP @ SWAP UDP +! ; + 5 + 6 : USER CREATE 2 UALLOT C, + 7 ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA + 8 TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE + 9 +10 : ALIAS ( CFA --) +11 CREATE LAST @ DUP C@ 020 AND +12 IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; +13 +14 +15 +Screen 77 not modified + 0 \ VOC-LINK VP CURRENT CONTEXT ALSO BP) + 1 CREATE VP 10 ALLOT + 2 + 3 VARIABLE CURRENT + 4 + 5 : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; + 6 + 7 | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; + 8 \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : + 9 \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER +10 +11 : ALSO VP @ +12 0A > ERROR" VOCABULARY STACK FULL" +13 CONTEXT @ 2 VP +! CONTEXT ! ; +14 +15 : TOSS -2 VP +! ; +Screen 78 not modified + 0 \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) + 1 + 2 : VOCABULARY CREATE 0 , 0 , + 3 HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; + 4 + 5 \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK + 6 + 7 VOCABULARY FORTH + 8 + 9 VOCABULARY ONLY +10 ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! +11 +12 : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; +13 +14 +15 +Screen 79 not modified + 0 \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) + 1 + 2 : DEFINITIONS CONTEXT @ CURRENT ! ; + 3 + 4 | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; + 5 + 6 : ORDER + 7 THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; + 8 + 9 : WORDS CONTEXT @ +10 BEGIN @ DUP STOP? 0= AND +11 WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; +12 +13 +14 +15 +Screen 80 not modified + 0 \ (FIND 08APR85BP) + 1 + 2 CODE (FIND ( STRING THREAD + 3 -- STRING FALSE / NAMEFIELD TRUE) + 4 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] + 5 N 2+ X) LDA 01F # AND N 4 + STA + 6 LABEL FINDLOOP 0 # LDY + 7 N )Y LDA TAX INY + 8 N )Y LDA N 1+ STA N STX N ORA + 9 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? +10 INY N )Y LDA 01F # AND N 4 + CMP +11 FINDLOOP BNE \ COUNTBYTE MATCH +12 CLC 2 # LDA N ADC N 5 + STA +13 0 # LDA N 1+ ADC N 6 + STA +14 N 4 + LDY +15 [[ N 2+ )Y LDA N 5 + )Y CMP +Screen 81 not modified + 0 \ + 1 FINDLOOP BNE DEY 0= ?] + 2 3 # LDY N 6 + LDA SP )Y STA DEY + 3 N 5 + LDA SP )Y STA + 4 DEY 0 # LDX PUTTRUE JMP END-CODE + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 82 not modified + 0 \ FOUND 29JAN85BP) + 1 + 2 | CODE FOUND ( NFA -- CFA N ) + 3 SP X) LDA N STA SP )Y LDA N 1+ STA + 4 N X) LDA N 2+ STA 01F # AND SEC N ADC N STA + 5 CS ?[ N 1+ INC ]? + 6 N 2+ LDA 020 # AND + 7 0= ?[ N LDA SP X) STA N 1+ LDA + 8 ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA + 9 SP 2DEC N 2+ LDA 0< ?[ INY ]? +10 .A ASL +11 0< NOT ?[ TYA 0FF # EOR TAY INY ]? +12 TYA SP X) STA +13 0< ?[ 0FF # LDA 24 C, ]? +14 TXA 1 # LDY SP )Y STA +15 NEXT JMP END-CODE +Screen 83 not modified + 0 \\ + 1 + 2 | : FOUND ( NFA -- CFA N ) + 3 DUP C@ >R (NAME> + 4 R@ 020 AND IF @ THEN + 5 -1 R@ 080 AND IF 1- THEN + 6 R> 040 AND IF NEGATE THEN ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 84 not modified + 0 \ FIND ' ['] 13JAN85BP) cas2013apr05 + 1 + 2 : FIND ( STRING -- CFA N / STRING FALSE) + 3 CONTEXT DUP @ OVER 2- @ = IF 2- THEN + 4 BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN + 5 OVER VP 2+ U> + 6 WHILE SWAP 2- REPEAT NIP FALSE ; + 7 + 8 : ' ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ; + 9 +10 : [COMPILE] ' , ; IMMEDIATE RESTRICT +11 +12 : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT +13 +14 : NULLSTRING? ( STRING -- STRING FALSE / TRUE) +15 DUP C@ 0= DUP IF NIP THEN ; +Screen 85 not modified + 0 \ >INTERPRET 28FEB85BP) + 1 + 2 LABEL JUMP + 3 INY CLC W )Y LDA 2 # ADC IP STA + 4 INY W )Y LDA 0 # ADC IP 1+ STA + 5 1 # LDY NEXT JMP END-CODE + 6 VARIABLE >INTERPRET + 7 + 8 JUMP ' >INTERPRET ! + 9 +10 \\ MAKE VARIABLE >INTERPRET TO SPECIAL +11 DEFER +12 +13 +14 +15 +Screen 86 not modified + 0 \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 + 1 + 2 DEFER NOTFOUND + 3 + 4 : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 + 5 + 6 ' NO.EXTENSIONS IS NOTFOUND + 7 + 8 : INTERPRET >INTERPRET ; -2 ALLOT + 9 +10 | : INTERACTIVE ?STACK NAME FIND ?DUP +11 IF 1 AND IF EXECUTE >INTERPRET THEN +12 ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? +13 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT +14 +15 ' INTERACTIVE >INTERPRET ! +Screen 87 not modified + 0 \ COMPILING [ ] 20DEC84BP) + 1 + 2 | : COMPILING + 3 ?STACK NAME FIND ?DUP + 4 IF 0> IF EXECUTE >INTERPRET THEN + 5 , >INTERPRET THEN + 6 NULLSTRING? ?EXIT NUMBER? ?DUP + 7 IF 0> IF SWAP [COMPILE] LITERAL THEN + 8 [COMPILE] LITERAL + 9 ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT +10 +11 : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE +12 +13 : ] ['] COMPILING IS >INTERPRET STATE ON ; +14 +15 +Screen 88 not modified + 0 \ PERFOM DEFER IS 03FEB85BP) + 1 + 2 | : CRASH TRUE ABORT" CRASH" ; + 3 + 4 : DEFER CREATE ['] CRASH , + 5 ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA + 6 W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE + 7 + 8 : (IS R> DUP 2+ >R @ ! ; + 9 +10 | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = +11 SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; +12 +13 : IS ( ADR -- ) ' DUP DEF? >BODY +14 STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE +15 +Screen 89 not modified + 0 \ ?STACK 08SEP84KS) + 1 + 2 | : STACKFULL ( -- ) + 3 DEPTH 20 > ABORT" TIGHT STACK" + 4 REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN + 5 (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; + 6 + 7 CODE ?STACK USER' DP # LDY + 8 SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC + 9 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? +10 USER' S0 # LDY UP )Y LDA SP CMP INY +11 UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? +12 ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT +13 +14 \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN +15 SP@ S0 @ U> ABORT" STACK EMPTY" ; +Screen 90 not modified + 0 \ .STATUS PUSH LOAD 08SEP84KS) + 1 + 2 DEFER .STATUS ' NOOP IS .STATUS + 3 + 4 | CREATE PULL 0 ] R> R> ! ; + 5 + 6 : PUSH ( ADDR -- ) + 7 R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT + 8 + 9 +10 : LOAD ( BLK --) +11 ?DUP 0= ?EXIT BLK PUSH BLK ! +12 >IN PUSH >IN OFF .STATUS INTERPRET ; +13 +14 +15 +Screen 91 not modified + 0 \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) + 1 + 2 : +LOAD ( OFFSET --) BLK @ + LOAD ; + 3 + 4 : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; + 5 + 6 : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; + 7 + 8 : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE + 9 +10 : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; +11 +12 : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; +13 +14 +15 +Screen 92 not modified + 0 \ QUIT (QUIT ABORT 07JUN85BP) + 1 + 2 | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; + 3 + 4 : (QUIT + 5 BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT + 6 + 7 DEFER 'QUIT ' (QUIT IS 'QUIT + 8 + 9 : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT +10 +11 : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; +12 +13 DEFER 'ABORT ' NOOP IS 'ABORT +14 +15 : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT +Screen 93 not modified + 0 \ (ERROR ABORT" ERROR" 20MAR85BP) + 1 + 2 VARIABLE SCR 1 SCR ! + 3 + 4 VARIABLE R# 0 R# ! + 5 + 6 : (ERROR ( STRING -- ) + 7 STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR + 8 BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT + 9 +10 ' (ERROR ERRORHANDLER ! +11 +12 : (ABORT" "LIT SWAP IF +13 >R CLEARSTACK R> ERRORHANDLER PERFORM +14 EXIT THEN DROP ; RESTRICT +15 +Screen 94 not modified + 0 \ + 1 + 2 | : (ERR" "LIT SWAP + 3 IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT + 4 + 5 : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT + 6 + 7 : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 95 not modified + 0 \ -TRAILING 08APR85BP) + 1 + 2 020 CONSTANT BL + 3 + 4 CODE -TRAILING ( ADDR N1 -- ADR N2 ) + 5 TYA SETUP JSR + 6 SP X) LDA N 2+ STA CLC + 7 SP )Y LDA N 1+ ADC N 3 + STA + 8 N LDY CLC CS ?[ + 9 LABEL (-TRAIL +10 DEY N 2+ )Y LDA BL # CMP +11 0<> ?[ INY 0= ?[ N 1+ INC ]? +12 TYA PHA N 1+ LDA PUSH JMP ]? +13 ]? TYA (-TRAIL BNE +14 N 3 + DEC N 1 + DEC (-TRAIL BPL +15 TYA PUSH0A JMP END-CODE +Screen 96 not modified + 0 \ SPACE SPACES 29JAN85KS/BP) + 1 + 2 : SPACE BL EMIT ; + 3 + 4 : SPACES ( U --) 0 ?DO SPACE LOOP ; + 5 + 6 \\ + 7 : -TRAILING ( ADDR N1 -- ADDR N2) + 8 2DUP BOUNDS + 9 ?DO 2DUP + 1- C@ BL - +10 IF LEAVE THEN 1- LOOP ; +11 +12 +13 +14 +15 +Screen 97 not modified + 0 \ HOLD <# #> SIGN # #S 24DEC83KS) + 1 | : HLD ( -- ADDR) PAD 2- ; + 2 + 3 : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; + 4 + 5 : <# HLD HLD ! ; + 6 + 7 : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; + 8 + 9 : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; +10 +11 : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < +12 IF [ ASCII A ASCII 9 - 1- ] LITERAL + +13 THEN ASCII 0 + HOLD ; +14 +15 : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; +Screen 98 not modified + 0 \ PRINT NUMBERS 24DEC83KS) + 1 + 2 : D.R -ROT UNDER DABS <# #S ROT SIGN #> + 3 ROT OVER MAX OVER - SPACES TYPE ; + 4 + 5 : .R SWAP EXTEND ROT D.R ; + 6 + 7 : U.R 0 SWAP D.R ; + 8 + 9 : D. 0 D.R SPACE ; +10 +11 : . EXTEND D. ; +12 +13 : U. 0 D. ; +14 +15 +Screen 99 not modified + 0 \ .S LIST C/L L/S 24DEC83KS) + 1 + 2 : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; + 3 + 4 40 CONSTANT C/L \ SCREEN LINE LENGTH + 5 + 6 10 CONSTANT L/S \ LINES PER SCREEN + 7 + 8 : LIST ( BLK --) + 9 SCR ! ." SCR " SCR @ DUP U. +10 ." DR " DRV? . +11 L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK +12 I C/L * + C/L -TRAILING TYPE LOOP CR ; +13 +14 +15 +Screen 100 not modified + 0 \ MULTITASKER PRIMITIVES BP03NOV85) + 1 CODE PAUSE NEXT HERE 2- ! END-CODE + 2 + 3 : LOCK ( ADDR --) + 4 DUP @ UP@ = IF DROP EXIT THEN + 5 BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; + 6 + 7 : UNLOCK ( ADDR --) DUP LOCK OFF ; + 8 + 9 LABEL WAKE WAKE >WAKE ! +10 PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA +11 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA +12 INY UP )Y LDA SP 1+ STA 1 # LDY +13 SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC +14 IP # LDX XPULL JMP END-CODE +15 +Screen 101 not modified + 0 \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 + 1 + 2 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK + 3 + 4 VARIABLE PREV 0 PREV ! \ LISTHEAD + 5 + 6 | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR + 7 + 8 0408 CONSTANT B/BUF \ size of buffer + 9 +10 +11 +12 +13 +14 +15 +Screen 102 not modified + 0 \\ structure of buffer (same for all volksFORTH ) cas 26jan06 + 1 0 : LINK + 2 2 : FILE + 3 6 : BLOCKNR + 4 8 : STATUSFLAGS + 5 0A : DATA .. 1 KB .. + 6 + 7 STATUSFLAG BITS: 15 1 -> UPDATED + 8 + 9 FILE = -1 EMPTY BUFFER +10 = 0 NO FCB , DIRECT ACCESS +11 = ELSE ADR OF FCB +12 ( SYSTEM DEPENDENT ) +13 +14 +15 +Screen 103 not modified + 0 \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) + 1 + 2 LABEL THISBUFFER? 2 # LDY + 3 [[ N 4 + )Y LDA N 2- ,Y CMP + 4 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) + 5 + 6 | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) + 7 \ N-AREA : 0 BLK 2 FILE 4 BUFFER + 8 \ 6 PREDECESSOR + 9 3 # LDY +10 [[ SP )Y LDA N ,Y STA DEY 0< ?] +11 USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA +12 INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA +13 PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ +14 +15 +Screen 104 not modified + 0 \ " 11JUN85BP) + 1 + 2 LABEL BLOCKFOUND SP 2INC 1 # LDY + 3 8 # LDA CLC N 4 + ADC SP X) STA + 4 N 5 + LDA 0 # ADC SP )Y STA + 5 ' EXIT @ JMP ]? + 6 [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA + 7 N 6 + X) LDA N 4 + STA 1 # LDY + 8 N 6 + )Y LDA N 5 + STA N 4 + ORA + 9 0= ?[ ( LIST EMPTY ) NEXT JMP ]? +10 THISBUFFER? JSR 0= ?] \ FOUND, RELINK +11 N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA +12 PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA +13 N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA +14 BLOCKFOUND JMP END-CODE +15 +Screen 105 not modified + 0 \\ (CORE? 23SEP85BP + 1 | : this? ( blk file bufadr -- flag ) + 2 DUP 4+ @ SWAP 2+ @ D= ; + 3 + 4 | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) + 5 BEGIN OVER OFFSET @ + OVER PREV @ + 6 THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN + 7 2DUP >R OFFSET @ + >R PREV @ + 8 BEGIN DUP @ ?DUP + 9 0= IF RDROP RDROP DROP EXIT THEN +10 DUP R> R> 2DUP >R >R ROT THIS? 0= +11 WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! +12 RDROP RDROP REPEAT ; -2 ALLOT +13 +14 +15 +Screen 106 not modified + 0 \ (DISKERR 11JUN85BP) + 1 + 2 : (DISKERR ." ERROR ! R TO RETRY " + 3 KEY DUP ASCII R = SWAP ASCII R = + 4 OR NOT ABORT" ABORTED" ; + 5 + 6 + 7 DEFER DISKERR ' (DISKERR IS DISKERR + 8 + 9 DEFER R/W +10 +11 +12 +13 +14 +15 +Screen 107 not modified + 0 \ BACKUP EMPTYBUF READBLK 11JUN85BP) + 1 | : BACKUP ( BUFADDR --) + 2 DUP 6+ @ 0< + 3 IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 + 4 IF INPUT PUSH OUTPUT PUSH STANDARDI/O + 5 BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W + 6 WHILE ." WRITE " DISKERR + 7 REPEAT THEN + 8 080 OVER 4+ 1+ CTOGGLE THEN DROP ; + 9 +10 | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; +11 +12 | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) +13 DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R +14 BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W +15 WHILE ." READ " DISKERR REPEAT R> ; +Screen 108 not modified + 0 \ TAKE MARK UPDATES? FULL? CORE? BP) + 1 + 2 | : TAKE ( -- BUFADDR) PREV + 3 BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL + 4 BUFFERS LOCK DUP BACKUP ; + 5 + 6 | : MARK ( BLK FILE BUFADDR -- BLK FILE ) + 7 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! + 8 R> 4+ OFF BUFFERS UNLOCK ; + 9 +10 | : UPDATES? ( -- BUFADDR / FLAG) +11 PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; +12 +13 | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; +14 +15 : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; +Screen 109 not modified + 0 \ BLOCK & BUFFER MANIPULATION 11JUN85BP) + 1 + 2 : (BUFFER ( BLK FILE -- ADDR) + 3 BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT + 4 + 5 : (BLOCK ( BLK FILE -- ADDR) + 6 BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT + 7 + 8 | CODE FILE@ ( -- N ) USER' FILE # LDY + 9 UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE +10 +11 : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; +12 +13 : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; +14 +15 +Screen 110 not modified + 0 \ BLOCK & BUFFER MANIPULATION 09SEP84KS) + 1 + 2 : UPDATE 080 PREV @ 6+ 1+ C! ; + 3 + 4 : SAVE-BUFFERS + 5 BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT + 6 BUFFERS UNLOCK ; + 7 + 8 : EMPTY-BUFFERS + 9 BUFFERS LOCK PREV +10 BEGIN @ ?DUP +11 WHILE DUP EMPTYBUF +12 REPEAT BUFFERS UNLOCK ; +13 +14 : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; +15 +Screen 111 not modified + 0 \ MOVING BLOCKS 15DEC83KS) cas 26jan06 + 1 | : (COPY ( FROM TO --) DUP FILE@ + 2 CORE? IF PREV @ EMPTYBUF THEN + 3 FULL? IF SAVE-BUFFERS THEN + 4 OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; + 5 + 6 | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R + 7 OVER R@ + OVER U> >R 2DUP U< R> AND + 8 IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP + 9 ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP +10 THEN SAVE-BUFFERS 2DROP ; +11 +12 : COPY ( FROM TO --) 1 BLKMOVE ; +13 +14 : CONVEY ( [BLK1 BLK2] [TO.BLK --) +15 SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; +Screen 112 not modified + 0 \ ALLOCATING BUFFERS 23SEP83KS) cas2013apr04 + 1 + 2 7F00 CONSTANT LIMIT VARIABLE FIRST + 3 + 4 : ALLOTBUFFER ( -- ) + 5 FIRST @ R0 @ - B/BUF 2+ U< ?EXIT + 6 B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF + 7 PREV @ OVER ! PREV ! ; + 8 + 9 : FREEBUFFER ( -- ) +10 FIRST @ LIMIT B/BUF - U< +11 IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT +12 FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; +13 +14 : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; +15 +Screen 113 not modified + 0 \ ENDPOINTS OF FORGET 04JAN85BP/KS) + 1 | : \? ( NFA -- FLAG ) C@ 020 AND ; + 2 + 3 | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? + 4 NAME> UNDER 1+ U< SWAP HEAP? OR ; + 5 + 6 | : ENDPOINTS ( ADDR -- ADDR SYMB) + 7 HEAP VOC-LINK @ >R + 8 BEGIN R> @ ?DUP \ THROUGH ALL VOCABS + 9 WHILE DUP >R 4 - >R \ LINK ON RETURNST. +10 BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR +11 SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR +12 WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP +13 R@ 2+ \? IF OVER R@ 2+ FORGET? +14 IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB +15 THEN REPEAT RDROP REPEAT ; +Screen 114 not modified + 0 \ REMOVE 23JUL85WE + 1 + 2 | CODE REMOVE ( DIC SYMB THR - DIC SYMB) + 3 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY + 4 CLC UP )Y LDA 6 # ADC N 6 + STA + 5 INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY + 6 [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> + 7 ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS + 8 ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC + 9 ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC +10 ]? CC +11 ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA +12 ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? +13 ]]? (DROP JMP END-CODE +14 +15 +Screen 115 not modified + 0 \ REMOVE- FORGET-WORDS 29APR85BP) + 1 + 2 | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) + 3 VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; + 4 + 5 | : REMOVE-TASKS ( DIC --) + 6 UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN + 7 IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; + 8 + 9 | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) +10 VOC-LINK REMOVE THRU.VOCSTACK +11 DO 2DUP I @ -ROT UWITHIN +12 IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP +13 2DUP CURRENT @ -ROT UWITHIN +14 IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; +15 +Screen 116 not modified + 0 \ FORGET-WORDS cas 26jan06 + 1 + 2 | : FORGET-WORDS ( DIC SYMB --) + 3 OVER REMOVE-TASKS REMOVE-VOCS + 4 REMOVE-WORDS + 5 HEAP SWAP - HALLOT DP ! 0 LAST ! ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 117 not modified + 0 \ DELETING WORDS FROM DICT. 13JAN83KS) + 1 + 2 : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; + 3 + 4 : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" + 5 ENDPOINTS FORGET-WORDS ; + 6 + 7 : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" + 8 >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; + 9 +10 : EMPTY [ DP ] LITERAL @ +11 UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; +12 +13 +14 +15 +Screen 118 not modified + 0 \ SAVE BYE STOP? ?CR 20OCT84KS/BP) + 1 + 2 : SAVE + 3 HERE UP@ FORGET-WORDS VOC-LINK @ + 4 BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL + 5 UP@ ORIGIN 0100 CMOVE ; + 6 + 7 : BYE FLUSH EMPTY (BYE ; + 8 + 9 | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; +10 +11 : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; +12 +13 : ?CR COL C/L 0A - U> IF CR THEN ; +14 +15 +Screen 119 not modified + 0 \ IN/OUTPUT STRUCTURE 02MAR85BP) + 1 | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; + 2 + 3 : OUTPUT: CREATE ] DOES> OUTPUT ! ; + 4 0 OUT: EMIT OUT: CR OUT: TYPE + 5 OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP + 6 + 7 : ROW ( -- ROW) AT? DROP ; + 8 : COL ( -- COL) AT? NIP ; + 9 +10 | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; +11 +12 : INPUT: CREATE ] DOES> INPUT ! ; +13 +14 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP +15 +Screen 120 not modified + 0 \ ALIAS ONLY DEFINITIONEN 29JAN85BP) + 1 + 2 ONLY DEFINITIONS FORTH + 3 + 4 : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) + 5 + 6 ' ONLY ALIAS ONLY + 7 ' FORTH ALIAS FORTH + 8 ' WORDS ALIAS WORDS + 9 ' ALSO ALIAS ALSO +10 ' DEFINITIONS ALIAS DEFINITIONS +11 HOST TARGET +12 +13 +14 +15 +Screen 121 not modified + 0 \ 'COLD 07JUN85BP) cas2013apr05 + 1 | : INIT-VOCABULARYS VOC-LINK @ + 2 BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; + 3 + 4 | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; + 5 + 6 DEFER 'COLD ' NOOP IS 'COLD + 7 + 8 | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH + 9 ." volksFORTH-83 3.8.7 05apr13 CS" CR RESTART ; -2 ALLOT +10 +11 DEFER 'RESTART ' NOOP IS 'RESTART +12 | : (RESTART ['] (QUIT IS 'QUIT +13 DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! +14 ['] NOOP IS 'ABORT ABORT ; -2 ALLOT +15 +Screen 122 not modified + 0 \ COLD BOOTSYSTEM RESTART 09JUL85WE) + 1 CODE COLD HERE >COLD ! + 2 ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA + 3 + 4 LABEL BOOTSYSTEM CLI 0 # LDY + 5 CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA + 6 [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] + 7 LABEL WARMBOOT BOOTNEXTLEN 1- # LDY + 8 [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] + 9 CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA +10 USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA +11 USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA +12 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA +13 PLA IP STA PLA IP 1+ STA +14 LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE +15 +Screen 123 not modified + 0 \ ( RESTART PARAM.-PASSING TO FORTH BP) + 1 + 2 CODE RESTART HERE >RESTART ! + 3 ' (RESTART >BODY 100 U/MOD + 4 # LDA PHA # LDA PHA WARMBOOT JMP END-CODE + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 124 not modified + 0 \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 + 1 + 2 \ Include system dependent Input / Output code + 3 \ (Keyboard and Screen) + 4 include systemio.fb + 5 + 6 + 7 HOST ' TRANSIENT 8 + @ + 8 TRANSIENT FORTH CONTEXT @ 6 + ! + 9 TARGET +10 +11 FORTH ALSO DEFINITIONS +12 +13 : FORTH-83 ; \ LAST WORD IN DICTIONARY +14 +15 +Screen 125 not modified + 0 \ SYSTEM DEPENDENT CONSTANTS BP/KS) + 1 + 2 VOCABULARY ASSEMBLER + 3 ASSEMBLER DEFINITIONS + 4 TRANSIENT ASSEMBLER + 5 PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK + 6 PUSH0A CONSTANT PUSH0A \ PUT A ON STACK + 7 PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK + 8 RP CONSTANT RP + 9 UP CONSTANT UP +10 SP CONSTANT SP +11 IP CONSTANT IP +12 N CONSTANT N +13 PUTA CONSTANT PUTA +14 W CONSTANT W +15 SETUP CONSTANT SETUP +Screen 126 not modified + 0 \ + 1 NEXT CONSTANT NEXT + 2 XYNEXT CONSTANT XYNEXT + 3 (2DROP CONSTANT POPTWO + 4 (DROP CONSTANT POP + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 127 not modified + 0 \ SYSTEM PATCHUP 05JAN85BP) cas2013apr05 + 1 + 2 FORTH DEFINITIONS + 3 + 4 \ change memory layout for stacks and buffers here + 5 TOPADDR ' LIMIT >BODY ! + 6 TOPADDR $F00 - S0 ! TOPADDR $480 - R0 ! + 7 + 8 S0 @ DUP S0 2- ! 6 + S0 7 - ! + 9 HERE DP ! +10 +11 HOST TUDP @ TARGET UDP ! +12 HOST TVOC-LINK @ TARGET VOC-LINK ! +13 HOST MOVE-THREADS +14 +15 ) +Screen 128 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 129 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 130 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 131 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/as65.fb.src b/sources/Apple1/as65.fb.src new file mode 100644 index 0000000..b897f53 --- /dev/null +++ b/sources/Apple1/as65.fb.src @@ -0,0 +1,204 @@ +Screen 0 not modified + 0 \ FORTH-6502 ASSEMBLER WFR ) cas 26jan06 + 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) + 2 + 3 Load from Screen 1 for the transient assembler: + 4 This 6502 Forth Assembler can be loaded into the heap + 5 and then not be saved in the final binary to save memory. + 6 + 7 Load from Screen 2 for the regular assembler: + 8 This 6502 Forth Assembler will be loaded into normal + 9 memory and will be saved into the final binary. +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88 + 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) + 2 + 3 ( INTERNAL LOADING 04MAY85BP/RE) + 4 hex + 5 \ HERE $200 HALLOT HEAP DP ! + 6 &10 LOAD + 7 &11 LOAD + 8 3 &8 THRU + 9 &9 LOAD \ for System-Assembler +10 +11 \ DP ! +12 +13 ONLYFORTH +14 decimal +15 +Screen 2 not modified + 0 \ FORTH-65 ASSEMBLER WFR ) er14dez88 + 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) + 2 ONLYFORTH + 3 Vocabulary tassembler + 4 TASSEMBLER ALSO DEFINITIONS + 5 hex + 6 + 7 8 +load \ relocate + 8 1 6 +THRU + 9 \ 7 +load \ System Assembler +10 decimal +11 +12 +13 +14 +15 +Screen 3 not modified + 0 \ FORTH-83 6502-ASSEMBLER ) er14dez88 + 1 : END-CODE CONTEXT 2- @ CONTEXT ! ; + 2 CREATE INDEX + 3 09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c, + 4 09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c, + 5 80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c, + 6 80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c, + 7 + 8 | VARIABLE MODE + 9 +10 : MODE: ( N -) CREATE C, DOES> ( -) C@ MODE ! ; +11 +12 0 MODE: .A 1 MODE: # 2 | MODE: MEM 3 MODE: ,X +13 4 MODE: ,Y 5 MODE: X) 6 MODE: )Y 0F MODE: ) +14 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +15 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +Screen 4 not modified + 0 \ UPMODE CPU ) er14dez88 + 1 | : UPMODE ( ADDR0 F0 - ADDR1 F1) + 2 IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F AND ?DUP IF + 3 0 DO DUP + LOOP THEN OVER 1+ @ AND 0= ; + 4 + 5 : CPU ( 8B -) CREATE C, DOES> ( -) C@ >c, MEM ; + 6 + 7 00 CPU BRK 18 CPU CLC D8 CPU CLD + 8 58 CPU CLI B8 CPU CLV CA CPU DEX + 9 88 CPU DEY E8 CPU INX C8 CPU INY +10 EA CPU NOP 48 CPU PHA 08 CPU PHP +11 68 CPU PLA 28 CPU PLP 40 CPU RTI +12 60 CPU RTS 38 CPU SEC F8 CPU SED +13 78 CPU SEI AA CPU TAX A8 CPU TAY +14 BA CPU TSX 8A CPU TXA 9A CPU TXS +15 98 CPU TYA +Screen 5 not modified + 0 \ M/CPU ) er14dez88 + 1 + 2 : M/CPU ( MODE OPCODE -) CREATE C, , DOES> + 3 DUP 1+ @ 80 AND IF 10 MODE +! THEN OVER FF00 AND UPMODE UPMODE + 4 IF MEM TRUE ABORT" INVALID" THEN + 5 C@ MODE @ INDEX + C@ + >c, MODE @ 7 AND + 6 IF MODE @ 0F AND 7 < IF >c, ELSE >, THEN THEN MEM ; + 7 + 8 1C6E 60 M/CPU ADC 1C6E 20 M/CPU AND 1C6E C0 M/CPU CMP + 9 1C6E 40 M/CPU EOR 1C6E A0 M/CPU LDA 1C6E 00 M/CPU ORA +10 1C6E E0 M/CPU SBC 1C6C 80 M/CPU STA 0D0D 01 M/CPU ASL +11 0C0C C1 M/CPU DEC 0C0C E1 M/CPU INC 0D0D 41 M/CPU LSR +12 0D0D 21 M/CPU ROL 0D0D 61 M/CPU ROR 0414 81 M/CPU STX +13 0486 E0 M/CPU CPX 0486 C0 M/CPU CPY 1496 A2 M/CPU LDX +14 0C8E A0 M/CPU LDY 048C 80 M/CPU STY 0480 14 M/CPU JSR +15 8480 40 M/CPU JMP 0484 20 M/CPU BIT +Screen 6 not modified + 0 \ ASSEMBLER CONDITIONALS ) er14dez88 + 1 + 2 | : RANGE? ( BRANCH -- BRANCH ) + 3 DUP ABS 07F U> ABORT" OUT OF RANGE " ; + 4 + 5 : [[ ( BEGIN) >here ; + 6 : ?] ( UNTIL) >c, >here 1+ - RANGE? >c, ; + 7 : ?[ ( IF) >c, >here 0 >c, ; + 8 : ?[[ ( WHILE) ?[ SWAP ; + 9 : ]? ( THEN) >here OVER >c@ IF SWAP >! +10 ELSE OVER 1+ - RANGE? SWAP >c! THEN ; +11 : ][ ( ELSE) >here 1+ 1 JMP +12 SWAP >here OVER 1+ - RANGE? SWAP >c! ; +13 : ]] ( AGAIN) JMP ; +14 : ]]? ( REPEAT) JMP ]? ; +15 +Screen 7 not modified + 0 \ ASSEMBLER CONDITIONALS ) er14dez88 + 1 + 2 90 CONSTANT CS B0 CONSTANT CC + 3 D0 CONSTANT 0= F0 CONSTANT 0<> + 4 10 CONSTANT 0< 30 CONSTANT 0>= + 5 50 CONSTANT VS 70 CONSTANT VC + 6 + 7 : NOT 20 [ FORTH ] XOR ; + 8 + 9 : BEQ 0<> ?] ; : BMI 0>= ?] ; +10 : BNE 0= ?] ; : BPL 0< ?] ; +11 : BCC CS ?] ; : BVC VS ?] ; +12 : BCS CC ?] ; : BVS VC ?] ; +13 +14 +15 +Screen 8 not modified + 0 \ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88 + 1 + 2 : 2INC + 3 DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ; + 4 + 5 : 2DEC + 6 DUP LDA SEC 2 # SBC DUP STA CC ?[ SWAP 1+ DEC ]? ; + 7 + 8 : WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; + 9 +10 : WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; +11 +12 : ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; +13 +14 +15 +Screen 9 not modified + 0 \ ;CODE CODE CODE> BP 03 02 85) er14dez88 + 1 ONLYFORTH + 2 + 3 : ASSEMBLER ASSEMBLER [ ASSEMBLER ] MEM ; + 4 + 5 : ;CODE [COMPILE] DOES> -3 >allot + 6 [COMPILE] ; -2 >allot ASSEMBLER ; IMMEDIATE + 7 + 8 : CODE CREATE >here DUP 2- >! ASSEMBLER ; + 9 +10 : >LABEL ( ADR -) +11 >here | CREATE SWAP , 4 HALLOT +12 HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE +13 HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ; +14 +15 : LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ; +Screen 10 not modified + 0 \ Code generating primitives er14dez88 + 1 + 2 Variable >codes + 3 | Create nrc ] c, , c@ here allot ! c! [ + 4 + 5 : nonrelocate nrc >codes ! ; nonrelocate + 6 + 7 | : >exec Create c, + 8 Does> c@ >codes @ + @ execute ; + 9 +10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +11 | 6 >exec >here | 8 >exec >allot | $0A >exec >! +12 | $0C >exec >c! +13 +14 +15 +Screen 11 not modified + 0 \ FORTH-65 ASSEMBLER WFR ) er14dez88 + 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) + 2 ONLYFORTH + 3 + 4 ASSEMBLER ALSO DEFINITIONS + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/assemble.fb.src b/sources/Apple1/assemble.fb.src new file mode 100644 index 0000000..cbb4b67 --- /dev/null +++ b/sources/Apple1/assemble.fb.src @@ -0,0 +1,323 @@ +Screen 0 not modified + 0 \\ *** Assembler *** 25may86we + 1 + 2 Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. + 3 Der Assembler basiert auf dem von Michael Perry fr F83 entwik- + 4 kelten, enth„lt aber einige zus„tzliche Features. + 5 Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels + 6 verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler + 7 kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner + 8 Tat die Code-Worte mit einem Disassembler zu berprfen. + 9 +10 Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten +11 Assembler auf den Heap laden kann, damit er w„hrend der Kompila- +12 tionszeit zur Verfgung steht, aber keinen Platz im Dictionary +13 verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, +14 wenn er nicht mehr ben”tigt wird. +15 +Screen 1 not modified + 0 \ 68000 Assembler Load Screen 26oct86we + 1 + 2 Onlyforth + 3 Vocabulary Assembler Assembler also definitions + 4 + 5 : end-code context 2- @ context ! ; + 6 ' swap | Alias *swap + 7 + 8 base @ 4 $11 +thru base ! + 9 +10 : reg) size push .l 0 *swap FP DI) ; +11 : Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp +12 >here next-link @ , next-link ! ; +13 +14 2 3 +thru Onlyforth +15 +Screen 2 not modified + 0 \ Internal Assembler 09sep86we + 1 + 2 Onlyforth + 3 + 4 here + 5 $1300 hallot heap dp ! -1 +load + 6 dp ! + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 3 not modified + 0 \ Extended adressing modes 09sep86we + 1 + 2 : R#) ( addr -- ) size push + 3 [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) + 4 [ Forth ] exit THEN .w FP D) ; + 5 + 6 + 7 | : inrange? ( addr -- offset f ) [ Forth ] + 8 >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN + 9 dup >here negate > ; +10 : pcrel) ( addr -- ) \ pc-relativ adressing mode +11 inrange? [ Forth ] 0= abort" out of range" pcd) ; +12 +13 : ;c: 0 recover R#) jsr end-code ] ; +14 +15 +Screen 4 not modified + 0 \ Assembler Forth words 09sep86we + 1 Forth definitions + 2 : Assembler Assembler [ Assembler ] .w ; + 3 : Code Create here dup 2- ! Assembler ; + 4 + 5 | : (;code r> last @ name> ! ; + 6 : ;Code 0 ?pairs compile (;code [compile] [ reveal + 7 Assembler ; immediate restrict + 8 + 9 : >label ( addr -- ) here | Create swap , immediate +10 4 hallot >here 4- heap 4 cmove +11 heap last @ count $1F and + even ! dp ! +12 Does> ( -- addr ) @ +13 state @ IF [compile] Literal THEN ; +14 : Label [ Assembler ] >here [ Forth ] 1 and +15 [ Assembler ] >allot >here >label Assembler ; +Screen 5 not modified + 0 \ Code generating primitives 26oct86we + 1 + 2 Variable >codes + 3 | Create nrc ] c, , c@ here allot ! c! [ + 4 + 5 : nonrelocate nrc >codes ! ; nonrelocate + 6 + 7 | : >exec Create c, + 8 Does> c@ >codes @ + @ execute ; + 9 +10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +11 | 6 >exec >here | 8 >exec >allot | $0A >exec >! +12 | $0C >exec >c! +13 +14 +15 +Screen 6 not modified + 0 \ 68000 Meta Assembler 04sep86we + 1 + 2 | : ?, IF >, THEN >, ; + 3 | : 2, >, >, ; + 4 8 base ! + 5 Variable size + 6 : .b 10000 size ! ; + 7 : .w 30100 size ! ; .w + 8 : .l 24600 size ! ; + 9 +10 | : Sz Constant Does> @ size @ and or ; +11 00300 | Sz sz3 00400 | Sz sz4 +12 04000 | Sz sz40 30000 | Sz sz300 +13 +14 | : long? size @ 24600 = ; +15 | : -sz1 long? IF 100 or THEN ; +Screen 7 not modified + 0 \ addressing modes 09sep86we + 1 + 2 | : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; + 3 | : Mode Constant Does> @ *swap 7007 and or ; + 4 0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 + 5 0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 + 6 0220 Mode ) \ address register indirect + 7 0330 Mode )+ \ adr reg ind post-increment + 8 0440 Mode -) \ adr reg ind pre-decrement + 9 0550 Mode D) \ adr reg ind displaced +10 0660 Mode (DI) \ adr reg ind displaced indexed s.u. +11 0770 Constant #) \ immediate address +12 1771 Constant L#) \ immediate long address +13 2772 Constant pcD) \ pc relative displaced +14 3773 Constant (pcDI) \ pc relative displaced indexed +15 4774 Constant # \ immediate data +Screen 8 not modified + 0 \ fields and register assignments 08sep86we + 1 + 2 | : Field Constant Does> @ and ; + 3 7000 | Field rd 0007 | Field rs + 4 0070 | Field ms 0077 | Field eas + 5 0377 | Field low + 6 | : dn? ( ea -- ea flag ) dup ms 0= ; + 7 | : src ( ea instr -- ea instr' ) over eas or ; + 8 | : dst ( ea instr -- ea instr' ) *swap rd or ; + 9 +10 | : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; +11 | : ??an ( mod -- mod ) dup ms 1 = +12 abort" needs Adress-Register" ; +13 +14 A6 Constant SP A5 Constant RP A4 Constant IP +15 A3 Constant FP +Screen 9 not modified + 0 \ extended addressing 09sep86we + 1 : DI) (DI) size @ *swap ; + 2 : pcDI) (pcDI) size @ *swap ; + 3 + 4 | : double? ( mode -- flag) dup L#) = *swap + 5 # = long? and or ; + 6 | : index? ( {n} mode -- {m} mode ) + 7 dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or + 8 IF size @ >r size ! + 9 dup rd 10 * *swap ms IF 100000 or THEN +10 sz40 *swap low or r> size ! +11 THEN r> ; +12 +13 | : more? ( ea -- ea flag ) dup ms 0040 > ; +14 | : ,more ( ea -- ) more? +15 IF index? double? ?, ELSE drop THEN ; +Screen 10 not modified + 0 \ extended addressing extras 09sep86we + 1 + 2 | Create extra here 5 dup allot erase \ temporary storage area + 3 + 4 | : extra? ( {n} mode -- mode ) more? + 5 IF >r r@ index? double? extra 1+ *swap + 6 IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> + 7 ELSE 0 extra ! + 8 THEN ; + 9 +10 | : ,extra ( -- ) extra c@ ?dup +11 IF extra 1+ *swap 1 = +12 IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase +13 THEN ; +14 +15 +Screen 11 not modified + 0 \ immediates & address register specific 15jan86we + 1 | : Imm Constant Does> @ >r extra? eas r> or + 2 sz3 >, long? ?, ,extra ; ( n ea) + 3 0000 Imm ori 1000 Imm andi + 4 2000 Imm subi 3000 Imm addi + 5 5000 Imm eori 6000 Imm cmpi + 6 | : Immsr Constant Does> @ sz3 2, ; ( n ) + 7 001074 Immsr andi>sr + 8 005074 Immsr eori>sr + 9 000074 Immsr ori>sr +10 | : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or +11 r> or sz3 >, ,extra ; ( n ea ) +12 050000 Iq addq 050400 Iq subq +13 | : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) +14 150300 Ieaa adda 130300 Ieaa cmpa +15 040700 Ieaa lea 110300 Ieaa suba +Screen 12 not modified + 0 \ shifts, rotates, and bit manipulation 15jan86we + 1 | : Isr Constant Does> @ >r dn? + 2 IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN + 3 rd *swap rs or r> or 160000 or sz3 >, + 4 ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or + 5 160000 or >, ,more + 6 THEN ; ( dm dn ) ( m # dn ) ( ea ) + 7 400 Isr asl 000 Isr asr + 8 410 Isr lsl 010 Isr lsr + 9 420 Isr roxl 020 Isr roxr +10 430 Isr rol 030 Isr ror +11 | : Ibit Constant does> @ >r extra? dn? +12 IF rd src 400 ELSE drop dup eas 4000 THEN +13 or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) +14 000 Ibit btst 100 Ibit bchg +15 200 Ibit bclr 300 Ibit bset +Screen 13 not modified + 0 \ branch, loop, and set conditionals 15jan86we + 1 + 2 | : Setclass ' *swap 0 DO I over execute LOOP drop ; + 3 | : Ibra 400 * 060000 or Constant ( label ) + 4 Does> @ *swap >here 2+ - dup abs 200 < + 5 IF low or >, ELSE *swap 2, THEN ; + 6 20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq + 7 bvc bvs bpl bmi bge blt bgt ble + 8 | : Idbr 400 * 050310 or Constant ( label \ dn - ) + 9 Does> @ *swap rs or >, >here - >, ; +10 20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq +11 dbvc dbvs dbpl dbmi dbge dblt dbgt dble +12 | : Iset 400 * 050300 or Constant ( ea ) +13 Does> @ src >, ,more ; +14 20 Setclass Iset set sno shi sls scc scs sne seq +15 svc svs spl smi sge slt sgt sle +Screen 14 not modified + 0 \ moves 15jan86we + 1 + 2 : move extra? 7700 and src sz300 >, + 3 ,more ,extra ; ( ea ea ) + 4 : moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) + 5 : move>usp ??an rs 047140 or >, ; ( an ) + 6 : move, ; ( an ) + 7 : movem> + 8 extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) + 9 : movem< +10 extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) +11 : movep dn? IF rd *swap rs or 410 or +12 ELSE rs rot rd or 610 or THEN -sz1 2, ; +13 ( dm d an ) ( d an dm ) +14 : lmove 7700 and *swap eas or 20000 or >, ; +15 ( long reg move ) +Screen 15 not modified + 0 \ odds and ends 15jan86we + 1 + 2 : cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) + 3 : exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r + 4 ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap + 5 THEN rs dst r> or >, ; ( rn rm ) + 6 : ext ??dn rs 044200 or -sz1 >, ; ( dn ) + 7 : swap ??dn rs 044100 or >, ; ( dn ) + 8 : stop 47162 2, ; ( n ) + 9 : trap 17 and 47100 or >, ; ( n ) +10 : link ??an rs 047120 or 2, ; ( n an ) +11 : unlk ??an rs 047130 or >, ; ( an ) +12 : eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) +13 : cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) +14 +15 +Screen 16 not modified + 0 \ arithmetic and logic 15jan86we + 1 | : Ibcd Constant Does> @ dst over rs or *swap ms + 2 IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) + 3 140400 Ibcd abcd 100400 Ibcd sbcd + 4 | : Idd Constant Does> @ dst over rs or *swap ms + 5 IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) + 6 150400 Idd addx 110400 Idd subx + 7 | : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) + 8 IF rd src r> or sz3 >, ,more + 9 ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; +10 150000 Idea add 110000 Idea sub +11 140000 Idea and 100000 Idea or +12 | : Iead Constant Does> @ >r ??dn r> dst src +13 >, ,more ; ( ea dn) +14 040600 Iead chk 100300 Iead divu 100700 Iead divs +15 140300 Iead mulu 140700 Iead muls +Screen 17 not modified + 0 \ arithmetic and control 15jan86we + 1 + 2 | : Iea Constant Does> @ src >, ,more ; ( ea ) + 3 047200 Iea jsr 047300 Iea jmp + 4 042300 Iea move>ccr + 5 040300 Iea movesr + 6 044000 Iea nbcd 044100 Iea pea + 7 045300 Iea tas + 8 | : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) + 9 041000 Ieas clr 043000 Ieas not +10 042000 Ieas neg 040000 Ieas negx +11 045000 Ieas tst +12 | : Icon Constant Does> @ >, ; +13 47160 Icon reset 47161 Icon nop +14 47163 Icon rte 47165 Icon rts +15 47166 Icon trapv 47167 Icon rtr +Screen 18 not modified + 0 \ structured conditionals +/- 256 bytes 15jan86we + 1 : THEN >here over 2+ - *swap 1+ >c! ; + 2 : IF >, >here 2- ; hex + 3 : ELSE 6000 IF *swap THEN ; + 4 : BEGIN >here ; + 5 : UNTIL >, >here - >here 1- >c! ; + 6 : AGAIN 6000 UNTIL ; + 7 : WHILE IF *swap ; + 8 : REPEAT AGAIN THEN ; + 9 : DO >here *swap ; +10 : LOOP dbra ; +11 6600 Constant 0= 6700 Constant 0<> +12 6A00 Constant 0< 6B00 Constant 0>= +13 6C00 Constant < 6D00 Constant >= +14 6E00 Constant <= 6F00 Constant > +15 6500 Constant CC 6400 Constant CS diff --git a/sources/Apple1/ccompile.fb.src b/sources/Apple1/ccompile.fb.src new file mode 100644 index 0000000..558088a --- /dev/null +++ b/sources/Apple1/ccompile.fb.src @@ -0,0 +1,34 @@ +Screen 0 not modified + 0 \ Crosscompile Script for 6502 Target cas 26jan06 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ loadscreen for cross-compiler cas 26jan06 + 1 + 2 include assemble.fb \ load 68000 assembler + 3 2 loadfrom as65.fb page \ load 6502 assembler + 4 include crostarg.fb page \ load target compiler + 5 include 6502f83.fb \ load Forth Kernel Source + 6 + 7 save-target f6502.com \ save new forth as f6502.com + 8 key drop page .( Ready ) cr \ wait for keypress + 9 bye \ and exit forth +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/crostarg.fb.src b/sources/Apple1/crostarg.fb.src new file mode 100644 index 0000000..4f47fc0 --- /dev/null +++ b/sources/Apple1/crostarg.fb.src @@ -0,0 +1,680 @@ +Screen 0 not modified + 0 \\ *** volksFORTH-84 Target-Compiler *** cas 26jan06 + 1 + 2 This Target Compiler can be used to create a new Forth System + 3 using the Sourcecode 6502F82.FB. + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ Target compiler loadscr 09sep86we + 1 \ Idea and first Implementation by ks/bp + 2 \ Implemented on 6502 by ks/bp + 3 \ ultraFORTH83-Version by bp/we + 4 \ Atari 520 ST - Version by we + 5 Onlyforth Assembler nonrelocate + 6 07 Constant imagepage \ Virtual memory bank + 7 Vocabulary Ttools + 8 Vocabulary Defining + 9 : .stat .blk .s ; ' .stat Is .status +10 \ : 65( [compile] ( ; immediate +11 : 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| +12 1 $14 +thru \ Target compiler +13 $15 $17 +thru \ Target Tools +14 $18 $1A +thru \ Redefinitions +15 save $1B $24 +thru \ Predefinitions +Screen 2 not modified + 0 \ Target header pointers bp05mar86we + 1 + 2 Variable tdp : there tdp @ ; + 3 Variable displace + 4 Variable ?thead 0 ?thead ! + 5 Variable tlast 0 tlast ! + 6 Variable glast' 0 glast' ! + 7 Variable tdoes> + 8 Variable >in: + 9 Variable tvoc 0 tvoc ! +10 Variable tvoc-link 0 tvoc-link ! +11 Variable tnext-link 0 tnext-link ! +12 +13 : c+! ( 8b addr -- ) dup c@ rot + swap c! ; +14 +15 +Screen 3 not modified + 0 \ Image and byteorder 15sep86we + 1 + 2 : >image ( addr1 - addr2 ) displace @ - ; + 3 + 4 : >heap ( from quan - ) + 5 heap over - 1 and + \ 68000-align + 6 dup hallot heap swap cmove ; + 7 \\ + 8 : >ascii 2drop ; ' noop Alias C64>ascii + 9 +10 Code Lc@ ( laddr -- 8b ) +11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move +12 .w D0 SP -) move Next end-code +13 Code Lc! ( 8b addr -- ) +14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move +15 Next end-code +Screen 4 not modified + 0 \ Ghost-creating 05mar86we + 1 + 2 0 | Constant 0 | Constant + 3 + 4 | : Make.ghost ( - cfa.ghost ) + 5 here dup 1 and allot here + 6 state @ IF context @ ELSE current THEN @ + 7 dup @ , name + 8 dup c@ 1 $1F uwithin not abort" inval.Gname" + 9 dup c@ 1+ over c! +10 c@ dup 1+ allot 1 and 0= IF bl c, THEN +11 here 2 pick - -rot +12 , 0 , 0 , +13 swap here over - >heap +14 heap swap ! swap dp ! +15 heap + ; +Screen 5 not modified + 0 \ ghost words 05mar86we + 1 + 2 : gfind ( string - cfa tf / string ff ) + 3 dup count + 1+ bl swap c! + 4 dup >r 1 over c+! find -1 r> c+! ; + 5 + 6 : ghost ( - cfa ) + 7 >in @ name gfind IF nip exit THEN + 8 drop >in ! Make.ghost ; + 9 +10 : Word, ghost execute ; +11 +12 : gdoes> ( cfa.ghost - cfa.does ) +13 4+ dup @ IF @ exit THEN +14 here dup , 0 , 4 >heap +15 dp ! heap dup rot ! ; +Screen 6 not modified + 0 \ ghost utilities 04dec85we + 1 + 2 : g' name gfind 0= abort" ?" ; + 3 + 4 : '. + 5 g' dup @ case? + 6 IF ." forw" ELSE - abort" ??" ." res" THEN + 7 2+ dup @ 5 u.r + 8 2+ @ ?dup + 9 IF dup @ case? +10 IF ." fdef" ELSE - abort" ??" ." rdef" THEN +11 2+ @ 5 u.r THEN ; +12 +13 ' ' Alias h' +14 +15 +Screen 7 not modified + 0 \ .unresolved 05mar86we + 1 + 2 | : forward? ( cfa - cfa / exit&true ) + 3 dup @ = over 2+ @ and IF drop true rdrop exit THEN ; + 4 + 5 | : unresolved? ( addr - f ) + 6 2+ dup c@ $1F and over + c@ BL = + 7 IF name> forward? 4+ @ dup IF forward? THEN + 8 THEN drop false ; + 9 +10 | : unresolved-words +11 BEGIN @ ?dup WHILE dup unresolved? +12 IF dup 2+ .name ?cr THEN REPEAT ; +13 +14 : .unresolved voc-link @ +15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; +Screen 8 not modified + 0 \ Extending Vocabularys for Target-Compilation 05mar86we + 1 + 2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + 3 + 4 Vocabulary Transient 0 tvoc ! + 5 + 6 Only definitions Forth also + 7 + 8 : T Transient ; immediate + 9 : H Forth ; immediate +10 +11 definitions +12 +13 +14 +15 +Screen 9 not modified + 0 \ Transient primitives 05mar86we + 1 + 2 Code byte> ( 8bh 8bl -- 16b ) + 3 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move + 4 .w D0 SP ) move Next end-code + 5 Code >byte ( 16b -- 8bl 8bh ) + 6 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr + 7 D0 SP -) move D1 SP -) move Next end-code + 8 + 9 Transient definitions +10 : c@ H >image imagepage lc@ ; +11 : c! H >image imagepage lc! ; +12 : @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; +13 : ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; +14 : cmove ( from.mem to.target quan -) +15 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +Screen 10 not modified + 0 \ Transient primitives bp05mar86we + 1 + 2 : here there ; + 3 : allot Tdp +! ; + 4 : c, T here c! 1 allot H ; + 5 : , T here ! 2 allot H ; + 6 + 7 : ," Ascii " parse dup T c, + 8 under there swap cmove + 9 .( dup 1 and 0= IF 1+ THEN ) allot H ; +10 +11 : fill ( addr quan 8b -) +12 -rot bounds ?DO dup I T c! H LOOP drop ; +13 : erase 0 T fill ; +14 : blank bl T fill ; +15 : here! H Tdp ! ; +Screen 11 not modified + 0 \ Resolving 08dec85we + 1 Forth definitions + 2 : resolve ( cfa.ghost cfa.target -) + 3 over dup @ = + 4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN + 5 >r >r 2+ @ ?dup + 6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! + 7 H ?dup 0= UNTIL + 8 THEN r> r> over ! 2+ ! ; + 9 +10 : resdoes> ( cfa.ghost cfa.target -) +11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +13 ' >body ! +14 ] Does> [ here 4- 0 ] @ T , H ; +15 ' >body ! +Screen 12 not modified + 0 \ move-threads 68000-align cas 26jan06 + 1 + 2 : move-threads Tvoc @ Tvoc-link @ + 3 BEGIN over ?dup + 4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + 5 error" some undef. Target-Vocs left" drop ; + 6 + 7 | : tlatest ( - addr) current @ 6 + ; + 8 + 9 \\ +10 not used for the 6502 architecture +11 +12 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; +13 +14 +15 +Screen 13 not modified + 0 \ save-target 09sep86we + 1 + 2 Dos definitions + 3 + 4 Code (filewrite ( buff len handle -- n) + 5 SP )+ D0 move .l D2 clr .w SP )+ D2 move + 6 .l 0 imagepage # D1 move .w SP )+ D1 move + 7 .l D1 A7 -) move \ buffer adress + 8 .l D2 A7 -) move \ buffer length + 9 .w D0 A7 -) move \ handle +10 $40 # A7 -) move \ call WRITE +11 1 trap $0C # A7 adda +12 .w D0 SP -) move Next end-code Forth definitions +13 +14 +15 +Screen 14 not modified + 0 \ save Target-System 09sep86we + 1 + 2 : save-target [ Dos ] + 3 bl word count dup 0= abort" missing filename" + 4 over + off (createfile dup >r 0< abort" no device " + 5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header + 6 0 there r@ (filewrite there - abort" write error" + 7 r> (closefile 0< abort" close error" ; + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 15 not modified + 0 \\ 6502-ALIGN ?HEAD \ 08SEP84BP) + 1 + 2 | : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ; + 3 + 4 + 5 | : 6502-align/2 ( lfa -- lfa ) + 6 there 0FF and 0FF = + 7 IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid + 8 1 tlast +! 1 tallot THEN ; + 9 +10 +11 +12 +13 +14 +15 +Screen 16 not modified + 0 \\ WARNING CREATE 30DEC84BP) + 1 + 2 VARIABLE WARNING 0 WARNING ! + 3 + 4 | : EXISTS? + 5 WARNING @ ?EXIT + 6 LAST @ CURRENT @ (FIND NIP + 7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; + 8 + 9 : CREATE HERE BLK @ , CURRENT @ @ , +10 NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" +11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ +12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE +13 HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! +14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , +15 ;CODE DOCREATE JMP END-CODE +Screen 17 not modified + 0 \ compiling names into targ. 05mar86we + 1 + 2 : (theader + 3 ?thead @ IF 1 ?thead +! + 4 there $FF and $FF = IF 1 T allot H THEN exit THEN + 5 >in @ name swap >in ! + 6 dup c@ 1 $20 uwithin not abort" inval. Tname" + 7 dup c@ 3 + there + $FF and $FF = + 8 there 2+ $FF and $FF = or IF 1 T allot H THEN + 9 blk @ T , H there tlatest dup @ T , H ! there dup tlast ! +10 over c@ 1+ .( even ) dup T allot cmove H ; +11 +12 : Theader tlast off +13 (theader Ghost dup glast' ! +14 there resolve ; +15 +Screen 18 not modified + 0 \ prebuild defining words bp27jun85we + 1 + 2 | : executable? ( adr - adr f ) dup ; + 3 | : tpfa, there , ; + 4 | : (prebuild ( cfa.adr -- ) + 5 >in @ Create >in ! here 2- ! ; + 6 + 7 : prebuild ( adr 0.from.: - 0 ) + 8 0 ?pairs executable? dup >r + 9 IF [compile] Literal compile (prebuild ELSE drop THEN +10 compile Theader Ghost gdoes> , +11 r> IF compile tpfa, THEN 0 ; immediate restrict +12 +13 +14 +15 +Screen 19 not modified + 0 \ code portion of def.words bp11sep86we + 1 + 2 : dummy 0 ; + 3 + 4 : DO> ( - adr.of.jmp.dodoes> 0 ) + 5 [compile] Does> here 4- compile @ 0 ] ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 20 not modified + 0 \ the 68000 Assembler 11sep86we + 1 + 2 Forth definitions + 3 | Create relocate ] T c, , c@ here allot ! c! H [ + 4 + 5 Transient definitions + 6 + 7 : Assembler H [ Tassembler ] relocate >codes ! Tassembler ; + 8 : >label ( 16b -) H >in @ name gfind rot >in ! + 9 IF over resolve dup THEN drop Constant ; +10 : Label T .( here 1 and allot ) here >label Assembler H ; +11 : Code H Theader there 2+ T , Assembler H ; +12 +13 +14 +15 +Screen 21 not modified + 0 \ immed. restr. ' \ compile bp05mar86we + 1 + 2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; + 3 : >mark ( - addr ) H there T 0 , H ; + 4 : >resolve ( addr - ) H there over - swap T ! H ; + 5 : - cfa ) H g' dup @ - abort" ?" 2+ @ ; +12 : | H ?thead @ ?exit ?thead on ; +13 : compile H Ghost , ; immediate restrict +14 +15 +Screen 22 not modified + 0 \ Target tools ks05mar86we + 1 + 2 Onlyforth Ttools also definitions + 3 + 4 | : ttype ( adr n -) bounds ?DO I T c@ H dup + 5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ; + 6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + 7 ELSE ." ??? " THEN space ?cr ; + 8 | : nfa? ( cfa lfa - nfa / cfa ff) + 9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = +10 IF 2+ nip exit THEN +11 T @ H REPEAT ; +12 : >name ( cfa - nfa / ff) +13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup +14 IF nip exit THEN +15 swap REPEAT nip ; +Screen 23 not modified + 0 \ Ttools for decompiling ks05mar86we + 1 + 2 | : ?: dup 4 u.r ." :" ; + 3 | : @? dup T @ H 6 u.r ; + 4 | : c? dup T c@ H 3 .r ; + 5 + 6 : s ( addr - addr+ ) ?: space c? 3 spaces + 7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + 8 + 9 : n ( addr - addr+2 ) ?: @? 2 spaces +10 dup T @ H [ Ttools ] >name .name H 2+ ; +11 +12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP +13 2 spaces -rot ttype ; +14 +15 +Screen 24 not modified + 0 \ Tools for decompiling bp05mar86we + 1 + 2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; + 3 + 4 : c ( addr -- addr+1 ) 1 d ; + 5 + 6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; + 7 + 8 : dump ( adr n -) bounds ?DO cr I $10 d drop + 9 stop? IF LEAVE THEN $10 +LOOP ; +10 +11 : view T ' H [ Ttools ] >name ?dup +12 IF 4- T @ H l THEN ; +13 +14 +15 +Screen 25 not modified + 0 \ reinterpretation def.-words 05mar86we + 1 + 2 Onlyforth + 3 + 4 : redefinition + 5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push + 6 state push context push >in: @ >in ! + 7 name [ ' Transient 2+ ] Literal (find nip 0= + 8 IF cr ." Redefinition: " here .name + 9 >in: @ >in ! : Defining interpret THEN +10 THEN 0 tdoes> ! ; +11 +12 +13 +14 +15 +Screen 26 not modified + 0 \ Create..does> structure bp05mar86we + 1 + 2 | : (;tcode + 3 Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; + 4 | : changecfa compile lit tdoes> @ , compile (;tcode ; + 5 + 6 Defining definitions + 7 + 8 : ;code 0 ?pairs changecfa reveal rdrop ; + 9 immediate restrict +10 +11 Defining ' ;code Alias does> immediate restrict +12 +13 : ; [compile] ; rdrop ; immediate restrict +14 +15 +Screen 27 not modified + 0 \ redefinition conditionals bp27jun85we + 1 + 2 ' DO Alias DO immediate restrict + 3 ' ?DO Alias ?DO immediate restrict + 4 ' LOOP Alias LOOP immediate restrict + 5 ' IF Alias IF immediate restrict + 6 ' THEN Alias THEN immediate restrict + 7 ' ELSE Alias ELSE immediate restrict + 8 ' BEGIN Alias BEGIN immediate restrict + 9 ' UNTIL Alias UNTIL immediate restrict +10 ' WHILE Alias WHILE immediate restrict +11 ' REPEAT Alias REPEAT immediate restrict +12 +13 +14 +15 +Screen 28 not modified + 0 \ clear Liter. Ascii ['] ." bp05mar86we + 1 + 2 Onlyforth Transient definitions + 3 + 4 : clear true abort" There are ghosts" ; + 5 : Literal ( n -) T compile lit , H ; immediate + 6 : Ascii H bl word 1+ c@ state @ + 7 IF T [compile] Literal H THEN ; immediate + 8 : ['] T ' [compile] Literal H ; immediate restrict + 9 : " T compile (" ," H ; immediate restrict +10 : ." T compile (." ," H ; immediate restrict +11 +12 +13 +14 +15 +Screen 29 not modified + 0 \ Target compilation ] [ bp05mar86we + 1 + 2 Forth definitions + 3 + 4 : tcompile + 5 ?stack >in @ name find ?dup + 6 IF 0> IF nip execute >interpret THEN + 7 drop dup >in ! name + 8 THEN gfind IF nip execute >interpret THEN + 9 nullstring? IF drop exit THEN +10 number? ?dup IF 0> IF swap T [compile] Literal THEN +11 [compile] Literal H drop >interpret THEN +12 drop >in ! Word, >interpret ; +13 +14 Transient definitions +15 : ] H state on ['] tcompile is >interpret ; +Screen 30 not modified + 0 \ Target conditionals bp05mar86we + 1 + 2 : IF T compile ?branch >mark H 1 ; immediate restrict + 3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict + 4 : ELSE T 1 ?pairs compile branch >mark swap >resolve + 5 H -1 ; immediate restrict + 6 : BEGIN T mark -2 H 2swap ; + 8 immediate restrict + 9 | : (repeat T 2 ?pairs resolve H REPEAT ; +11 : UNTIL T compile ?branch (repeat H ; immediate restrict +12 : REPEAT T compile branch (repeat H ; immediate restrict +13 +14 +15 +Screen 31 not modified + 0 \ Target conditionals bp27jun85we + 1 + 2 : DO T compile (do >mark H 3 ; immediate restrict + 3 : ?DO T compile (?do >mark H 3 ; immediate restrict + 4 : LOOP T 3 ?pairs compile (loop compile endloop + 5 >resolve H ; immediate restrict + 6 : +LOOP T 3 ?pairs compile (+loop compile endloop + 7 >resolve H ; immediate restrict + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 32 not modified + 0 \ predefinitions bp05mar86we + 1 + 2 : abort" T compile (abort" ," H ; immediate + 3 : error" T compile (err" ," H ; immediate + 4 + 5 Forth definitions + 6 + 7 Variable torigin + 8 Variable tudp 0 Tudp ! + 9 +10 : >user T c@ H torigin @ + ; +11 +12 +13 +14 +15 +Screen 33 not modified + 0 \ Datatypes bp05mar86we + 1 + 2 Transient definitions + 3 : origin! H torigin ! ; + 4 : user' ( -- n ) T ' >body c@ H ; + 5 : uallot ( n -- ) H tudp @ swap tudp +! ; + 6 + 7 DO> >user ; + 8 : User prebuild User 2 T uallot c, ; + 9 +10 DO> ; +11 : Create prebuild Create ; +12 +13 DO> T @ H ; +14 : Constant prebuild Constant T , ; +15 : Variable Create 2 T allot ; +Screen 34 not modified + 0 \ Datatypes bp05mar86we + 1 + 2 dummy + 3 : Vocabulary + 4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + 5 here H tvoc-link @ T , H tvoc-link ! ; + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 35 not modified + 0 \ target defining words bp08sep86we + 1 + 2 Do> ; + 3 : Defer prebuild Defer 2 T allot ; + 4 : Is T ' H >body state @ IF T compile (is , H + 5 ELSE T ! H THEN ; immediate + 6 | : dodoes> T compile (;code H Glast' @ + 7 there resdoes> there tdoes> ! ; + 8 + 9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [ +10 redefinition ; immediate restrict +11 +12 : does> T dodoes> $04C C, +13 compile (dodoes> H ; immediate restrict +14 +15 +Screen 36 not modified + 0 \ : Alias ; bp25mar86we + 1 + 2 : Create: T Create H current @ context ! T ] H 0 ; + 3 + 4 dummy + 5 : : H tdoes> off >in @ >in: ! T prebuild : + 6 H current @ context ! T ] H 0 ; + 7 + 8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve + 9 tlast @ T c@ H $20 or tlast @ T c! , H ; +10 +11 : ; T 0 ?pairs compile exit .( unnest gegen exit getauscht) +12 [compile] [ H redefinition ; immediate restrict +13 +14 +15 +Screen 37 not modified + 0 \ predefinitions bp11sep86we + 1 + 2 : compile T compile compile H ; immediate restrict + 3 : Host H Onlyforth Ttools also ; + 4 : Compiler T Host H Transient also definitions ; + 5 : [compile] H Word, ; immediate restrict + 6 : Onlypatch H there 3 - 0 tdoes> ! 0 ; + 7 + 8 Onlyforth + 9 : Target Onlyforth Transient also definitions ; +10 +11 Transient definitions +12 Ghost c, drop +13 +14 +15 +Screen 38 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 39 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/systemio.fb.src b/sources/Apple1/systemio.fb.src new file mode 100644 index 0000000..f8fd8b2 --- /dev/null +++ b/sources/Apple1/systemio.fb.src @@ -0,0 +1,187 @@ +Screen 0 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ loadscreen for system IO for Apple1 cas2013apr05 + 1 + 2 + 3 1 9 +thru + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 2 not modified + 0 \ 65KEY? GETKEY cas2013apr05 + 1 | $D010 Constant KBDDTA + 2 | $D011 Constant KBDCTL + 3 + 4 | CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]? + 5 push0a jmp end-code + 6 + 7 | CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND + 8 push0a jmp end-code + 9 +10 | CODE CURON ( --) NEXT JMP END-CODE +11 +12 | CODE CUROFF ( --) NEXT JMP END-CODE +13 +14 : 65KEY ( -- 8B) +15 CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ; +Screen 3 not modified + 0 \ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05 + 1 08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC + 2 + 3 : 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2) + 4 #BS CASE? IF DUP IF DEL 1- THEN EXIT THEN + 5 #CR CASE? IF DUP SPAN ! EXIT THEN + 6 >R 2DUP + R@ SWAP C! R> EMIT 1+ ; + 7 + 8 : 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0 + 9 BEGIN DUP SPAN @ U< +10 WHILE KEY DECODE +11 REPEAT 2DROP SPACE ; +12 +13 INPUT: KEYBOARD [ HERE INPUT ! ] +14 65KEY 65KEY? 65DECODE 65EXPECT [ +15 +Screen 4 not modified + 0 \ senden? (emit 65emit 25JAN85RE) cas2013apr05 + 1 + 2 | $D012 Constant DSP + 3 + 4 | Code send? ( -- flg ) + 5 DSP lda $80 # AND $80 # EOR push0a jmp end-code + 6 + 7 Code (emit ( 8b -- ) + 8 SP X) LDA DSP sta (drop jmp end-code + 9 +10 +11 +12 +13 +14 +15 +Screen 5 not modified + 0 \ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05 + 1 + 2 | Variable out 0 out ! | &40 Constant c/row + 3 + 4 : 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ; + 5 + 6 : 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ; + 7 + 8 : 65DEL ASCII _ 65emit -1 out +! ; + 9 +10 : 65PAGE &24 0 DO CR LOOP out off ; +11 +12 : 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ; +13 +14 : 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ; +15 +Screen 6 not modified + 0 \ er14dez88 + 1 + 2 : 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ; + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 7 not modified + 0 \ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88 + 1 + 2 OUTPUT: DISPLAY [ HERE OUTPUT ! ] + 3 65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [ + 4 + 5 + 6 | : (bye ; + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 8 not modified + 0 \ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88 + 1 + 2 $400 CONSTANT B/BLK + 3 + 4 $0AA CONSTANT BLK/DRV + 5 + 6 | VARIABLE (DRV 0 (DRV ! + 7 + 8 | : DISK ( -- DEV.NO ) (DRV @ 8 + ; + 9 +10 : DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ; +11 +12 +13 +14 +15 +Screen 9 not modified + 0 \ er14dez88 + 1 : >DRIVE ( BLOCK DRV# -- BLOCK' ) + 2 BLK/DRV * + OFFSET @ - ; + 3 : DRV? ( BLOCK -- DRV# ) + 4 OFFSET @ + BLK/DRV / ; + 5 + 6 : DRVINIT NOOP ; + 7 .( fuer reads. u. writes. ist errorhandler erforderlich ) + 8 | : readserial ( adr blk -- ) + 9 &27 emit .( rb ) space base push decimal . cr +10 $400 bounds DO key I c! LOOP ; +11 +12 | : writeserial ( adr blk -- ) +13 &27 emit .( wb ) space base push decimal . cr +14 $400 bounds DO I c@ emit LOOP ; +15 +Screen 10 not modified + 0 \ (r/w er14decas + 1 + 2 : (R/W ( ADR BLK FILE R/WF -- FLAG) + 3 swap abort" no file" + 4 IF readserial ELSE writeserial THEN false ; + 5 + 6 ' (R/W IS R/W + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/tasker.fb.src b/sources/Apple1/tasker.fb.src new file mode 100644 index 0000000..1bf38bb --- /dev/null +++ b/sources/Apple1/tasker.fb.src @@ -0,0 +1,170 @@ +Screen 0 not modified + 0 \ Multitasking Extension to volksFORTH cas 26jan06 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ Tasker Loadscreen + 1 + 2 \NEEDS CODE abort( Assembler needed ) + 3 hex + 4 1 5 +thru \ load Tasker + 5 7 load \ Task-Demo + 6 decimal + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 2 not modified + 0 \ MULTITASKER BP 13.9.84 ) + 1 + 2 CODE STOP + 3 SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA + 4 SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA + 5 6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA + 6 1 # LDY TYA CLC UP ADC W STA + 7 TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE + 8 + 9 | CREATE TASKPAUSE ASSEMBLER +10 2C # LDA UP X) STA ' STOP @ JMP END-CODE +11 +12 : SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ; +13 +14 : MULTITASK TASKPAUSE ['] PAUSE ! ; +15 +Screen 3 not modified + 0 \ PASS ACTIVATE KS 8 MAY 84 ) + 1 + 2 : PASS ( N0 .. NR-1 TADR R -- ) + 3 BEGIN [ ROT ( TRICK ! ) ] + 4 SWAP 02C OVER C! \ AWAKE TASK + 5 R> -ROT \ IP R ADDR + 6 8 + >R \ S0 OF TASK + 7 R@ 2+ @ SWAP \ IP R0 R + 8 2+ 2* \ BYTES ON TASKSTACK + 9 \ INCL. R0 & IP +10 R@ @ OVER - \ NEW SP +11 DUP R> 2- ! \ INTO SSAVE +12 SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT +13 +14 +15 +Screen 4 not modified + 0 \ + 1 + 2 : ACTIVATE ( TADR --) + 3 0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT + 4 + 5 : SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE + 6 + 7 : WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE + 8 + 9 | : TASKERROR ( STRING -) +10 STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE +11 MULTITASK STOP ; +12 +13 +14 +15 +Screen 5 not modified + 0 \ BUILDING A TASK BP 13.9.84 ) + 1 + 2 : TASK ( RLEN SLEN -- ) + 3 ALLOT \ STACK + 4 HERE 00FF AND 0FE = + 5 IF 1 ALLOT THEN \ 6502-ALIGN + 6 UP@ HERE 100 CMOVE \ INIT USER AREA + 7 HERE 04C C, \ JMP OPCODE TO SLEEP TASK + 8 UP@ 1+ @ , + 9 DUP UP@ 1+ ! \ LINK TASK +10 3 ALLOT \ ALLOT JSR WAKE +11 DUP 6 - DUP , , \ SSAVE AND S0 +12 2DUP + , \ HERE + RLEN = R0 +13 UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER +14 [ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ; +15 +Screen 6 not modified + 0 \ MORE TASKS KS/BP 26APR85RE) + 1 + 2 : RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ; + 3 + 4 | : STATESMART STATE @ IF [COMPILE] LITERAL THEN ; + 5 + 6 : 'S ( TADR - ADR.OF.TASKUSERVAR) + 7 ' >BODY C@ + STATESMART ; IMMEDIATE + 8 + 9 \ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY +10 +11 : TASKS ( -) ." MAIN " CR UP@ DUP 1+ @ +12 BEGIN 2DUP - WHILE +13 DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME +14 DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ; +15 +Screen 7 not modified + 0 \ TASKDEMO 27APR85RE) + 1 : TASKMARK ; + 2 + 3 VARIABLE COUNTER COUNTER OFF + 4 + 5 100 100 TASK BACKGROUND + 6 + 7 : >COUNT ( N -) BACKGROUND 1 PASS COUNTER ! + 8 BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP + 9 WHILE PAUSE 0 <# #S #> type REPEAT stop ; +10 +11 : WAIT BACKGROUND SLEEP ; +12 +13 : GO BACKGROUND WAKE ; +14 +15 +Screen 8 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 9 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 diff --git a/sources/Apple1/tools.fb.src b/sources/Apple1/tools.fb.src new file mode 100644 index 0000000..416ffcb --- /dev/null +++ b/sources/Apple1/tools.fb.src @@ -0,0 +1,255 @@ +Screen 0 not modified + 0 \ Development Tools cas 26jan06 + 1 + 2 Interactive Tracer + 3 + 4 One-Step Debugger + 5 + 6 Traps + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 1 not modified + 0 \ TOOLS LOADSCREEN 22MAR85RE) + 1 + 2 ONLYFORTH + 3 + 4 \NEEDS CODE abort( Assembler is needed ) + 5 + 6 VOCABULARY TOOLS + 7 + 8 TOOLS ALSO DEFINITIONS + 9 hex +10 1 &11 +THRU +11 decimal +12 ONLYFORTH +13 +14 +15 +Screen 2 not modified + 0 \ HANDLE STEPS BP 10 02 85) + 1 + 2 ASSEMBLER ALSO DEFINITIONS + 3 + 4 ONLY FORTH ALSO TOOLS ALSO DEFINITIONS + 5 | VARIABLE (W | VARIABLE RPT + 6 + 7 | CODE STEP + 8 RPT DEC RP X) LDA IP STA + 9 RP )Y LDA IP 1+ STA RP 2INC +10 (W LDA W STA (W 1+ LDA W 1+ STA +11 W 1- JMP END-CODE +12 +13 | CREATE NEXTSTEP ] STEP [ +14 +15 +Screen 3 not modified + 0 \ THROW STATUS ON R-STACK B 23JUL85RE) + 1 + 2 | CREATE NPULL 0 ] + 3 RP@ COUNT 2DUP + RP! R> SWAP CMOVE ; + 4 + 5 : NPUSH ( ADDR LEN -) + 6 R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE + 7 NPULL >R >R ; + 8 + 9 | : ONELINE .STATUS SPACE QUERY INTERPRET +10 -82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ; +11 +12 +13 +14 +15 +Screen 4 not modified + 0 \ TRAP AND DISPLAY KS 26MAR85RE) + 1 LABEL TNEXT + 2 IP 2INC RP LDA RPT CMP 0<> ?[ + 3 [[ W 1- JMP SWAP ]? + 4 RP 1+ LDA RPT 1+ CMP 0= ?] + 5 LABEL DOTRACE + 6 RPT INC ( DISABLE TRACER ) + 7 W LDA (W STA W 1+ LDA (W 1+ STA + 8 ;C: R@ NEXTSTEP >R + 9 INPUT PUSH KEYBOARD +10 OUTPUT PUSH DISPLAY +11 CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES +12 >NAME .NAME 1C COL - 0 MAX SPACES .S +13 STATE PUSH BLK PUSH >IN PUSH +14 [ ' 'QUIT >BODY ] LITERAL PUSH +15 [ ' >INTERPRET >BODY ] LITERAL PUSH +Screen 5 not modified + 0 \ + 1 #TIB PUSH TIB #TIB @ NPUSH R0 PUSH + 2 RP@ R0 ! 082 ALLOT + 3 ['] ONELINE IS 'QUIT QUIT ; -2 ALLOT + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 6 not modified + 0 \ TRACER COMMANDS BP 23JUL85RE) + 1 + 2 | CODE (TRACE TNEXT 0 100 M/MOD + 3 # LDA NEXT 0C + STA + 4 # LDA NEXT 0B + STA + 5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + 6 + 7 : TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ; + 8 + 9 : BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT +10 +11 : TRACEL: CREATE , DOES> @ RPT +! ; +12 +13 -6 TRACEL: +DO 6 TRACEL: -DO +14 -2 TRACEL: +R 2 TRACEL: -R +15 -6 TRACEL: +PUSH 6 TRACEL: -PUSH +Screen 7 not modified + 0 \ WATCH TRAP BP 10 02 85 ) + 1 + 2 | VARIABLE WATCHPT 2 ALLOT + 3 + 4 LABEL WNEXT IP 2INC + 5 WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA + 6 N X) LDA WATCHPT 2+ CMP 0<> ?[ + 7 [[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA + 8 ( SET TO TNEXT) TNEXT 0 100 M/MOD + 9 # LDA NEXT 0C + STA # LDA NEXT 0B + STA +10 DOTRACE JMP SWAP ]? +11 N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE +12 +13 +14 +15 +Screen 8 not modified + 0 \ WATCH COMMANDS BP 10 02 85 ) + 1 + 2 | CODE (WATCH WNEXT 0 100 M/MOD + 3 # LDA NEXT 0C + STA + 4 # LDA NEXT 0B + STA + 5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + 6 + 7 : WATCH' ( ADR -- ) + 8 DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ; + 9 +10 : CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ; +11 +12 ( SYNTAX : WATCH' ) +13 +14 +15 +Screen 9 not modified + 0 \ TOOLS FOR DECOMPILING, KS 4 APR 83 ) + 1 ( INTERACTIVE USE ) + 2 | : ?: DUP 4 U.R ." :" ; + 3 | : @? DUP @ 6 U.R ; + 4 | : C? DUP C@ 3 .R ; + 5 | : BL 024 COL - 0 MAX SPACES ; + 6 + 7 : S ( ADR - ADR+) ( PRINT LITERAL STRING) + 8 ?: SPACE C? 4 SPACES DUP COUNT TYPE + 9 DUP C@ + 1+ BL ; ( COUNT + RE) +10 +11 : N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA) +12 ?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ; +13 +14 : L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ; +15 +Screen 10 not modified + 0 \ TOOLS FOR DECOMPILING, INTERACTIVE ) + 1 + 2 : D ( ADR N - ADR+N) ( DUMP N BYTES) + 3 2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP + 4 4 SPACES -ROT TYPE BL ; + 5 + 6 : C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ; + 7 + 8 : B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION ) + 9 ?: @? DUP @ OVER + 6 U.R 2+ BL ; +10 +11 ( USED FOR : ) +12 ( NAME STRING LITERAL DUMP CLIT BRANCH ) +13 ( - - - - - - ) +14 +15 +Screen 11 not modified + 0 \ DEBUGGING UTILITIES BP 19 02 85 ) + 1 + 2 : UNRAVEL \ UNRAVEL PERFORM (ABORT" + 3 RDROP RDROP RDROP CR ." TRACE DUMP IS " CR + 4 + 5 BEGIN RP@ R0 @ - + 6 WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR + 7 REPEAT (ERROR ; + 8 + 9 ' UNRAVEL ERRORHANDLER ! +10 +11 +12 +13 +14 +15 +Screen 12 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 13 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +Screen 14 not modified + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15