diff --git a/.gitignore b/.gitignore index 64a5d91..a73100c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ *.log /.DS_Store *~ +/tools/blkpack +/tools/blkunpack diff --git a/6502/C64/Makefile b/6502/C64/Makefile index 67fb8e2..a795e13 100644 --- a/6502/C64/Makefile +++ b/6502/C64/Makefile @@ -175,31 +175,31 @@ emulator/sdcard.img: emulator/sdcard.sfdisk test-v4thblk-c64.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double block report-blk) - cat $? > $@ + cat $^ > $@ test-v4th-c64.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4thblk-c16+.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double block report-blk) - cat $? > $@ + cat $^ > $@ test-v4th-c16+.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4thblk-c16-.golden: $(patsubst %, tests/golden/%.golden, \ prelim core) - cat $? > $@ + cat $^ > $@ test-v4th-c16-.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4th-x16.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ # Rules for building Forth binaries on top of the plain vanilla # c64-volksforth83. diff --git a/6502/C64/src/vf-cbm-file.fth b/6502/C64/src/vf-cbm-file.fth index 210db63..3a4ab7b 100644 --- a/6502/C64/src/vf-cbm-file.fth +++ b/6502/C64/src/vf-cbm-file.fth @@ -14,7 +14,10 @@ create fload-dev 8 , create fload-2nd f , -| : eol? ( c -- f ) +| : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: not eol but eof; store c, return line and flag eof dup 0= swap #cr = or IF 0 exit THEN i/o-status? IF 1 exit THEN -1 ; @@ -25,7 +28,7 @@ fload-dev @ fload-2nd @ busin i/o-status?abort tib /tib bounds - DO bus@ i/o-status?abort dup eol? under + DO bus@ i/o-status?abort dup eolf? under IF I c! ELSE drop THEN dup 0< IF drop ELSE I + tib - #tib ! UNLOOP @@ -33,7 +36,7 @@ LOOP /tib #tib ! ." warning: line exceeds max " /tib . cr ." extra chars ignored" cr - BEGIN bus@ eol? 1+ UNTIL + BEGIN bus@ eolf? 1+ UNTIL i/o-status? busoff ; diff --git a/6502/C64/tests/logtofile.fth b/6502/C64/tests/logtofile.fth index 68b5149..fd66bbc 100644 --- a/6502/C64/tests/logtofile.fth +++ b/6502/C64/tests/logtofile.fth @@ -24,4 +24,4 @@ Output: alsologtofile alsologtofile ; : logclose - log-dev-2nd@ busclose display ; + display log-dev-2nd@ busclose ; diff --git a/6502/py65/6502f83.fb b/6502/py65/6502f83.fb index fa9a30e..4795ada 100644 --- a/6502/py65/6502f83.fb +++ b/6502/py65/6502f83.fb @@ -1 +1 @@ - ende 123 \ volksFORTH Loadscreen for py65 target cas 15juli2020forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $1000 CONSTANT BASEADDR \ change target base address here BASEADDR DISPLACE ! TARGET DEFINITIONS BASEADDR HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED \ if this prints unresolved \ definitions, check code CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID cas 26jan06 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ Coldstartvalues and user variables cas 15juli2020\ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VOLKSFORTH-83 3.8 py65 15july2020 CS" \ ZERO PAGE VARIABLES & NEXT cas 26jan06\ adjust this to match your architecture 20 DUP >LABEL RP 2+ DUP >LABEL UP 2+ DUP >LABEL PUTA 1+ DUP >LABEL SP 2+ DUP >LABEL NEXT DUP 5 + >LABEL IP 13 + >LABEL W W 8 + >LABEL N \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) LABEL BOOTNEXT -1 STA \ -1 IS DUMMY SP IP )Y LDA W 1+ STA -1 LDA W STA \ -1 IS DUMMY IP CLC IP LDA 2 # ADC IP STA CS NOT ?[ LABEL WJMP -1 ) JMP ]? IP 1+ INC WJMP BCS END-CODE \ Bootnext and Endtrace cas 26jan06HERE BOOTNEXT - >LABEL BOOTNEXTLEN CODE END-TRACE ( PATCH NEXT FOR TRACE ) 0A5 # LDA NEXT 0A + STA IP # LDA NEXT 0B + STA 069 # LDA NEXT 0C + STA 02 # LDA NEXT 0D + STA NEXT JMP END-CODE \ ;C: NOOP cas 26jan06 CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ manual forward reference for JMP command COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES cas 26jan06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 $5000 S0 ! USER R0 $5500 R0 ! USER DP USER OFFSET 0 OFFSET ! USER BASE &10 BASE ! USER OUTPUT USER INPUT USER ERRORHANDLER \ POINTER FOR ABORT" -CODE USER VOC-LINK USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ MANIPULATE SYSTEM POINTERS 29JAN85BP) CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA N # LDX LABEL XPUSH SP 2DEC 1 ,X LDA SP )Y STA 0 ,X LDA 0 # LDX PUTA JMP END-CODE CODE SP! ( ADDR --) SP X) LDA TAX SP )Y LDA SP 1+ STA SP STX 0 # LDX NEXT JMP END-CODE \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06CODE UP@ ( -- ADDR) UP # LDX XPUSH JMP END-CODE CODE UP! ( ADDR --) UP # LDX LABEL XPULL SP )Y LDA 1 ,X STA DEY SP )Y LDA 0 ,X STA LABEL (XYDROP 0 # LDX 1 # LDY LABEL (DROP SP 2INC NEXT JMP END-CODE RESTRICT \ MANIPULATE RETURNSTACK 16FEB85BP/KS) CODE RP@ ( -- ADDR ) RP # LDX XPUSH JMP END-CODE CODE RP! ( ADDR -- ) RP # LDX XPULL JMP END-CODE RESTRICT CODE >R ( 16B -- ) RP 2DEC SP X) LDA RP X) STA SP )Y LDA RP )Y STA (DROP JMP END-CODE RESTRICT \ R> (RDROP (NRDROP cas 26jan06CODE R> ( -- 16B) SP 2DEC RP X) LDA SP X) STA RP )Y LDA SP )Y STA LABEL (RDROP 2 # LDA LABEL (NRDROP CLC RP ADC RP STA CS ?[ RP 1+ INC ]? NEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT 08APR85BP) CODE R@ ( -- 16B) SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP END-CODE CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT CODE EXIT RP X) LDA IP STA RP )Y LDA IP 1+ STA (RDROP JMP END-CODE \ EXECUTE PERFORM 08APR85BP) CODE ?EXIT ( FLAG -- ) SP X) LDA SP )Y ORA PHP SP 2INC PLP ' EXIT @ BNE NEXT JMP END-CODE CODE EXECUTE ( ADDR --) SP X) LDA W STA SP )Y LDA W 1+ STA SP 2INC W 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; \ C@ C! CTOGGLE 10JAN85BP) CODE C@ ( ADDR -- 8B) SP X) LDA N STA SP )Y LDA N 1+ STA LABEL (C@ 0 # LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE C! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA DEY LABEL (2DROP SP LDA CLC 4 # ADC SP STA CS ?[ SP 1+ INC ]? NEXT JMP END-CODE \ @ ! +! 08APR85BP) er14dez88 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; CODE @ ( ADDR -- 16B) SP X) LDA N STA SP )Y LDA N 1+ STA N )Y LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE ! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA INY SP )Y LDA 1 # LDY LABEL (! N )Y STA (2DROP JMP END-CODE \ +! DROP cas 26jan06 CODE +! ( N ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA CLC N X) ADC N X) STA INY SP )Y LDA 1 # LDY N )Y ADC (! JMP END-CODE CODE DROP ( 16B --) (DROP HERE 2- ! END-CODE \ SWAP cas 26jan06CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) SP )Y LDA TAX 3 # LDY SP )Y LDA N STA TXA SP )Y STA N LDA 1 # LDY SP )Y STA INY 0 # LDX SP )Y LDA N STA SP X) LDA SP )Y STA DEY N LDA PUTA JMP END-CODE \ DUP ?DUP 08MAY85BP) cas 26jan06 CODE DUP ( 16B -- 16B 16B) SP 2DEC 3 # LDY SP )Y LDA 1 # LDY SP )Y STA INY SP )Y LDA DEY PUTA JMP END-CODE CODE ?DUP ( 16B -- 16B 16B / FALSE) SP X) LDA SP )Y ORA 0= ?[ NEXT JMP ]? ' DUP @ JMP END-CODE \\ ?DUP and DUP in FORTH \ : ?DUP ( 16B -- 16B 16B / FALSE) \ DUP IF DUP THEN ; \ : DUP SP@ @ ; \ OVER ROT 13JUN84KS) cas 26jan06 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) SP 2DEC 4 # LDY SP )Y LDA SP X) STA INY SP )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ ROT OVER in FORTH \ : ROT >R SWAP R> SWAP ; \ : OVER >R DUP R> SWAP ; \ ROT cas 26jan06CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY SP )Y LDA N 1+ STA 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 5 # LDY SP )Y LDA N STA N 1+ LDA SP )Y STA 1 # LDY N LDA SP )Y STA INY SP )Y LDA N 1+ STA SP X) LDA SP )Y STA 4 # LDY SP )Y LDA SP X) STA N 1+ LDA SP )Y STA 1 # LDY NEXT JMP END-CODE \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) ROT ROT ; : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \\ : -ROLL ( N --) >R DUP SP@ DUP 2+ DUP 2+ SWAP R@ 2* CMOVE R> 1+ 2* + ! ; \ DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; CODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE : 2DUP ( 32B -- 32B 32B) OVER OVER ; \ : 2DROP ( 32B -- ) DROP DROP ; \ + AND OR XOR 08APR85BP) COMPILER ASSEMBLER ALSO DEFINITIONS H : DYADOP ( OPCODE --) T INY SP X) LDA DUP C, SP C, SP )Y STA DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA (XYDROP JMP H ; TARGET CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE \ - NOT NEGATE 24DEC83KS) CODE - ( N1 N2 -- N3) INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE CODE NOT ( 16B1 -- 16B2) CLC LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; \ DNEGATE SETUP D+ 14JUN84KS) CODE DNEGATE ( D1 -- -D1) INY SEC TXA SP )Y SBC SP )Y STA INY TXA SP )Y SBC SP )Y STA TXA SP X) SBC SP X) STA 1 # LDY TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE LABEL SETUP ( QUAN IN A) .A ASL TAX TAY DEY [[ SP )Y LDA N ,Y STA DEY 0< ?] TXA CLC SP ADC SP STA CS ?[ SP 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE \ D+ cas 26jan06CODE D+ ( D1 D2 -- D3) 2 # LDA SETUP JSR INY SP )Y LDA CLC N 2+ ADC SP )Y STA INY SP )Y LDA N 3 + ADC SP )Y STA SP X) LDA N ADC SP X) STA 1 # LDY SP )Y LDA N 1+ ADC SP )Y STA NEXT JMP END-CODE \ 1+ 2+ 3+ 1- 2- 08APR85BP) CODE 1+ ( N1 -- N2) 1 # LDA LABEL N+ CLC SP X) ADC CS NOT ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # ADC SP )Y STA NEXT JMP END-CODE CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE \ NUMBER CONSTANTS 24DEC83KS) CODE 1- ( N1 -- N2) SEC LABEL (1- SP X) LDA 1 # SBC CS ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # SBC SP )Y STA NEXT JMP END-CODE CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE ' TRUE ALIAS -1 ' FALSE ALIAS 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 CODE CLIT ( -- 8B) SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC NEXT JMP END-CODE RESTRICT CODE LIT ( -- 16B) SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT : LITERAL ( 16B --) DUP 0FF00 AND IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; \ COMPARISION CODE WORDS 13JUN84KS) CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ LABEL PUTTRUE 0FF # LDA 024 C, ]? LABEL PUTFALSE TXA SP )Y STA PUTA JMP END-CODE CODE 0= ( 16B -- FLAG) SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP SP )Y LDA N 3 + SBC PUTTRUE BCS ]? PUTFALSE JMP END-CODE \ COMPARISION CODE WORDS 13JUN84KS) CODE < ( N1 N2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC N 1+ LDA SP )Y EOR ' 0< @ BMI SP X) LDA N CMP SP )Y LDA N 1+ SBC ' 0< @ 2+ JMP END-CODE CODE U< ( U1 U2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ PUTTRUE JMP ]? PUTFALSE JMP END-CODE \ COMPARISION WORDS 24DEC83KS) | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) NEGATE 0< ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; : D0= ( D -- FLAG) OR 0= ; : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; : D< ( D1 D2 -- FLAG) ROT 2DUP - IF > NIP NIP ELSE 2DROP U< THEN ; \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 | : MINIMAX ( N1 N2 FLAG -- N3) RDROP IF SWAP THEN DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; : ABS ( N -- U) EXTEND IF NEGATE THEN ; \ LOOP PRIMITIVES 08FEB85BP/KS) | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX \ LIMIT \ ADR.OF.DO" ON RETURN-STACK \ (LOOP (+LOOP 08APR85BP) CODE (LOOP CLC 1 # LDA RP X) ADC RP X) STA CS ?[ RP )Y LDA 0 # ADC RP )Y STA CS ?[ NEXT JMP ]? ]? LABEL DOLOOP 5 # LDY RP )Y LDA IP 1+ STA DEY RP )Y LDA IP STA 1 # LDY NEXT JMP END-CODE RESTRICT CODE (+LOOP CLC SP X) LDA RP X) ADC RP X) STA SP )Y LDA RP )Y ADC RP )Y STA .A ROR SP )Y EOR PHP SP 2INC PLP DOLOOP BPL NEXT JMP END-CODE RESTRICT \ LOOP INDICES 08APR85BP) CODE I ( -- N) 0 # LDY LABEL LOOPINDEX SP 2DEC CLC RP )Y LDA INY INY RP )Y ADC SP X) STA DEY RP )Y LDA INY INY RP )Y ADC 1 # LDY SP )Y STA NEXT JMP END-CODE RESTRICT CODE J ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 24DEC83KS) CODE BRANCH CLC IP LDA IP X) ADC N STA IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA NEXT JMP END-CODE RESTRICT CODE ?BRANCH SP X) LDA SP )Y ORA PHP SP 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : MARK 1 ; IMMEDIATE RESTRICT : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ELSE 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ LOOPS 29JAN85KS/BP) : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : LOOP 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +LOOP 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ RETURNSTACK: CALLADR \ INDEX LIMIT \ ADR OF DO \ UM* BP/KS13.2.85) CODE UM* ( U1 U2 -- UD) SP )Y LDA N STA SP X) LDA N 1+ STA INY N 2 + STX N 3 + STX 010 # LDX [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA INY SP )Y LDA DEY N 2 + ADC N 2 + STA CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? DEX 0= ?] N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY N LDA SP )Y STA N 1+ LDA SP X) STA NEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; \ M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R IF NEGATE THEN SWAP DUP 0< IF NEGATE R> NOT >R THEN UM* R> IF DNEGATE THEN ; : * ( N N -- PROD) UM* DROP ; CODE 2* ( N1 -- N2) SP X) LDA .A ASL SP X) STA SP )Y LDA .A ROL SP )Y STA NEXT JMP END-CODE | : 2* DUP + ; \ UM/MOD 04JUL84KS) | : DIVOVL TRUE ABORT" DIVISION OVERFLOW" ; CODE UM/MOD ( UD U -- UREM UQUOT) SP X) LDA N 5 + STA SP )Y LDA N 4 + STA SP 2INC SP X) LDA N 1+ STA SP )Y LDA N STA INY SP )Y LDA N 3 + STA INY SP )Y LDA N 2+ STA 011 # LDX CLC [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC TAY N LDA N 4 + SBC CS NOT ?[ N 6 + ROL ]? CS ?[ N STA N 1+ STY ]? \ N 3 + ROL N 2+ ROL N 1+ ROL N ROL DEX 0= ?] 1 # LDY N ROR N 1+ ROR CS ?[ ;C: DIVOVL ; ASSEMBLER ]? N 2+ LDA SP )Y STA INY N 1+ LDA SP )Y STA INY N LDA SP )Y STA 1 # LDY N 3 + LDA PUTA JMP END-CODE \ 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< IF UNDER + SWAP THEN UM/MOD R@ 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- THEN THEN RDROP ; CODE 2/ ( N1 -- N2) SP )Y LDA .A ASL SP )Y LDA .A ROR SP )Y STA SP X) LDA .A ROR PUTA JMP END-CODE \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; : / ( N1 N2 -- QUOT) /MOD NIP ; : MOD ( N1 N2 -- REM) /MOD DROP ; : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; : UD/MOD ( UD1 U2 -- UREM UDQUOT) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ CMOVE CMOVE> (CMOVE> BP 08APR85) CODE CMOVE ( FROM TO QUAN --) 3 # LDA SETUP JSR DEY [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 1 # LDY NEXT JMP ]? ]? N 4 + )Y LDA N 2+ )Y STA INY 0= ?] N 5 + INC N 3 + INC ]] END-CODE \ CMOVE> MOVE cas 26jan06CODE CMOVE> ( FROM TO QUAN --) 3 # LDA SETUP JSR CLC N 1+ LDA N 3 + ADC N 3 + STA CLC N 1+ LDA N 5 + ADC N 5 + STA N 1+ INC N LDY CLC CS ?[ LABEL (CMOVE> DEY N 4 + )Y LDA N 2+ )Y STA ]? TYA (CMOVE> BNE N 3 + DEC N 5 + DEC N 1+ DEC (CMOVE> BNE 1 # LDY NEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN R> CMOVE ; \ PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; CODE COUNT ( ADDR -- ADDR+1 LEN) SP X) LDA N STA CLC 1 # ADC SP X) STA SP )Y LDA N 1+ STA 0 # ADC SP )Y STA SP 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; \ FILL 11JUN85BP) CODE FILL ( ADDR QUAN 8B -- ) 3 # LDA SETUP JSR DEY N LDA N 3 + LDX 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] N 5 + INC DEX 0= ?] ]? N 2+ LDX 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] ]? 1 # LDY NEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE 042 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT \ INPUT STRINGS 24DEC83KS) VARIABLE #TIB 0 #TIB ! VARIABLE >TIB $100 >TIB ! \ 050 ALLOT VARIABLE >IN 0 >IN ! VARIABLE BLK 0 BLK ! VARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; \ SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL 03APR85BP) (C LABEL (CAPITAL \ FOR COMMODORE ONLY PHA 0DF # AND \ 2ND UPPER TO LOWER ASCII A # CMP CS ?[ ASCII Z 1+ # CMP CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS ]? ]? PLA RTS END-CODE ) LABEL (CAPITAL \ FOR ASCII ONLY ASCII a # CMP CS ?[ ASCII z 1+ # CMP CC ?[ SEC ASCII a ASCII A - # SBC ]? ]? RTS END-CODE CODE CAPITAL ( CHAR -- CHAR' ) SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE \ CAPITALIZE 03APR85BP) CODE CAPITALIZE ( STRING -- STRING ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA DEY [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? INY N )Y LDA (CAPITAL JSR N )Y STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; \\ CAPITAL ( CHAR -- CHAR ) ASCII A ASCII Z 1+ UWITHIN IF I C@ [ ASCII A ASCII A - ] LITERAL - ; \ (WORD 08APR85BP) | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ N : LENGTH OF SOURCE \ N+2 : PTR IN SOURCE / NEXT CHAR \ N+4 : STRING START ADRESS \ N+6 : STRING LENGTH N 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA \ >IN+ADR0 =: N+2 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA \ LEN0->IN =: N N 1+ LDA >IN 1+ SBC N 1+ STA CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED SP )Y LDA >IN 1+ STA \ (WORD 08APR85BP) ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 0= ?[[ N 2+ WINC N WDEC ]]? N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS N 3 + LDA N 5 + STA [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR N 2+ WINC N WDEC PLP 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH N LDA N 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) N 2+ LDA SP )Y SBC >IN STA INY N 3 + LDA SP )Y SBC >IN 1+ STA \ (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA SP ADC SP STA CS ?[ SP 1+ INC ]? \ 2DROP USER' DP # LDY UP )Y LDA SP X) STA N STA INY UP )Y LDA 1 # LDY SP )Y STA N 1+ STA \ DP @ DEY N 6 + LDA \ STORE COUNT BYTE FIRST [[ N )Y STA N 4 + )Y LDA INY N 6 + DEC 0< ?] 020 # LDA N )Y STA \ ADD A BLANK 1 # LDY NEXT JMP END-CODE \ SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; : WORD ( CHAR -- ADDR) SOURCE (WORD ; : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; \\ : WORD ( CHAR -- ADDR) >R SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R ROT OVER SWAP - R> 0<> - >IN ! OVER - HERE PLACE BL HERE COUNT + C! HERE ; \ STATE ASCII ," (" " 24DEC83KS) VARIABLE STATE 0 STATE ! : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT : (" "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ASCII ) PARSE 2DROP ; IMMEDIATE : .( ASCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; \ NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ASCII 0 - DUP 9 U> IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; | : END? ( -- FLAG ) PTR @ 0= ; | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; \ ?NONUM ?NUM FIXBASE? 13FEB85KS) VARIABLE DPL -1 DPL ! | : ?NONUM ( FLAG -- EXIT IF TRUE ) IF RDROP 2DROP DROP RDROP FALSE THEN ; | : ?NUM ( FLAG -- EXIT IF TRUE ) IF RDROP DROP R> IF DNEGATE THEN ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ASCII & CASE? IF 0A TRUE EXIT THEN ASCII $ CASE? IF 10 TRUE EXIT THEN ASCII H CASE? IF 10 TRUE EXIT THEN ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ (NUMBER NUMBER 13FEB85KS) : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0.0 ROT END? ?NONUM CHAR ASCII - CASE? IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? IF BASE ! END? ?NONUM CHAR THEN BEGIN DIGIT? 0= ?NONUM BEGIN ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= UNTIL PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR REPEAT ; : NUMBER ( STRING -- D ) NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; \ HIDE REVEAL IMMEDIATE RESTRICT KS) VARIABLE LAST 0 LAST ! | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; : REVEAL LAST? IF 2- CURRENT @ ! THEN ; : RECURSIVE REVEAL ; IMMEDIATE RESTRICT | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; : IMMEDIATE 040 FLAG! ; : RESTRICT 080 FLAG! ; \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 CODE CLEARSTACK USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY NEXT JMP END-CODE : HALLOT ( QUAN -- ) S0 @ OVER - SWAP SP@ 2+ DUP ROT - DUP S0 ! 2 PICK OVER - MOVE CLEARSTACK S0 ! ; : HEAP ( -- ADDR) S0 @ 6+ ; : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; \ DOES> ; 30DEC84KS/BP) LABEL (DODOES> RP 2DEC IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP CLC W X) LDA 3 # ADC IP STA TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP LABEL DOCREATE 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE | : (;CODE R> LAST @ NAME> ! ; : DOES> COMPILE (;CODE 04C C, COMPILE (DODOES> ; IMMEDIATE RESTRICT \ 6502-ALIGN ?HEAD \ 08SEP84BP) | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; | : 6502-ALIGN/2 ( LFA -- LFA ) HERE 0FF AND 0FF = IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT THEN ; VARIABLE ?HEAD 0 ?HEAD ! : | ?HEAD @ ?EXIT -1 ?HEAD ! ; \ WARNING CREATE 30DEC84BP) VARIABLE WARNING 0 WARNING ! | : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; : CREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , ;CODE DOCREATE JMP END-CODE \ NFA? 30DEC84BP) | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA N 2+ ORA 0= ?[ PUTFALSE JMP ]? N 2+ )Y LDA SP )Y STA N 1+ STA N 2+ X) LDA SP X) STA N STA N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK N 2INC N X) LDA PHA SEC 01F # AND N ADC N STA CS ?[ N 1+ INC ]? PLA 020 # AND 0= NOT ?[ N )Y LDA PHA N X) LDA N STA PLA N 1+ STA ]? N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT \ >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK BEGIN @ DUP WHILE 2DUP 4 - SWAP NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE ELSE ." ???" THEN SPACE ; \ : ; CONSTANT VARIABLE 09JAN85KS/BP) : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA NEXT JMP END-CODE : ; 0 ?PAIRS COMPILE EXIT [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : CONSTANT ( 16B --) CREATE , ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE : VARIABLE CREATE 2 ALLOT ; \ UALLOT USER ALIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + 0FF U> ABORT" USERAREA FULL" UDP @ SWAP UDP +! ; : USER CREATE 2 UALLOT C, ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE : ALIAS ( CFA --) CREATE LAST @ DUP C@ 020 AND IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; \ VOC-LINK VP CURRENT CONTEXT ALSO BP) CREATE VP 10 ALLOT VARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER : ALSO VP @ 0A > ERROR" VOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) : VOCABULARY CREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK VOCABULARY FORTH VOCABULARY ONLY ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ BEGIN @ DUP STOP? 0= AND WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; \ (FIND 08APR85BP) CODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] N 2+ X) LDA 01F # AND N 4 + STA LABEL FINDLOOP 0 # LDY N )Y LDA TAX INY N )Y LDA N 1+ STA N STX N ORA 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? INY N )Y LDA 01F # AND N 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA N ADC N 5 + STA 0 # LDA N 1+ ADC N 6 + STA N 4 + LDY [[ N 2+ )Y LDA N 5 + )Y CMP \ FINDLOOP BNE DEY 0= ?] 3 # LDY N 6 + LDA SP )Y STA DEY N 5 + LDA SP )Y STA DEY 0 # LDX PUTTRUE JMP END-CODE \ FOUND 29JAN85BP) | CODE FOUND ( NFA -- CFA N ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA 01F # AND SEC N ADC N STA CS ?[ N 1+ INC ]? N 2+ LDA 020 # AND 0= ?[ N LDA SP X) STA N 1+ LDA ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA SP 2DEC N 2+ LDA 0< ?[ INY ]? .A ASL 0< NOT ?[ TYA 0FF # EOR TAY INY ]? TYA SP X) STA 0< ?[ 0FF # LDA 24 C, ]? TXA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ | : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ 020 AND IF @ THEN -1 R@ 080 AND IF 1- THEN R> 040 AND IF NEGATE THEN ; \ FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = IF 2- THEN BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN OVER VP 2+ U> WHILE SWAP 2- REPEAT NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ABORT" HAEH?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ >INTERPRET 28FEB85BP) LABEL JUMP INY CLC W )Y LDA 2 # ADC IP STA INY W )Y LDA 0 # ADC IP 1+ STA 1 # LDY NEXT JMP END-CODE VARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE VARIABLE >INTERPRET TO SPECIAL DEFER \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 ' NO.EXTENSIONS IS NOTFOUND : INTERPRET >INTERPRET ; -2 ALLOT | : INTERACTIVE ?STACK NAME FIND ?DUP IF 1 AND IF EXECUTE >INTERPRET THEN ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT ' INTERACTIVE >INTERPRET ! \ COMPILING [ ] 20DEC84BP) | : COMPILING ?STACK NAME FIND ?DUP IF 0> IF EXECUTE >INTERPRET THEN , >INTERPRET THEN NULLSTRING? ?EXIT NUMBER? ?DUP IF 0> IF SWAP [COMPILE] LITERAL THEN [COMPILE] LITERAL ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE : ] ['] COMPILING IS >INTERPRET STATE ON ; \ PERFOM DEFER IS 03FEB85BP) | : CRASH TRUE ABORT" CRASH" ; : DEFER CREATE ['] CRASH , ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE : (IS R> DUP 2+ >R @ ! ; | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; : IS ( ADR -- ) ' DUP DEF? >BODY STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE \ ?STACK 08SEP84KS) cas 15july2020 | : STACKFULL ( -- ) DEPTH 20 > ABORT" TIGHT STACK" REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; CODE ?STACK USER' DP # LDY SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? USER' S0 # LDY UP )Y LDA SP CMP INY UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN SP@ S0 @ U> ABORT" STACK EMPTY" ; \ .STATUS PUSH LOAD 08SEP84KS) DEFER .STATUS ' NOOP IS .STATUS | CREATE PULL 0 ] R> R> ! ; : PUSH ( ADDR -- ) R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT : LOAD ( BLK --) ?DUP 0= ?EXIT BLK PUSH BLK ! >IN PUSH >IN OFF .STATUS INTERPRET ; \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) : +LOAD ( OFFSET --) BLK @ + LOAD ; : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; \ QUIT (QUIT ABORT 07JUN85BP) | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; : (QUIT BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT DEFER 'QUIT ' (QUIT IS 'QUIT : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; DEFER 'ABORT ' NOOP IS 'ABORT : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT \ (ERROR ABORT" ERROR" 20MAR85BP) VARIABLE SCR 1 SCR ! VARIABLE R# 0 R# ! : (ERROR ( STRING -- ) STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT ' (ERROR ERRORHANDLER ! : (ABORT" "LIT SWAP IF >R CLEARSTACK R> ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ -TRAILING 08APR85BP) 020 CONSTANT BL CODE -TRAILING ( ADDR N1 -- ADR N2 ) TYA SETUP JSR SP X) LDA N 2+ STA CLC SP )Y LDA N 1+ ADC N 3 + STA N LDY CLC CS ?[ LABEL (-TRAIL DEY N 2+ )Y LDA BL # CMP 0<> ?[ INY 0= ?[ N 1+ INC ]? TYA PHA N 1+ LDA PUSH JMP ]? ]? TYA (-TRAIL BNE N 3 + DEC N 1 + DEC (-TRAIL BPL TYA PUSH0A JMP END-CODE \ SPACE SPACES 29JAN85KS/BP) : SPACE BL EMIT ; : SPACES ( U --) 0 ?DO SPACE LOOP ; \\ : -TRAILING ( ADDR N1 -- ADDR N2) 2DUP BOUNDS ?DO 2DUP + 1- C@ BL - IF LEAVE THEN 1- LOOP ; \ HOLD <# #> SIGN # #S 24DEC83KS) | : HLD ( -- ADDR) PAD 2- ; : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; : <# HLD HLD ! ; : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < IF [ ASCII A ASCII 9 - 1- ] LITERAL + THEN ASCII 0 + HOLD ; : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; \ PRINT NUMBERS 24DEC83KS) : D.R -ROT UNDER DABS <# #S ROT SIGN #> ROT OVER MAX OVER - SPACES TYPE ; : .R SWAP EXTEND ROT D.R ; : U.R 0 SWAP D.R ; : D. 0 D.R SPACE ; : . EXTEND D. ; : U. 0 D. ; \ .S LIST C/L L/S 24DEC83KS) : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 40 CONSTANT C/L \ SCREEN LINE LENGTH 10 CONSTANT L/S \ LINES PER SCREEN : LIST ( BLK --) SCR ! ." SCR " SCR @ DUP U. ." DR " DRV? . L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK I C/L * + C/L -TRAILING TYPE LOOP CR ; \ MULTITASKER PRIMITIVES BP03NOV85) CODE PAUSE NEXT HERE 2- ! END-CODE : LOCK ( ADDR --) DUP @ UP@ = IF DROP EXIT THEN BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; : UNLOCK ( ADDR --) DUP LOCK OFF ; LABEL WAKE WAKE >WAKE ! PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC IP # LDX XPULL JMP END-CODE \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ size of buffer \\ structure of buffer (same for all volksFORTH ) cas 26jan06 0 : LINK 2 : FILE 6 : BLOCKNR 8 : STATUSFLAGS 0A : DATA .. 1 KB .. STATUSFLAG BITS: 15 1 -> UPDATED FILE = -1 EMPTY BUFFER = 0 NO FCB , DIRECT ACCESS = ELSE ADR OF FCB ( SYSTEM DEPENDENT ) \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) LABEL THISBUFFER? 2 # LDY [[ N 4 + )Y LDA N 2- ,Y CMP 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) \ N-AREA : 0 BLK 2 FILE 4 BUFFER \ 6 PREDECESSOR 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ \ " 11JUN85BP) LABEL BLOCKFOUND SP 2INC 1 # LDY 8 # LDA CLC N 4 + ADC SP X) STA N 5 + LDA 0 # ADC SP )Y STA ' EXIT @ JMP ]? [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA N 6 + X) LDA N 4 + STA 1 # LDY N 6 + )Y LDA N 5 + STA N 4 + ORA 0= ?[ ( LIST EMPTY ) NEXT JMP ]? THISBUFFER? JSR 0= ?] \ FOUND, RELINK N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA BLOCKFOUND JMP END-CODE \\ (CORE? 23SEP85BP | : this? ( blk file bufadr -- flag ) DUP 4+ @ SWAP 2+ @ D= ; | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) BEGIN OVER OFFSET @ + OVER PREV @ THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN 2DUP >R OFFSET @ + >R PREV @ BEGIN DUP @ ?DUP 0= IF RDROP RDROP DROP EXIT THEN DUP R> R> 2DUP >R >R ROT THIS? 0= WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! RDROP RDROP REPEAT ; -2 ALLOT \ (DISKERR 11JUN85BP) : (DISKERR ." ERROR ! R TO RETRY " KEY DUP ASCII R = SWAP ASCII R = OR NOT ABORT" ABORTED" ; DEFER DISKERR ' (DISKERR IS DISKERR DEFER R/W \ BACKUP EMPTYBUF READBLK 11JUN85BP) | : BACKUP ( BUFADDR --) DUP 6+ @ 0< IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 IF INPUT PUSH OUTPUT PUSH STANDARDI/O BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W WHILE ." WRITE " DISKERR REPEAT THEN 080 OVER 4+ 1+ CTOGGLE THEN DROP ; | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W WHILE ." READ " DISKERR REPEAT R> ; \ TAKE MARK UPDATES? FULL? CORE? BP) | : TAKE ( -- BUFADDR) PREV BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL BUFFERS LOCK DUP BACKUP ; | : MARK ( BLK FILE BUFADDR -- BLK FILE ) 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! R> 4+ OFF BUFFERS UNLOCK ; | : UPDATES? ( -- BUFADDR / FLAG) PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; \ BLOCK & BUFFER MANIPULATION 11JUN85BP) : (BUFFER ( BLK FILE -- ADDR) BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT : (BLOCK ( BLK FILE -- ADDR) BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT | CODE FILE@ ( -- N ) USER' FILE # LDY UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; \ BLOCK & BUFFER MANIPULATION 09SEP84KS) : UPDATE 080 PREV @ 6+ 1+ C! ; : SAVE-BUFFERS BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT BUFFERS UNLOCK ; : EMPTY-BUFFERS BUFFERS LOCK PREV BEGIN @ ?DUP WHILE DUP EMPTYBUF REPEAT BUFFERS UNLOCK ; : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; \ MOVING BLOCKS 15DEC83KS) cas 26jan06| : (COPY ( FROM TO --) DUP FILE@ CORE? IF PREV @ EMPTYBUF THEN FULL? IF SAVE-BUFFERS THEN OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R OVER R@ + OVER U> >R 2DUP U< R> AND IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP THEN SAVE-BUFFERS 2DROP ; : COPY ( FROM TO --) 1 BLKMOVE ; : CONVEY ( [BLK1 BLK2] [TO.BLK --) SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; \ ALLOCATING BUFFERS 23SEP83KS) 12jan13py F000 CONSTANT LIMIT VARIABLE FIRST : ALLOTBUFFER ( -- ) FIRST @ R0 @ - B/BUF 2+ U< ?EXIT B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF PREV @ OVER ! PREV ! ; : FREEBUFFER ( -- ) FIRST @ LIMIT B/BUF - U< IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; \ ENDPOINTS OF FORGET 04JAN85BP/KS) | : \? ( NFA -- FLAG ) C@ 020 AND ; | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? NAME> UNDER 1+ U< SWAP HEAP? OR ; | : ENDPOINTS ( ADDR -- ADDR SYMB) HEAP VOC-LINK @ >R BEGIN R> @ ?DUP \ THROUGH ALL VOCABS WHILE DUP >R 4 - >R \ LINK ON RETURNST. BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP R@ 2+ \? IF OVER R@ 2+ FORGET? IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB THEN REPEAT RDROP REPEAT ; \ REMOVE 23JUL85WE | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY CLC UP )Y LDA 6 # ADC N 6 + STA INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC ]? CC ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? ]]? (DROP JMP END-CODE \ REMOVE- FORGET-WORDS 29APR85BP) | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; | : REMOVE-TASKS ( DIC --) UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) VOC-LINK REMOVE THRU.VOCSTACK DO 2DUP I @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 2DUP CURRENT @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ DELETING WORDS FROM DICT. 13JAN83KS) : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" ENDPOINTS FORGET-WORDS ; : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; : EMPTY [ DP ] LITERAL @ UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; \ SAVE BYE STOP? ?CR 20OCT84KS/BP) : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE FLUSH EMPTY (BYE ; | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; : ?CR COL C/L 0A - U> IF CR THEN ; \ IN/OUTPUT STRUCTURE 02MAR85BP) | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; : OUTPUT: CREATE ] DOES> OUTPUT ! ; 0 OUT: EMIT OUT: CR OUT: TYPE OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP : ROW ( -- ROW) AT? DROP ; : COL ( -- COL) AT? NIP ; | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; : INPUT: CREATE ] DOES> INPUT ! ; 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP \ ALIAS ONLY DEFINITIONEN 29JAN85BP) ONLY DEFINITIONS FORTH : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) ' ONLY ALIAS ONLY ' FORTH ALIAS FORTH ' WORDS ALIAS WORDS ' ALSO ALIAS ALSO ' DEFINITIONS ALIAS DEFINITIONS HOST TARGET \ 'COLD 07JUN85BP) cas 15juli2020| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH ." volksFORTH-83 3.8 py65 202007" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) CODE COLD HERE >COLD ! ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM CLI 0 # LDY CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] LABEL WARMBOOT BOOTNEXTLEN 1- # LDY [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA PLA IP STA PLA IP 1+ STA LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 \ Include system dependent Input / Output code \ (Keyboard and Screen) include systemio.fb HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET FORTH ALSO DEFINITIONS : FORTH-83 ; \ LAST WORD IN DICTIONARY \ SYSTEM DEPENDENT CONSTANTS BP/KS) VOCABULARY ASSEMBLER ASSEMBLER DEFINITIONS TRANSIENT ASSEMBLER PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK PUSH0A CONSTANT PUSH0A \ PUT A ON STACK PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK RP CONSTANT RP UP CONSTANT UP SP CONSTANT SP IP CONSTANT IP N CONSTANT N PUTA CONSTANT PUTA W CONSTANT W SETUP CONSTANT SETUP \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ SYSTEM PATCHUP 05JAN85BP) cas 26jan06 FORTH DEFINITIONS \ change memory layout for stacks and buffers here 6000 ' LIMIT >BODY ! $5800 S0 ! $5B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS \ No newline at end of file + ende 123 \ volksFORTH Loadscreen for py65 target cas 02aug2020forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE $1000 CONSTANT BASEADDR \ change target base address here BASEADDR DISPLACE ! TARGET DEFINITIONS BASEADDR HERE! hex &01 &126 +THRU decimal \ ASSEMBLER NONRELOCATE .UNRESOLVED \ if this prints unresolved \ definitions, check code CR .( SAVE-TARGET 6502-FORTH83) \ FORTH PREAMBLE AND ID cas 26jan06 ASSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ Coldstartvalues and user variables cas 02aug2020\ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE 0D6 ALLOT \ Bootlabel ," VolksForth-83 3.8.1 py65 02aug2020 CS" \ ZERO PAGE VARIABLES & NEXT cas 26jan06\ adjust this to match your architecture 20 DUP >LABEL RP 2+ DUP >LABEL UP 2+ DUP >LABEL PUTA 1+ DUP >LABEL SP 2+ DUP >LABEL NEXT DUP 5 + >LABEL IP 13 + >LABEL W W 8 + >LABEL N \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) LABEL BOOTNEXT -1 STA \ -1 IS DUMMY SP IP )Y LDA W 1+ STA -1 LDA W STA \ -1 IS DUMMY IP CLC IP LDA 2 # ADC IP STA CS NOT ?[ LABEL WJMP -1 ) JMP ]? IP 1+ INC WJMP BCS END-CODE \ Bootnext and Endtrace cas 26jan06HERE BOOTNEXT - >LABEL BOOTNEXTLEN CODE END-TRACE ( PATCH NEXT FOR TRACE ) 0A5 # LDA NEXT 0A + STA IP # LDA NEXT 0B + STA 069 # LDA NEXT 0C + STA 02 # LDA NEXT 0D + STA NEXT JMP END-CODE \ ;C: NOOP cas 26jan06 CREATE RECOVER ASSEMBLER PLA W STA PLA W 1+ STA W WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ manual forward reference for JMP command COMPILER ASSEMBLER ALSO DEFINITIONS H : ;C: 0 T RECOVER JSR END-CODE ] H ; TARGET CODE NOOP NEXT HERE 2- ! END-CODE \ USER VARIABLES cas 26jan06 CONSTANT ORIGIN 8 UALLOT DROP \ FOR MULTITASKER \ Adjust memory values for data stack and return stack here USER S0 $5000 S0 ! USER R0 $5500 R0 ! USER DP USER OFFSET 0 OFFSET ! USER BASE &10 BASE ! USER OUTPUT USER INPUT USER ERRORHANDLER \ POINTER FOR ABORT" -CODE USER VOC-LINK USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020 CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA N # LDX LABEL XPUSH SP 2DEC 1 ,X LDA SP )Y STA 0 ,X LDA 0 # LDX PUTA JMP END-CODE CODE SP! ( ADDR --) SP X) LDA TAX SP )Y LDA SP 1+ STA SP STX 0 # LDX NEXT JMP END-CODE \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06CODE UP@ ( -- ADDR) UP # LDX XPUSH JMP END-CODE CODE UP! ( ADDR --) UP # LDX LABEL XPULL SP )Y LDA 1 ,X STA DEY SP )Y LDA 0 ,X STA LABEL (XYDROP 0 # LDX 1 # LDY LABEL (DROP SP 2INC NEXT JMP END-CODE RESTRICT \ MANIPULATE RETURNSTACK 16FEB85BP/KS) CODE RP@ ( -- ADDR ) RP # LDX XPUSH JMP END-CODE CODE RP! ( ADDR -- ) RP # LDX XPULL JMP END-CODE RESTRICT CODE >R ( 16B -- ) RP 2DEC SP X) LDA RP X) STA SP )Y LDA RP )Y STA (DROP JMP END-CODE RESTRICT \ R> (RDROP (NRDROP cas 26jan06CODE R> ( -- 16B) SP 2DEC RP X) LDA SP X) STA RP )Y LDA SP )Y STA LABEL (RDROP 2 # LDA LABEL (NRDROP CLC RP ADC RP STA CS ?[ RP 1+ INC ]? NEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT 08APR85BP) CODE R@ ( -- 16B) SP 2DEC RP )Y LDA SP )Y STA RP X) LDA PUTA JMP END-CODE CODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT CODE EXIT RP X) LDA IP STA RP )Y LDA IP 1+ STA (RDROP JMP END-CODE \ EXECUTE PERFORM 08APR85BP) CODE ?EXIT ( FLAG -- ) SP X) LDA SP )Y ORA PHP SP 2INC PLP ' EXIT @ BNE NEXT JMP END-CODE CODE EXECUTE ( ADDR --) SP X) LDA W STA SP )Y LDA W 1+ STA SP 2INC W 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; \ C@ C! CTOGGLE 10JAN85BP) CODE C@ ( ADDR -- 8B) SP X) LDA N STA SP )Y LDA N 1+ STA LABEL (C@ 0 # LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE C! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA DEY LABEL (2DROP SP LDA CLC 4 # ADC SP STA CS ?[ SP 1+ INC ]? NEXT JMP END-CODE \ @ ! +! 08APR85BP) er14dez88 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; CODE @ ( ADDR -- 16B) SP X) LDA N STA SP )Y LDA N 1+ STA N )Y LDA SP )Y STA N X) LDA PUTA JMP END-CODE CODE ! ( 16B ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA N X) STA INY SP )Y LDA 1 # LDY LABEL (! N )Y STA (2DROP JMP END-CODE \ +! DROP cas 26jan06 CODE +! ( N ADDR --) SP X) LDA N STA SP )Y LDA N 1+ STA INY SP )Y LDA CLC N X) ADC N X) STA INY SP )Y LDA 1 # LDY N )Y ADC (! JMP END-CODE CODE DROP ( 16B --) (DROP HERE 2- ! END-CODE \ SWAP cas 26jan06CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) SP )Y LDA TAX 3 # LDY SP )Y LDA N STA TXA SP )Y STA N LDA 1 # LDY SP )Y STA INY 0 # LDX SP )Y LDA N STA SP X) LDA SP )Y STA DEY N LDA PUTA JMP END-CODE \ DUP ?DUP 08MAY85BP) cas 26jan06 CODE DUP ( 16B -- 16B 16B) SP 2DEC 3 # LDY SP )Y LDA 1 # LDY SP )Y STA INY SP )Y LDA DEY PUTA JMP END-CODE CODE ?DUP ( 16B -- 16B 16B / FALSE) SP X) LDA SP )Y ORA 0= ?[ NEXT JMP ]? ' DUP @ JMP END-CODE \\ ?DUP and DUP in FORTH \ : ?DUP ( 16B -- 16B 16B / FALSE) \ DUP IF DUP THEN ; \ : DUP SP@ @ ; \ OVER ROT 13JUN84KS) cas 26jan06 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) SP 2DEC 4 # LDY SP )Y LDA SP X) STA INY SP )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ ROT OVER in FORTH \ : ROT >R SWAP R> SWAP ; \ : OVER >R DUP R> SWAP ; \ ROT cas 26jan06CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY SP )Y LDA N 1+ STA 1 # LDY SP )Y LDA 3 # LDY SP )Y STA 5 # LDY SP )Y LDA N STA N 1+ LDA SP )Y STA 1 # LDY N LDA SP )Y STA INY SP )Y LDA N 1+ STA SP X) LDA SP )Y STA 4 # LDY SP )Y LDA SP X) STA N 1+ LDA SP )Y STA 1 # LDY NEXT JMP END-CODE \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) ROT ROT ; : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \\ : -ROLL ( N --) >R DUP SP@ DUP 2+ DUP 2+ SWAP R@ 2* CMOVE R> 1+ 2* + ! ; \ DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; CODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE : 2DUP ( 32B -- 32B 32B) OVER OVER ; \ : 2DROP ( 32B -- ) DROP DROP ; \ + AND OR XOR 08APR85BP) COMPILER ASSEMBLER ALSO DEFINITIONS H : DYADOP ( OPCODE --) T INY SP X) LDA DUP C, SP C, SP )Y STA DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA (XYDROP JMP H ; TARGET CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE \ - NOT NEGATE 24DEC83KS) CODE - ( N1 N2 -- N3) INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE CODE NOT ( 16B1 -- 16B2) CLC LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; \ DNEGATE SETUP D+ 14JUN84KS) CODE DNEGATE ( D1 -- -D1) INY SEC TXA SP )Y SBC SP )Y STA INY TXA SP )Y SBC SP )Y STA TXA SP X) SBC SP X) STA 1 # LDY TXA SP )Y SBC SP )Y STA NEXT JMP END-CODE LABEL SETUP ( QUAN IN A) .A ASL TAX TAY DEY [[ SP )Y LDA N ,Y STA DEY 0< ?] TXA CLC SP ADC SP STA CS ?[ SP 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE \ D+ cas 26jan06CODE D+ ( D1 D2 -- D3) 2 # LDA SETUP JSR INY SP )Y LDA CLC N 2+ ADC SP )Y STA INY SP )Y LDA N 3 + ADC SP )Y STA SP X) LDA N ADC SP X) STA 1 # LDY SP )Y LDA N 1+ ADC SP )Y STA NEXT JMP END-CODE \ 1+ 2+ 3+ 1- 2- 08APR85BP) CODE 1+ ( N1 -- N2) 1 # LDA LABEL N+ CLC SP X) ADC CS NOT ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # ADC SP )Y STA NEXT JMP END-CODE CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE \ NUMBER CONSTANTS 24DEC83KS) CODE 1- ( N1 -- N2) SEC LABEL (1- SP X) LDA 1 # SBC CS ?[ PUTA JMP ]? SP X) STA SP )Y LDA 0 # SBC SP )Y STA NEXT JMP END-CODE CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE ' TRUE ALIAS -1 ' FALSE ALIAS 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 4 CONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 CODE CLIT ( -- 8B) SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC NEXT JMP END-CODE RESTRICT CODE LIT ( -- 16B) SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT : LITERAL ( 16B --) DUP 0FF00 AND IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; \ COMPARISION CODE WORDS 13JUN84KS) CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ LABEL PUTTRUE 0FF # LDA 024 C, ]? LABEL PUTFALSE TXA SP )Y STA PUTA JMP END-CODE CODE 0= ( 16B -- FLAG) SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE CODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP SP )Y LDA N 3 + SBC PUTTRUE BCS ]? PUTFALSE JMP END-CODE \ COMPARISION CODE WORDS 13JUN84KS) CODE < ( N1 N2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC N 1+ LDA SP )Y EOR ' 0< @ BMI SP X) LDA N CMP SP )Y LDA N 1+ SBC ' 0< @ 2+ JMP END-CODE CODE U< ( U1 U2 -- FLAG) SP X) LDA N STA SP )Y LDA N 1+ STA SP 2INC SP X) LDA N CMP SP )Y LDA N 1+ SBC CS NOT ?[ PUTTRUE JMP ]? PUTFALSE JMP END-CODE \ COMPARISION WORDS 24DEC83KS) cas 02aug2020 | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; : 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; : D0= ( D -- FLAG) OR 0= ; : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; : D< ( D1 D2 -- FLAG) ROT 2DUP - IF > NIP NIP ELSE 2DROP U< THEN ; \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 | : MINIMAX ( N1 N2 FLAG -- N3) RDROP IF SWAP THEN DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; : ABS ( N -- U) EXTEND IF NEGATE THEN ; \ LOOP PRIMITIVES 08FEB85BP/KS) | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX \ LIMIT \ ADR.OF.DO" ON RETURN-STACK \ (LOOP (+LOOP 08APR85BP) CODE (LOOP CLC 1 # LDA RP X) ADC RP X) STA CS ?[ RP )Y LDA 0 # ADC RP )Y STA CS ?[ NEXT JMP ]? ]? LABEL DOLOOP 5 # LDY RP )Y LDA IP 1+ STA DEY RP )Y LDA IP STA 1 # LDY NEXT JMP END-CODE RESTRICT CODE (+LOOP CLC SP X) LDA RP X) ADC RP X) STA SP )Y LDA RP )Y ADC RP )Y STA .A ROR SP )Y EOR PHP SP 2INC PLP DOLOOP BPL NEXT JMP END-CODE RESTRICT \ LOOP INDICES 08APR85BP) CODE I ( -- N) 0 # LDY LABEL LOOPINDEX SP 2DEC CLC RP )Y LDA INY INY RP )Y ADC SP X) STA DEY RP )Y LDA INY INY RP )Y ADC 1 # LDY SP )Y STA NEXT JMP END-CODE RESTRICT CODE J ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 24DEC83KS) CODE BRANCH CLC IP LDA IP X) ADC N STA IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA NEXT JMP END-CODE RESTRICT CODE ?BRANCH SP X) LDA SP )Y ORA PHP SP 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : MARK 1 ; IMMEDIATE RESTRICT : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ELSE 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT | : (REPTIL RESOLVE REPEAT ; : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT \ LOOPS 29JAN85KS/BP) : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : LOOP 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +LOOP 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ RETURNSTACK: CALLADR \ INDEX LIMIT \ ADR OF DO \ UM* BP/KS13.2.85) CODE UM* ( U1 U2 -- UD) SP )Y LDA N STA SP X) LDA N 1+ STA INY N 2 + STX N 3 + STX 010 # LDX [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA INY SP )Y LDA DEY N 2 + ADC N 2 + STA CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? DEX 0= ?] N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY N LDA SP )Y STA N 1+ LDA SP X) STA NEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; \ M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R IF NEGATE THEN SWAP DUP 0< IF NEGATE R> NOT >R THEN UM* R> IF DNEGATE THEN ; : * ( N N -- PROD) UM* DROP ; CODE 2* ( N1 -- N2) SP X) LDA .A ASL SP X) STA SP )Y LDA .A ROL SP )Y STA NEXT JMP END-CODE | : 2* DUP + ; \ UM/MOD 04JUL84KS) | : DIVOVL TRUE ABORT" DIVISION OVERFLOW" ; CODE UM/MOD ( UD U -- UREM UQUOT) SP X) LDA N 5 + STA SP )Y LDA N 4 + STA SP 2INC SP X) LDA N 1+ STA SP )Y LDA N STA INY SP )Y LDA N 3 + STA INY SP )Y LDA N 2+ STA 011 # LDX CLC [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC TAY N LDA N 4 + SBC CS NOT ?[ N 6 + ROL ]? CS ?[ N STA N 1+ STY ]? \ N 3 + ROL N 2+ ROL N 1+ ROL N ROL DEX 0= ?] 1 # LDY N ROR N 1+ ROR CS ?[ ;C: DIVOVL ; ASSEMBLER ]? N 2+ LDA SP )Y STA INY N 1+ LDA SP )Y STA INY N LDA SP )Y STA 1 # LDY N 3 + LDA PUTA JMP END-CODE \ 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< IF UNDER + SWAP THEN UM/MOD R@ 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- THEN THEN RDROP ; CODE 2/ ( N1 -- N2) SP )Y LDA .A ASL SP )Y LDA .A ROR SP )Y STA SP X) LDA .A ROR PUTA JMP END-CODE \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; : / ( N1 N2 -- QUOT) /MOD NIP ; : MOD ( N1 N2 -- REM) /MOD DROP ; : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; : UD/MOD ( UD1 U2 -- UREM UDQUOT) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ CMOVE CMOVE> (CMOVE> BP 08APR85) CODE CMOVE ( FROM TO QUAN --) 3 # LDA SETUP JSR DEY [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ 1 # LDY NEXT JMP ]? ]? N 4 + )Y LDA N 2+ )Y STA INY 0= ?] N 5 + INC N 3 + INC ]] END-CODE \ CMOVE> MOVE cas 26jan06CODE CMOVE> ( FROM TO QUAN --) 3 # LDA SETUP JSR CLC N 1+ LDA N 3 + ADC N 3 + STA CLC N 1+ LDA N 5 + ADC N 5 + STA N 1+ INC N LDY CLC CS ?[ LABEL (CMOVE> DEY N 4 + )Y LDA N 2+ )Y STA ]? TYA (CMOVE> BNE N 3 + DEC N 5 + DEC N 1+ DEC (CMOVE> BNE 1 # LDY NEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN R> CMOVE ; \ PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; CODE COUNT ( ADDR -- ADDR+1 LEN) SP X) LDA N STA CLC 1 # ADC SP X) STA SP )Y LDA N 1+ STA 0 # ADC SP )Y STA SP 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; \ FILL 11JUN85BP) CODE FILL ( ADDR QUAN 8B -- ) 3 # LDA SETUP JSR DEY N LDA N 3 + LDX 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] N 5 + INC DEX 0= ?] ]? N 2+ LDX 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] ]? 1 # LDY NEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE 042 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT \ INPUT STRINGS 24DEC83KS) VARIABLE #TIB 0 #TIB ! VARIABLE >TIB $100 >TIB ! \ 050 ALLOT VARIABLE >IN 0 >IN ! VARIABLE BLK 0 BLK ! VARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; \ SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ - WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R BEGIN DUP WHILE OVER C@ R@ = WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL 03APR85BP) (C LABEL (CAPITAL \ FOR COMMODORE ONLY PHA 0DF # AND \ 2ND UPPER TO LOWER ASCII A # CMP CS ?[ ASCII Z 1+ # CMP CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS ]? ]? PLA RTS END-CODE ) LABEL (CAPITAL \ FOR ASCII ONLY ASCII a # CMP CS ?[ ASCII z 1+ # CMP CC ?[ SEC ASCII a ASCII A - # SBC ]? ]? RTS END-CODE CODE CAPITAL ( CHAR -- CHAR' ) SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE \ CAPITALIZE 03APR85BP) CODE CAPITALIZE ( STRING -- STRING ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA DEY [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? INY N )Y LDA (CAPITAL JSR N )Y STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; \\ CAPITAL ( CHAR -- CHAR ) ASCII A ASCII Z 1+ UWITHIN IF I C@ [ ASCII A ASCII A - ] LITERAL - ; \ (WORD 08APR85BP) | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ N : LENGTH OF SOURCE \ N+2 : PTR IN SOURCE / NEXT CHAR \ N+4 : STRING START ADRESS \ N+6 : STRING LENGTH N 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA \ >IN+ADR0 =: N+2 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA \ LEN0->IN =: N N 1+ LDA >IN 1+ SBC N 1+ STA CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED SP )Y LDA >IN 1+ STA \ (WORD 08APR85BP) ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 0= ?[[ N 2+ WINC N WDEC ]]? N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS N 3 + LDA N 5 + STA [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR N 2+ WINC N WDEC PLP 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH N LDA N 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) N 2+ LDA SP )Y SBC >IN STA INY N 3 + LDA SP )Y SBC >IN 1+ STA \ (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA SP ADC SP STA CS ?[ SP 1+ INC ]? \ 2DROP USER' DP # LDY UP )Y LDA SP X) STA N STA INY UP )Y LDA 1 # LDY SP )Y STA N 1+ STA \ DP @ DEY N 6 + LDA \ STORE COUNT BYTE FIRST [[ N )Y STA N 4 + )Y LDA INY N 6 + DEC 0< ?] 020 # LDA N )Y STA \ ADD A BLANK 1 # LDY NEXT JMP END-CODE \ SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; : WORD ( CHAR -- ADDR) SOURCE (WORD ; : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; \\ : WORD ( CHAR -- ADDR) >R SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R ROT OVER SWAP - R> 0<> - >IN ! OVER - HERE PLACE BL HERE COUNT + C! HERE ; \ STATE ASCII ," (" " 24DEC83KS) VARIABLE STATE 0 STATE ! : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT : (" "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ASCII ) PARSE 2DROP ; IMMEDIATE : .( ASCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; \ NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ASCII 0 - DUP 9 U> IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; | : END? ( -- FLAG ) PTR @ 0= ; | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; \ ?NONUM ?NUM FIXBASE? 13FEB85KS) VARIABLE DPL -1 DPL ! | : ?NONUM ( FLAG -- EXIT IF TRUE ) IF RDROP 2DROP DROP RDROP FALSE THEN ; | : ?NUM ( FLAG -- EXIT IF TRUE ) IF RDROP DROP R> IF DNEGATE THEN ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ASCII & CASE? IF 0A TRUE EXIT THEN ASCII $ CASE? IF 10 TRUE EXIT THEN ASCII H CASE? IF 10 TRUE EXIT THEN ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; \ 13FEB85KS) | : PUNCTUATION? ( CHAR -- FLAG) ASCII , OVER = SWAP ASCII . = OR ; | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; | VARIABLE PTR \ POINTS INTO STRING \ (NUMBER NUMBER 13FEB85KS) : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0.0 ROT END? ?NONUM CHAR ASCII - CASE? IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? IF BASE ! END? ?NONUM CHAR THEN BEGIN DIGIT? 0= ?NONUM BEGIN ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= UNTIL PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR REPEAT ; : NUMBER ( STRING -- D ) NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; \ HIDE REVEAL IMMEDIATE RESTRICT KS) VARIABLE LAST 0 LAST ! | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; : REVEAL LAST? IF 2- CURRENT @ ! THEN ; : RECURSIVE REVEAL ; IMMEDIATE RESTRICT | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; : IMMEDIATE 040 FLAG! ; : RESTRICT 080 FLAG! ; \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 CODE CLEARSTACK USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY NEXT JMP END-CODE : HALLOT ( QUAN -- ) S0 @ OVER - SWAP SP@ 2+ DUP ROT - DUP S0 ! 2 PICK OVER - MOVE CLEARSTACK S0 ! ; : HEAP ( -- ADDR) S0 @ 6+ ; : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; \ DOES> ; 30DEC84KS/BP) LABEL (DODOES> RP 2DEC IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP CLC W X) LDA 3 # ADC IP STA TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP LABEL DOCREATE 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE | : (;CODE R> LAST @ NAME> ! ; : DOES> COMPILE (;CODE 04C C, COMPILE (DODOES> ; IMMEDIATE RESTRICT \ 6502-ALIGN ?HEAD \ 08SEP84BP) | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; | : 6502-ALIGN/2 ( LFA -- LFA ) HERE 0FF AND 0FF = IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT THEN ; VARIABLE ?HEAD 0 ?HEAD ! : | ?HEAD @ ?EXIT -1 ?HEAD ! ; \ WARNING CREATE 30DEC84BP) VARIABLE WARNING 0 WARNING ! | : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; : CREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , ;CODE DOCREATE JMP END-CODE \ NFA? 30DEC84BP) | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA N 2+ ORA 0= ?[ PUTFALSE JMP ]? N 2+ )Y LDA SP )Y STA N 1+ STA N 2+ X) LDA SP X) STA N STA N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK N 2INC N X) LDA PHA SEC 01F # AND N ADC N STA CS ?[ N 1+ INC ]? PLA 020 # AND 0= NOT ?[ N )Y LDA PHA N X) LDA N STA PLA N 1+ STA ]? N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT \ >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK BEGIN @ DUP WHILE 2DUP 4 - SWAP NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE ELSE ." ???" THEN SPACE ; \ : ; CONSTANT VARIABLE 09JAN85KS/BP) : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA NEXT JMP END-CODE : ; 0 ?PAIRS COMPILE EXIT [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : CONSTANT ( 16B --) CREATE , ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE : VARIABLE CREATE 2 ALLOT ; \ UALLOT USER ALIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + 0FF U> ABORT" USERAREA FULL" UDP @ SWAP UDP +! ; : USER CREATE 2 UALLOT C, ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE : ALIAS ( CFA --) CREATE LAST @ DUP C@ 020 AND IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; \ VOC-LINK VP CURRENT CONTEXT ALSO BP) CREATE VP 10 ALLOT VARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER : ALSO VP @ 0A > ERROR" VOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) : VOCABULARY CREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK VOCABULARY FORTH VOCABULARY ONLY ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ BEGIN @ DUP STOP? 0= AND WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; \ (FIND 08APR85BP) CODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] N 2+ X) LDA 01F # AND N 4 + STA LABEL FINDLOOP 0 # LDY N )Y LDA TAX INY N )Y LDA N 1+ STA N STX N ORA 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? INY N )Y LDA 01F # AND N 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA N ADC N 5 + STA 0 # LDA N 1+ ADC N 6 + STA N 4 + LDY [[ N 2+ )Y LDA N 5 + )Y CMP \ FINDLOOP BNE DEY 0= ?] 3 # LDY N 6 + LDA SP )Y STA DEY N 5 + LDA SP )Y STA DEY 0 # LDX PUTTRUE JMP END-CODE \ FOUND 29JAN85BP) | CODE FOUND ( NFA -- CFA N ) SP X) LDA N STA SP )Y LDA N 1+ STA N X) LDA N 2+ STA 01F # AND SEC N ADC N STA CS ?[ N 1+ INC ]? N 2+ LDA 020 # AND 0= ?[ N LDA SP X) STA N 1+ LDA ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA SP 2DEC N 2+ LDA 0< ?[ INY ]? .A ASL 0< NOT ?[ TYA 0FF # EOR TAY INY ]? TYA SP X) STA 0< ?[ 0FF # LDA 24 C, ]? TXA 1 # LDY SP )Y STA NEXT JMP END-CODE \\ | : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ 020 AND IF @ THEN -1 R@ 080 AND IF 1- THEN R> 040 AND IF NEGATE THEN ; \ FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = IF 2- THEN BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN OVER VP 2+ U> WHILE SWAP 2- REPEAT NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ABORT" HAEH?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP IF NIP THEN ; \ >INTERPRET 28FEB85BP) LABEL JUMP INY CLC W )Y LDA 2 # ADC IP STA INY W )Y LDA 0 # ADC IP 1+ STA 1 # LDY NEXT JMP END-CODE VARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE VARIABLE >INTERPRET TO SPECIAL DEFER \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 DEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 ' NO.EXTENSIONS IS NOTFOUND : INTERPRET >INTERPRET ; -2 ALLOT | : INTERACTIVE ?STACK NAME FIND ?DUP IF 1 AND IF EXECUTE >INTERPRET THEN ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT ' INTERACTIVE >INTERPRET ! \ COMPILING [ ] 20DEC84BP) | : COMPILING ?STACK NAME FIND ?DUP IF 0> IF EXECUTE >INTERPRET THEN , >INTERPRET THEN NULLSTRING? ?EXIT NUMBER? ?DUP IF 0> IF SWAP [COMPILE] LITERAL THEN [COMPILE] LITERAL ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE : ] ['] COMPILING IS >INTERPRET STATE ON ; \ PERFOM DEFER IS 03FEB85BP) | : CRASH TRUE ABORT" CRASH" ; : DEFER CREATE ['] CRASH , ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE : (IS R> DUP 2+ >R @ ! ; | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; : IS ( ADR -- ) ' DUP DEF? >BODY STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE \ ?STACK 08SEP84KS) cas 15july2020 | : STACKFULL ( -- ) DEPTH 20 > ABORT" TIGHT STACK" REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; CODE ?STACK USER' DP # LDY SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? USER' S0 # LDY UP )Y LDA SP CMP INY UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN SP@ S0 @ U> ABORT" STACK EMPTY" ; \ .STATUS PUSH LOAD 08SEP84KS) DEFER .STATUS ' NOOP IS .STATUS | CREATE PULL 0 ] R> R> ! ; : PUSH ( ADDR -- ) R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT : LOAD ( BLK --) ?DUP 0= ?EXIT BLK PUSH BLK ! >IN PUSH >IN OFF .STATUS INTERPRET ; \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) : +LOAD ( OFFSET --) BLK @ + LOAD ; : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; \ QUIT (QUIT ABORT 07JUN85BP) | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; : (QUIT BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT DEFER 'QUIT ' (QUIT IS 'QUIT : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; DEFER 'ABORT ' NOOP IS 'ABORT : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT \ (ERROR ABORT" ERROR" 20MAR85BP) VARIABLE SCR 1 SCR ! VARIABLE R# 0 R# ! : (ERROR ( STRING -- ) STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT ' (ERROR ERRORHANDLER ! : (ABORT" "LIT SWAP IF >R CLEARSTACK R> ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT \ | : (ERR" "LIT SWAP IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT \ -TRAILING 08APR85BP) 020 CONSTANT BL CODE -TRAILING ( ADDR N1 -- ADR N2 ) TYA SETUP JSR SP X) LDA N 2+ STA CLC SP )Y LDA N 1+ ADC N 3 + STA N LDY CLC CS ?[ LABEL (-TRAIL DEY N 2+ )Y LDA BL # CMP 0<> ?[ INY 0= ?[ N 1+ INC ]? TYA PHA N 1+ LDA PUSH JMP ]? ]? TYA (-TRAIL BNE N 3 + DEC N 1 + DEC (-TRAIL BPL TYA PUSH0A JMP END-CODE \ SPACE SPACES 29JAN85KS/BP) : SPACE BL EMIT ; : SPACES ( U --) 0 ?DO SPACE LOOP ; \\ : -TRAILING ( ADDR N1 -- ADDR N2) 2DUP BOUNDS ?DO 2DUP + 1- C@ BL - IF LEAVE THEN 1- LOOP ; \ HOLD <# #> SIGN # #S 24DEC83KS) | : HLD ( -- ADDR) PAD 2- ; : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; : <# HLD HLD ! ; : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < IF [ ASCII A ASCII 9 - 1- ] LITERAL + THEN ASCII 0 + HOLD ; : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; \ PRINT NUMBERS 24DEC83KS) : D.R -ROT UNDER DABS <# #S ROT SIGN #> ROT OVER MAX OVER - SPACES TYPE ; : .R SWAP EXTEND ROT D.R ; : U.R 0 SWAP D.R ; : D. 0 D.R SPACE ; : . EXTEND D. ; : U. 0 D. ; \ .S LIST C/L L/S 24DEC83KS) : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; 40 CONSTANT C/L \ SCREEN LINE LENGTH 10 CONSTANT L/S \ LINES PER SCREEN : LIST ( BLK --) SCR ! ." SCR " SCR @ DUP U. ." DR " DRV? . L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK I C/L * + C/L -TRAILING TYPE LOOP CR ; \ MULTITASKER PRIMITIVES BP03NOV85) CODE PAUSE NEXT HERE 2- ! END-CODE : LOCK ( ADDR --) DUP @ UP@ = IF DROP EXIT THEN BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; : UNLOCK ( ADDR --) DUP LOCK OFF ; LABEL WAKE WAKE >WAKE ! PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA 1 # LDY SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC IP # LDX XPULL JMP END-CODE \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK VARIABLE PREV 0 PREV ! \ LISTHEAD | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR 0408 CONSTANT B/BUF \ size of buffer \\ structure of buffer (same for all volksFORTH ) cas 26jan06 0 : LINK 2 : FILE 6 : BLOCKNR 8 : STATUSFLAGS 0A : DATA .. 1 KB .. STATUSFLAG BITS: 15 1 -> UPDATED FILE = -1 EMPTY BUFFER = 0 NO FCB , DIRECT ACCESS = ELSE ADR OF FCB ( SYSTEM DEPENDENT ) \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) LABEL THISBUFFER? 2 # LDY [[ N 4 + )Y LDA N 2- ,Y CMP 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) \ N-AREA : 0 BLK 2 FILE 4 BUFFER \ 6 PREDECESSOR 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ \ " 11JUN85BP) LABEL BLOCKFOUND SP 2INC 1 # LDY 8 # LDA CLC N 4 + ADC SP X) STA N 5 + LDA 0 # ADC SP )Y STA ' EXIT @ JMP ]? [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA N 6 + X) LDA N 4 + STA 1 # LDY N 6 + )Y LDA N 5 + STA N 4 + ORA 0= ?[ ( LIST EMPTY ) NEXT JMP ]? THISBUFFER? JSR 0= ?] \ FOUND, RELINK N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA BLOCKFOUND JMP END-CODE \\ (CORE? 23SEP85BP | : this? ( blk file bufadr -- flag ) DUP 4+ @ SWAP 2+ @ D= ; | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) BEGIN OVER OFFSET @ + OVER PREV @ THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN 2DUP >R OFFSET @ + >R PREV @ BEGIN DUP @ ?DUP 0= IF RDROP RDROP DROP EXIT THEN DUP R> R> 2DUP >R >R ROT THIS? 0= WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! RDROP RDROP REPEAT ; -2 ALLOT \ (DISKERR 11JUN85BP) : (DISKERR ." ERROR ! R TO RETRY " KEY DUP ASCII R = SWAP ASCII R = OR NOT ABORT" ABORTED" ; DEFER DISKERR ' (DISKERR IS DISKERR DEFER R/W \ BACKUP EMPTYBUF READBLK 11JUN85BP) | : BACKUP ( BUFADDR --) DUP 6+ @ 0< IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 IF INPUT PUSH OUTPUT PUSH STANDARDI/O BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W WHILE ." WRITE " DISKERR REPEAT THEN 080 OVER 4+ 1+ CTOGGLE THEN DROP ; | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W WHILE ." READ " DISKERR REPEAT R> ; \ TAKE MARK UPDATES? FULL? CORE? BP) | : TAKE ( -- BUFADDR) PREV BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL BUFFERS LOCK DUP BACKUP ; | : MARK ( BLK FILE BUFADDR -- BLK FILE ) 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! R> 4+ OFF BUFFERS UNLOCK ; | : UPDATES? ( -- BUFADDR / FLAG) PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; \ BLOCK & BUFFER MANIPULATION 11JUN85BP) : (BUFFER ( BLK FILE -- ADDR) BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT : (BLOCK ( BLK FILE -- ADDR) BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT | CODE FILE@ ( -- N ) USER' FILE # LDY UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; \ BLOCK & BUFFER MANIPULATION 09SEP84KS) : UPDATE 080 PREV @ 6+ 1+ C! ; : SAVE-BUFFERS BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT BUFFERS UNLOCK ; : EMPTY-BUFFERS BUFFERS LOCK PREV BEGIN @ ?DUP WHILE DUP EMPTYBUF REPEAT BUFFERS UNLOCK ; : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; \ MOVING BLOCKS 15DEC83KS) cas 26jan06| : (COPY ( FROM TO --) DUP FILE@ CORE? IF PREV @ EMPTYBUF THEN FULL? IF SAVE-BUFFERS THEN OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R OVER R@ + OVER U> >R 2DUP U< R> AND IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP THEN SAVE-BUFFERS 2DROP ; : COPY ( FROM TO --) 1 BLKMOVE ; : CONVEY ( [BLK1 BLK2] [TO.BLK --) SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; \ ALLOCATING BUFFERS 23SEP83KS) 12jan13py F000 CONSTANT LIMIT VARIABLE FIRST : ALLOTBUFFER ( -- ) FIRST @ R0 @ - B/BUF 2+ U< ?EXIT B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF PREV @ OVER ! PREV ! ; : FREEBUFFER ( -- ) FIRST @ LIMIT B/BUF - U< IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; \ ENDPOINTS OF FORGET 04JAN85BP/KS) | : \? ( NFA -- FLAG ) C@ 020 AND ; | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? NAME> UNDER 1+ U< SWAP HEAP? OR ; | : ENDPOINTS ( ADDR -- ADDR SYMB) HEAP VOC-LINK @ >R BEGIN R> @ ?DUP \ THROUGH ALL VOCABS WHILE DUP >R 4 - >R \ LINK ON RETURNST. BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP R@ 2+ \? IF OVER R@ 2+ FORGET? IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB THEN REPEAT RDROP REPEAT ; \ REMOVE 23JUL85WE | CODE REMOVE ( DIC SYMB THR - DIC SYMB) 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY CLC UP )Y LDA 6 # ADC N 6 + STA INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC ]? CC ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? ]]? (DROP JMP END-CODE \ REMOVE- FORGET-WORDS 29APR85BP) | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; | : REMOVE-TASKS ( DIC --) UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) VOC-LINK REMOVE THRU.VOCSTACK DO 2DUP I @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP 2DUP CURRENT @ -ROT UWITHIN IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; \ FORGET-WORDS cas 26jan06 | : FORGET-WORDS ( DIC SYMB --) OVER REMOVE-TASKS REMOVE-VOCS REMOVE-WORDS HEAP SWAP - HALLOT DP ! 0 LAST ! ; \ DELETING WORDS FROM DICT. 13JAN83KS) : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" ENDPOINTS FORGET-WORDS ; : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; : EMPTY [ DP ] LITERAL @ UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; \ SAVE BYE STOP? ?CR 20OCT84KS/BP) : SAVE HERE UP@ FORGET-WORDS VOC-LINK @ BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL UP@ ORIGIN 0100 CMOVE ; : BYE FLUSH EMPTY (BYE ; | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; : ?CR COL C/L 0A - U> IF CR THEN ; \ IN/OUTPUT STRUCTURE 02MAR85BP) | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; : OUTPUT: CREATE ] DOES> OUTPUT ! ; 0 OUT: EMIT OUT: CR OUT: TYPE OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP : ROW ( -- ROW) AT? DROP ; : COL ( -- COL) AT? NIP ; | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; : INPUT: CREATE ] DOES> INPUT ! ; 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP \ ALIAS ONLY DEFINITIONEN 29JAN85BP) ONLY DEFINITIONS FORTH : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) ' ONLY ALIAS ONLY ' FORTH ALIAS FORTH ' WORDS ALIAS WORDS ' ALSO ALIAS ALSO ' DEFINITIONS ALIAS DEFINITIONS HOST TARGET \ 'COLD 07JUN85BP) cas 02aug2020| : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH ." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! ['] NOOP IS 'ABORT ABORT ; -2 ALLOT \ COLD BOOTSYSTEM RESTART 09JUL85WE) CODE COLD HERE >COLD ! ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA LABEL BOOTSYSTEM CLI 0 # LDY CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] LABEL WARMBOOT BOOTNEXTLEN 1- # LDY [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA PLA IP STA PLA IP 1+ STA LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE \ ( RESTART PARAM.-PASSING TO FORTH BP) CODE RESTART HERE >RESTART ! ' (RESTART >BODY 100 U/MOD # LDA PHA # LDA PHA WARMBOOT JMP END-CODE \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 \ Include system dependent Input / Output code \ (Keyboard and Screen) include systemio.fb HOST ' TRANSIENT 8 + @ TRANSIENT FORTH CONTEXT @ 6 + ! TARGET FORTH ALSO DEFINITIONS : FORTH-83 ; \ LAST WORD IN DICTIONARY \ SYSTEM DEPENDENT CONSTANTS BP/KS) VOCABULARY ASSEMBLER ASSEMBLER DEFINITIONS TRANSIENT ASSEMBLER PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK PUSH0A CONSTANT PUSH0A \ PUT A ON STACK PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK RP CONSTANT RP UP CONSTANT UP SP CONSTANT SP IP CONSTANT IP N CONSTANT N PUTA CONSTANT PUTA W CONSTANT W SETUP CONSTANT SETUP \ NEXT CONSTANT NEXT XYNEXT CONSTANT XYNEXT (2DROP CONSTANT POPTWO (DROP CONSTANT POP \ SYSTEM PATCHUP 05JAN85BP) cas 26jan06 FORTH DEFINITIONS \ change memory layout for stacks and buffers here 6000 ' LIMIT >BODY ! $5800 S0 ! $5B00 R0 ! S0 @ DUP S0 2- ! 6 + S0 7 - ! HERE DP ! HOST TUDP @ TARGET UDP ! HOST TVOC-LINK @ TARGET VOC-LINK ! HOST MOVE-THREADS \ No newline at end of file diff --git a/6502/py65/6502f83.fth b/6502/py65/6502f83.fth index 07c9fdc..1eda541 100644 --- a/6502/py65/6502f83.fth +++ b/6502/py65/6502f83.fth @@ -20,7 +20,7 @@ ende 123 \ *** Block No. 1, Hexblock 1 -\ volksFORTH Loadscreen for py65 target cas 15juli2020 +\ volksFORTH Loadscreen for py65 target cas 02aug2020 forth definitions : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE @@ -58,7 +58,7 @@ HERE DUP ORIGIN! \ *** Block No. 3, Hexblock 3 -\ Coldstartvalues and user variables cas 15juli2020 +\ Coldstartvalues and user variables cas 02aug2020 \ 0 JMP 0 JSR HERE 2- >LABEL >WAKE @@ -67,7 +67,7 @@ HERE DUP ORIGIN! 0D6 ALLOT \ Bootlabel -," VOLKSFORTH-83 3.8 py65 15july2020 CS" +," VolksForth-83 3.8.1 py65 02aug2020 CS" @@ -172,7 +172,7 @@ USER UDP \ POINTS TO NEXT FREE ADDR IN USER \ *** Block No. 9, Hexblock 9 -\ MANIPULATE SYSTEM POINTERS 29JAN85BP) +\ MANIPULATE SYSTEM POINTERS 29JAN85BP) cas 02aug2020 CODE SP@ ( -- ADDR) SP LDA N STA SP 1+ LDA N 1+ STA @@ -628,12 +628,12 @@ CODE U< ( U1 U2 -- FLAG) \ *** Block No. 33, Hexblock 21 -\ COMPARISION WORDS 24DEC83KS) +\ COMPARISION WORDS 24DEC83KS) cas 02aug2020 | : 0< 8000 AND 0<> ; : > ( N1 N2 -- FLAG) SWAP < ; -: 0> ( N -- FLAG) NEGATE 0< ; +: 0> ( N -- FLAG) DUP 0< SWAP 0= OR NOT ; : 0<> ( N -- FLAG) 0= NOT ; : U> ( U1 U2 -- FLAG) SWAP U< ; : = ( N1 N2 -- FLAG) - 0= ; @@ -2300,7 +2300,7 @@ HOST TARGET \ *** Block No. 121, Hexblock 79 -\ 'COLD 07JUN85BP) cas 15juli2020 +\ 'COLD 07JUN85BP) cas 02aug2020 | : INIT-VOCABULARYS VOC-LINK @ BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; @@ -2309,7 +2309,7 @@ HOST TARGET DEFER 'COLD ' NOOP IS 'COLD | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH - ." volksFORTH-83 3.8 py65 202007" CR RESTART ; -2 ALLOT + ." volksFORTH-83 3.8.1 py65 202008" CR RESTART ; -2 ALLOT DEFER 'RESTART ' NOOP IS 'RESTART | : (RESTART ['] (QUIT IS 'QUIT diff --git a/6502/py65/vfpy65.bin b/6502/py65/vfpy65.bin index 946c79e..622acef 100644 Binary files a/6502/py65/vfpy65.bin and b/6502/py65/vfpy65.bin differ diff --git a/8080/AmstradCPC/AMSDOS.SCR b/8080/AmstradCPC/AMSDOS.SCR new file mode 100644 index 0000000..0d69633 --- /dev/null +++ b/8080/AmstradCPC/AMSDOS.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 38K-CP/M, das mit den Standard 3" Floppylaufwerken und ohne Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Vortex-Laufwerke und/oder Speichererweiterung) kann es sein, dass die Firmware-Aufrufe anders organisiert sein muessen. (Siehe VDOS62KX.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer Standard 3" Laufwerk Amsdos UH 29Nov86 Assembler definitions Variable 'start Create jumprom \ Startaddr in 'start, returns like a subroutineAssembler H push 'start lhld xthl ret end-code ' noop Alias +org immediate \ No newline at end of file diff --git a/8080/AmstradCPC/ASS8080.SCR b/8080/AmstradCPC/ASS8080.SCR new file mode 100644 index 0000000..ce1c1b4 --- /dev/null +++ b/8080/AmstradCPC/ASS8080.SCR @@ -0,0 +1 @@ +\ VolksForth 8080 Assembler UH 09Mar86 Ideen lieferten: John Cassady Mike Perry Klaus Schleisiek Bernd Pennemann Dietrich Weineck \ VolksForth 8080 Assembler Load Screen UH 03Jun86Onlyforth Assembler also definitions hex 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr OnlyForth \ Vektorisierte Erzeugung UH 03Jun86Variable >codes | Create nrc ] c, , c@ here allot ! c! [ : nonrelocate ( -- ) nrc >codes ! ; nonrelocate | : >exec ( n -- n+2 ) Create dup c, 2+ does> c@ >codes @ + perform ; 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here | >exec >allot | >exec >! | >exec >c! drop \ Register und Definierende Worte UH 09Mar86 7 Constant A 0 Constant B 1 Constant C 2 Constant D 3 Constant E 0 Constant I 1 Constant I' 2 Constant W 3 Constant W' 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S | : 1MI Create >c, does> C@ >c, ; | : 2MI Create >c, does> C@ + >c, ; | : 3MI Create >c, does> C@ swap 8 * + >c, ; | : 4MI Create >c, does> C@ >c, >c, ; | : 5MI Create >c, does> C@ >c, >, ; \ Mnemonics UH 09Mar8600 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo EA 5MI jpe F2 5MI jp FA 5MI jm \ Spezial Mnemonics und Spruenge UH 09Mar86DA Constant C0= D2 Constant C0<> D2 Constant CS C2 Constant 0= CA Constant 0<> E2 Constant PE F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; : mov 8 * 40 + + >c, ; : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; : [[ ( -- addr ) >here ; \ BEGIN : ?] ( addr opcode -- ) >c, >, ; \ UNTIL : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE : ]? ( addr -- ) >here swap >! ; \ THEN : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE : ]] ( addr -- ) jmp ; \ AGAIN : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT \ Macros UH 14May86: end-code context 2- @ context ! ; : ;c: 0 recover call end-code ] ; : Next >next jmp ; : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; \ Definierende Worte UH 06Aug86Forth definitions : Code ( -- ) Create here dup 2- ! Assembler ; : ;Code ( -- ) 0 ?pairs compile [ ' does> >body 2+ @ , ] reveal [compile] [ Assembler ; immediate : >label ( adr -- ) here | Create swap , 4 hallot >here 4 - heap 4 cmove heap last @ (name> ! dp ! does> ( -- adr ) @ State @ IF [compile] Literal THEN ; : Label [ Assembler ] >here >label Assembler ; UH 14May86 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 % VolksForth 8080 Assembler UH 03Jun86 Der 8080 Assembler wurde von John Cassady, in den Forth Dimensions veroeffentlicht und von Mike Perry im F83 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat und auch Befehle zur strukturierten Assemblerprogrammierung. Um ein Wort in Assembler zu definieren wird das definierende Wort Code benutzt, es kann, muss aber nicht mit end-code beendetwerden. Wie der Assembler arbeitet ist ein interessantes Beispiel fuer die Maechtigkeit von Create does>. Am Anfang werden die Befehle in Klassen eingeteilt und fuer jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic des Befehls spaeter interpretiert wird, kompiliert er den entsprechenden Opcode. % Vektorisierte Erzeugung UH 09Mar86Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler Schaltet Assembler in den In-Line Modus. Definierendes Wort fuer Erzeugungs-Operator-Namen. Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden aktuellen Erzeugungsoperator aus. Mit diesen Erweiterungen kann der Assembler auch fuer den Target-Compiler benutzt werden. % Register und Definierende Worte UH 09Mar86 Die 8080 Register werden definiert. Es sind einfach Konstanten die Information fuer die Mnemonics hinterlassen. Einige Register der Forth-Maschine: IP ist BC, W ist DE Definierende Worte fuer die Mnemonics. Fast alle 8080 Befehle fallen in diese 5 Klassen. % Mnemonics UH 09Mar86Die 8080 Mnemonics werden definiert. % Spezial Mnemonics und Spruenge UH 09Mar86Vergleiche des 8080 not folgt einem Vergleich, wenn er invertiert werden soll. die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 einteilen lassen. Die strukturierten Assembler-Anweisungen. Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungenzu den strukturierten Anweisungen in Forth entstehen. Es findet keine Absicherung der Kontrollstrukturen statt, sodasssie auch beliebig missbraucht, werden koennen. Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. % Macros UH 17May86end-code beendet eine Code-Definition ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. Next Assembliert einen Sprung zum Adress-Interpretierer. rpush Das angegebene Register wird auf den Return-Stack gelegt. rpop Das angegebene Register wird vom Return-Stack genommen. rpush und rpop benutzen das HL Register. mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register Bewegt Registerpaare HL BC DE % Definierende Worte UH 17May86Code leitet eine Code-Definition ein. ;code ist das Low-Level-Aequivalent von does> >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert Label erzeugt ein Label auf dem Heap, mit dem Wert von here \ No newline at end of file diff --git a/8080/AmstradCPC/ASSTRAN.SCR b/8080/AmstradCPC/ASSTRAN.SCR new file mode 100644 index 0000000..4e1447f --- /dev/null +++ b/8080/AmstradCPC/ASSTRAN.SCR @@ -0,0 +1 @@ +\\ Transinient Assembler 11Nov86 Dieses File enthaelt Befehle, die den Assembler vollstaendig in den Heap laden, so dass er schliesslich mit clear wieder vergessen werden kann. Dadurch ist es nicht notwendig in einer Anwendung den ganzen Assembler im Speicher lassen zu muessen, nur weil einige primitive Worte in Assembler geschrieben sind. \ Internal Assembler UH 22Oct86 Onlyforth here $C00 hallot heap dp ! include ass8080.scr dp ! \ No newline at end of file diff --git a/8080/AmstradCPC/ATARI.SCR b/8080/AmstradCPC/ATARI.SCR new file mode 100644 index 0000000..cf39370 --- /dev/null +++ b/8080/AmstradCPC/ATARI.SCR @@ -0,0 +1 @@ +\ Anpassung an C64 und Atari-Graphic UH 03Dec86 Dieses File enthaelt im wesentlichen Umbenennungen der Grafik- routinen, da die Grafikpakete auf dem C64 und dem Atari zum Teil andere Namen verwenden, als die AMSTRAD Programmierer sie sich ausgedacht haben. Um die Atari und C64 Grafik-Demos weitgehend uebernehmen zu koennen wird also dieses Schicht zusaetzlich vom File GRAFDEMO.SCR geladen. \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' move Alias set ' line Alias draw ' mover Alias rset ' liner Alias rdraw : line ( x1 y1 x2 y2 -- ) set draw ; | Create cur 4 allot : cur.x ( -- addr ) cursor@ cur 2! cur 2+ ; : cur.y ( -- addr ) cursor@ cur 2! cur ; : home ( -- ) 0 0 move ; : exorwrite 1 access ; : overwrite 3 access ; --> \ Anpassung an C64 und Atari-Graphic UH 05Sep86 ' test Alias get.pixel ( x y -- p ) : put.pixel ( x y p -- ) pen plot ; : clip.window ( x1 y1 x2 y2 -- ) rot heigth width ; : unplot ( x y -- ) paper@ put.pixel ; 05Sep86 05Sep86 \ No newline at end of file diff --git a/8080/AmstradCPC/COPY.SCR b/8080/AmstradCPC/COPY.SCR new file mode 100644 index 0000000..30357c5 --- /dev/null +++ b/8080/AmstradCPC/COPY.SCR @@ -0,0 +1 @@ +\ Copy und Convey 19Nov87 Dieses File enthaelt Definitionen, die urspruenglich im Kern enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern klein zu halten. copy kopiert einen Screen convey kopiert einen Bereich von Screens \ moving blocks 20Oct86 19Nov87| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; | : fromblock ( blk -- adr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN full? IF save-buffers THEN offset @ + isfile@ rot fromblock 6 - 2! update ; | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to --) 1 blkmove ; : convey ( [blk1 blk2] [to.blk --) swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; \ No newline at end of file diff --git a/8080/AmstradCPC/DISASS.SCR b/8080/AmstradCPC/DISASS.SCR new file mode 100644 index 0000000..08ae90c --- /dev/null +++ b/8080/AmstradCPC/DISASS.SCR @@ -0,0 +1 @@ +\\ Z80-Disassembler 08Nov86 Dieses File enthaelt einen Z80-Disassembler, der assemblierten Code in Standard Zilog-Z80 Mnemonics umsetzt. Benutzung: TOOLS ALSO \ Schalte Disassembler-Vokabular an addr DIS \ Disassembliere ab Adresse addr xxxx displace ! \ Beruecksichte bei allen Adressen einen \ Versatz von xxxx. \ Wird gebraucht, wenn ein Assemblerstueck \ nicht an dem Platz disassembliert wird, \ an dem es ablaeuft. \ Z80-Disassembler Load Screen 08Nov86 Onlyforth Tools also definitions hex ' Forth | Alias F: immediate ' Tools | Alias T: immediate 1 $10 +THRU cr .( Disassembler geladen. ) cr OnlyForth \\ Fragen Anregungen & Kritik an: U. Hoffmann Harmsstrasse 71 2300 Kiel 1 \ Speicherzugriff und Ausgabe 07Jul86internal \needs Case: : Case: Create: Does> swap 2* + perform ; Variable index Variable address Variable offset Variable oldoutput external Variable displace displace off internal ' pad Alias str1 ( -- addr ) : str2 ( -- addr ) str1 $40 + ; : byte ( -- b ) address @ displace @ + c@ ; : word ( -- w ) address @ displace @ + @ ; : .byte ( byte -- ) 0 <# # #s #> type ; : .word ( addr -- ) 0 <# # # # #s #> type ; \ neue Bytes lesen Byte-Fraktionen 07Jul86 : next-byte output push oldoutput @ output ! byte .byte space 1 address +! ; : next-word next-byte next-byte ; : f ( -- b ) byte $40 / ; : g ( -- b ) byte 8 / 7 and ; : h ( -- b ) byte 7 and ; : j ( -- b ) g 2/ ; : k ( -- b ) g 1 and ; \\ 76543210 ffggghhh jjk \ Select" 08Nov86 : scan/ ( limit start -- limit start' ) over swap DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; : select ( n addr len -- addr' len' ) bounds rot 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN LOOP under scan/ nip over - ; : (select" ( n -- ) "lit count select type ; : select" ( -- ) compile (select" ," ; immediate : append ( c str -- ) under count + c! dup c@ 1+ swap c! ; \ StringOutput 07Jul86 Variable $ : $emit ( c -- ) $ @ append pause ; : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; : $cr ( -- ) $ @ off ; : $at? ( -- row col ) 0 $ @ c@ ; Output: $output $emit $cr $type noop $cr 2drop $at? ; \ Register 07Jul86 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN select" B/C/D/E/H/L/$/A" ; : double-reg ( n -- ) select" BC/DE/%/SP" ; : double-reg2 ( n -- ) select" BC/DE/%/AF" ; : num ( n -- ) select" 0/1/2/3/4/5/6/7" ; : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; : arith ( n -- ) select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; \ no-prefix Einteilung der Befehle in Klassen 07Jul86 : 00xxx000 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN select" nop/ex AF,AF'/djnz ?/jr ?" ; : 00xxx001 k IF ." add %," j double-reg exit THEN ." ld " j double-reg ." ,&" ; : 00xxx010 ." ld " g select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" ; : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; \ no-prefix 07Jul86 : 00xxx100 ." inc " g reg ; : 00xxx101 ." dec " g reg ; : 00xxx110 ." ld " g reg ." ,#" ; : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; : 01xxxxxx ." ld " g reg ." ," h reg ; : 10xxxxxx g arith h reg ; \ no-prefix 07Jul86 : 11xxx000 ." ret " g cond ; : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN ." pop " j double-reg2 ; : 11xxx010 ." JP " g cond ." ,&" ; : 11xxx011 g select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; : 11xxx100 ." call " g cond ; : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; : 11xxx110 g arith ." #" ; : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; \ no-prefix 07Jul86 Case: 00xxxhhh 00xxx000 00xxx001 00xxx010 00xxx011 00xxx100 00xxx101 00xxx110 00xxx111 ; Case: 11xxxhhh 11xxx000 11xxx001 11xxx010 11xxx011 11xxx100 11xxx101 11xxx110 11xxx111 ; : 00xxxxxx h 00xxxhhh ; : 11xxxxxx h 11xxxhhh ; Case: ffxxxxxx 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; \ no-prefix 07Jul86 : get-offset index @ 0> IF byte offset ! next-byte THEN ; : no-prefix f ffxxxxxx next-byte get-offset ; \ CB-Prefix 07Jul86 : CB-00xxxxxx g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; : CB-01xxxxxx ." bit " g num ." ," h reg ; : CB-10xxxxxx ." res " g num ." ," h reg ; : CB-11xxxxxx ." set " g num ." ," h reg ; case: singlebit CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; : CB-prefix get-offset f singlebit next-byte ; \ ED-Prefix 30Sep86: ED-01xxx000 ." in (C)," g reg ; : ED-01xxx001 ." out (C)," g reg ; : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN ." HL," j double-reg ; : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN ." (&)," j double-reg ; : ED-01xxx100 ." neg" ; : ED-01xxx101 k IF ." reti" exit THEN ." retn" ; : ED-01xxx110 g select" im 0/-/im 1/im 2" ; : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; Case: ED-01xxxhhh ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; : ED-01xxxxxx h ED-01xxxhhh ; \ ED-Prefix 07Jul86 Case: extended noop ED-01xxxxxx ED-10xxxxxx noop ; : ED-prefix get-offset f extended next-byte ; \ Disassassemblieren eines einzelnen Befehls 30Sep86 : index-register ( n -- ) index ! next-byte ; : get-instruction ( -- ) index off str1 $ ! cr byte $DD = IF 1 index-register ELSE byte $FD = IF 2 index-register THEN THEN byte $76 case? IF next-byte ." halt" exit THEN $CB case? IF next-byte CB-prefix exit THEN $ED case? IF next-byte ED-prefix exit THEN drop no-prefix ; \ Adressierungsarten ausgeben 07Jul86 27Nov87: .index-register ( -- ) index @ abs select" HL/IX/IY" ; : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; : .offset ( -- ) offset @ offset-sign extend under dabs <# # #s rot +- #> type ; : .index-register-offset index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; : .inline-byte ( -- ) byte .byte next-byte ; : .inline-word ( -- ) word .word next-word ; : .displace ( -- ) byte offset-sign address @ + 1+ .word next-byte ; \ Hauptebene: dis 07Jul86: .char ( c -- ) Ascii % case? IF .index-register exit THEN Ascii $ case? IF .index-register-offset exit THEN Ascii # case? IF .inline-byte exit THEN Ascii & case? IF .inline-word exit THEN Ascii ? case? IF .displace exit THEN emit ; : instruction ( -- ) cr address @ .word 2 spaces output @ oldoutput ! $output get-instruction str2 $ ! cr str1 count 0 ?DO count .char LOOP drop oldoutput @ output ! $20 col - 0 max spaces str2 count type ; external : dis ( addr -- ) address ! BEGIN instruction stop? UNTIL ; \ No newline at end of file diff --git a/8080/AmstradCPC/DOUBLE.SCR b/8080/AmstradCPC/DOUBLE.SCR new file mode 100644 index 0000000..a7c6663 --- /dev/null +++ b/8080/AmstradCPC/DOUBLE.SCR @@ -0,0 +1 @@ +\\ Double words 11Nov86 Dieses File enthaelt Worte fuer 32-Bit Objekte. Im Kern bereits enthalten sind: 2@ 2! 2dup 2drop 2swap dnegate d+ Hier werden definiert: 2Variable 2Constant 2over d* \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 : 2Variable Variable 2 allot ; : 2Constant Create , , does> 2@ ; Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi SP dad M D mov H dcx M E mov D push H dcx M D mov H dcx M E mov D push Next end-code --> \\ Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ d* d- 29Jun86 : d* ( d1 d2 -- d1*d2 ) rot 2over rot um* 2swap um* d+ 2swap um* d+ ; : d- ( d1 d2 -- d1-d2 ) dnegate d+ ; \ No newline at end of file diff --git a/8080/AmstradCPC/EDITOR.SCR b/8080/AmstradCPC/EDITOR.SCR new file mode 100644 index 0000000..6eedfcd --- /dev/null +++ b/8080/AmstradCPC/EDITOR.SCR @@ -0,0 +1 @@ +\ Full-Screen Editor UH 02Nov86 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 Onlyforth cr 1 $1E +thru Onlyforth \ String primitves 27Nov87 : delete ( buffer size count -- ) over umin dup >r - 2dup over r@ + -rot cmove + r> bl fill ; : insert ( string length buffer size -- ) rot over umin dup >r - over dup r@ + rot cmove> r> cmove ; : replace ( string length buffer size -- ) rot umin cmove ; \ usefull definitions and Editor vocabulary UH 27Nov87 : blank ( addr len -- ) bl fill ; : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; : ?abort( ( f -- ) IF [compile] .( true abort" !" THEN [compile] ( ; Vocabulary Editor ' Forth | Alias F: immediate ' Editor | Alias E: immediate Editor also definitions \ move cursor with position-checking 23Nov86 | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; \\ : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses UH 31Oct86 | Code *line ( l -- adr ) H pop H dad H dad H dad H dad H dad H dad Hpush jmp end-code | Code /line ( n -- c l ) H pop L A mov $3F ani A E mov 0 D mvi L A mov ral A L mov H A mov ral A H mov L A mov ral A L mov H A mov ral A H mov L A mov ral 3 ani H L mov A H mov dpush jmp end-code \\ | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; \ calculate addresses UH 01Nov86 | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 01Nov86 | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab \ 1/4 line forth cursor $10 / 1+ $10 * cursor - c ; | : -tab \ 1/8 line back cursor 8 mod negate dup 0= 8 * + c ; | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; | : #after c ; \ show border UH 27Nov87&15 | Constant dx 1 | Constant dy | : horizontal ( row -- row' ) dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii | emit row dx c/l + at Ascii | emit 1+ LOOP ; | : border dy 1- horizontal vertical horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; Forth definitions : updated? ( -- f) scr @ block 2- @ 0< ; \ display screen UH 02Nov86 UH 27Nov87Editor definitions | Variable isfile' | Variable imode | : .updated ( -- ) 7 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at imode @ IF ." insert " exit THEN ." overwrite" ; | : .screen l/s 0 DO I redisplay LOOP ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id UH 02Nov86 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : get-id ( -- ) id c@ ?exit id on cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at id id-len 2 /string expect rvsoff span @ id 1+ c! ; \ update screen-display UH 02Dec86 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor UH 02Dec86 UH 23Feb88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot ( | Variable imode ) imode off | : setimode imode on .title ; | : clrimode imode off .title ; | : flipimode ( -- ) imode @ 0= imode ! .title ; | : done ( -- ) ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 03Nov86 UH 27Nov87 | Variable r#' r#' off | Variable scr' scr' off ( | Variable isfile' ) isfile@ isfile' ! | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens UH 06Mar88 ' name >body &10 + | Constant 'name | : showoff ['] exit 'name ! curoff rvsoff ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! curoff edit-at curon stop? IF showoff true Abort" Break! " THEN blk @ scr @ - IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon rvson ['] .status >body push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings UH 01Nov86 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." |" &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: |" 'find get swap 1+ swap 2- at ." ? replace: |" 'insert get ; \ search for string UH 02Nov86 UH 27Nov87 | : skip ( addr -- addr' ) 'find c@ + ; | : find? ( -- addr T | F ) 'find count 'cursor #remaining "search ; | : "find ( -- r# scr ) find? IF skip 'start - scr @ exit THEN ?stamp capacity scr @ 1+ ?DO 'find count I dup 5 5 at 4 .r block b/blk "search IF skip I block - I endloop exit THEN stop? Abort" Break! " LOOP true Abort" not found!" ; \ replace strings UH 03Nov86 UH 27Nov87| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at rvson type rvsoff ; | : (replace 'insert c@ 'find c@ - ?fit 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert 'insert c@ c modified ; | : "replace get-buffers BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Control-Characters and special keys CPCs UH 04Dec86Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate $7F Constant #del Editor definitions \ Definition der Spezialtasten $F0 | Constant #up $F1 | Constant #down $F2 | Constant #left $F3 | Constant #right $E0 | Constant #copy $FC | Constant #esc | ' 4+ | Alias &s ( key -- key' ) | : &c ( key -- key' ) 8 + ; \ Try a Screen-Editor for CPCs UH 04Dec86 Create keytable #up c, #left c, #down c, #right c, #up &s c, #left &s c, #down &s c, #right &s c, Ctrl Q c, Ctrl Z c, Ctrl H c, Ctrl H c, #del c, Ctrl P c, #copy c, Ctrl D c, Ctrl T c, Ctrl I c, Ctrl O c, Ctrl C c, Ctrl E c, #cr c, #right &c c, #left &c c, #up &c c, #down &c c, Ctrl F c, Ctrl U c, Ctrl X c, #esc c, Ctrl L c, Ctrl W c, Ctrl N c, Ctrl B c, Ctrl A c, Ctrl R c, here keytable - Constant #keys \ Try a screen Editor UH 28Nov86 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char copyline copychar backspace backspace backspace delete-char insert-char delete-line insert-line setimode clrimode clear-line clear> +tab -tab top >""end "replace undo update-exit flushed-exit showload >shadow n b a mark ; here actiontable - 2/ 1- #keys - ?abort( # of actions) \ find keys UH 01Nov86 | Code findkey ( key -- addr/default ) H pop L A mov keytable H lxi #keys $100 * D lxi [[ M cmp 0= ?[ actiontable H lxi 0 D mvi D dad D dad M E mov H inx M D mov D push next ]? H inx E inr D dcr 0= ?] ' putchar H lxi hpush jmp end-code \\ | : findkey ( key -- adr/default ) #keys 0 DO dup keytable F: I + c@ = IF drop E: actiontable F: I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 02Nov86| Variable jingle jingle on | : bell 07 con! jingle off ; | : clear-error jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit BEGIN ?clearbuffer edit-at key dup char c! findkey execute clear-error REPEAT ; | : fullerror ( string --) jingle @ IF bell THEN dy l/s + 1+ dx $16 + at rvson count type rvsoff &80 col - spaces scr @ capacity 1- min 0 max scr ! .title quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor UH 02Nov86 Forth definitions : v ( -- ) E: 'start drop get-id install ?clearbuffer page curoff border .all quit ; : l ( scr -- ) 1 ?enough scr ! E: top F: v ; \ savesystem UH 27Nov87 : savesystem \ save image E: id off (pad off savesystem ; | : >find ?clearbuffer >in push bl word count 'find 1+ place bl 'find 1+ dup >r count dup >r + c! r> 2+ 'find c! bl r> c! ; : view ( --) >find ' >name 4- @ (view ?dup 0= Abort" hand made" scr ! E: top curdown find? 0= IF ." From Scr # " scr @ u. true Abort" wrong file" THEN skip 'start - 1- r# ! v ; \ No newline at end of file diff --git a/8080/AmstradCPC/FILEINT.SCR b/8080/AmstradCPC/FILEINT.SCR new file mode 100644 index 0000000..c969775 --- /dev/null +++ b/8080/AmstradCPC/FILEINT.SCR @@ -0,0 +1 @@ +\ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. Damit ist Zugriff auf normale CP/M-Files moeglich. Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, die mit dem Massenspeicher arbeiten, auf dieses File. Benutzung: USE \ benutze ein schon existierendes File FILE \ erzeuge ein Forthfile mit dem Namen . MAKE \ Erzeuge ein File mit und ordne \ es dem aktuellen Forthfile zu. MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen . INCLUDE \ Lade File mit Forthnamen ab Screen 1 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) \ CP/M 2.2 File-Interface load-Screen UH 18Feb88OnlyForth 2 load \ view numbers for this file 3 4 thru \ DOS File Functions 5 $11 thru \ Forth File Functions $12 $16 thru \ User Interface File source.scr \ Define already existing Files File fileint.scr File startup.scr ' (makeview Is makeview ' remove-files Is custom-remove ' file-r/w Is r/w ' noop Is drvinit \ include startup.scr \ load Standard System \ Build correct view-numbers for this file UUH 19Nov87 | : fileintview ( -- ) $400 blk @ + ; ' fileintview Is makeview \ File Control Blocks UH 18Feb88Dos definitions also | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; &11 Constant filenamelen 0 2 | Fcbyte nextfile immediate 1 Fcbyte drive ' drive | Alias >dosfcb filenamelen 3 - Fcbyte filename 3 Fcbyte extension &21 + \ ex, s1, s2, rc, d0, ... dn, cr 2 Fcbyte record \ r0, r1 1+ \ r2 2 Fcbyte opened 2 Fcbyte fileno 2 Fcbyte filesize \ in 128-Byte-Records 4 Fcbyte position Constant b/fcb \ dos primitives UH 10Oct87 ' 2- | Alias body> ' 2- | Alias dosfcb> : drive! ( drv -- ) $0E bdos ; : search0 ( dosfcb -- dir ) $11 bdosa ; : searchnext ( dosfcb -- dir ) $12 bdosa ; : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; : drive@ ( -- drv ) 0 $19 bdosa ; : killfile ( dosfcb -- ) $13 bdos ; \ File sizes UH 05Oct87 : (capacity ( fcb -- n ) \ filecapacity in blocks filesize @ rec/blk u/mod swap 0= ?exit 1+ ; : in-range ( block fcb -- ) (capacity u< not Abort" beyond capacity!" ; Forth definitions : capacity ( -- n ) isfile@ (capacity ; Dos definitions \ (open UH 18Feb88 : (open ( fcb -- ) dup opened @ IF drop exit THEN dup position 0. rot 2! dup >dosfcb openfile Abort" not found!" dup opened on dup >dosfcb size swap filesize ! ; : (make ( fcb -- ) dup >dosfcb killfile dup >dosfcb createfile Abort" directory full!" dup position 0. rot 2! dup filesize off opened on offset off ; : file-r/w ( buffer block fcb f -- f ) over 0= Abort" no Direct Disk IO supported! " >r dup (open 2dup in-range r> (r/w ; \ Print Filenames UH 10Oct87 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN fcb dosfcb> case? IF ." DEFAULT" exit THEN body> >name .name ; : .drive ( fcb -- ) drive c@ ?dup 0=exit [ Ascii A 1- ] Literal + emit Ascii : emit ; : .dosfile ( fcb -- ) dup filename 8 -trailing type Ascii . emit extension 3 type ; \ Print Filenames UH 10Oct87 : tab ( -- ) col &59 > IF cr exit THEN &20 col &20 mod - 0 max spaces ; : .fcb ( fcb -- ) dup fileno @ 3 u.r tab dup .file tab dup .drive dup .dosfile tab dup opened @ IF ." opened" ELSE ." closed" THEN 3 spaces base push decimal (capacity 3 u.r ." kB" ; \ Filenames UH 05Oct87 : !name ( addr len fcb -- ) dup >r filename filenamelen bl fill over 1+ c@ Ascii : = IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> ELSE 0 THEN r@ drive c! r> dup filename 2swap filenamelen 1+ min bounds ?DO I c@ Ascii . = IF drop dup extension ELSE I c@ over c! 1+ THEN LOOP 2drop ; : !fcb ( fcb -- ) dup opened off name count rot !name ; \ Print Directory UH 18Nov87 | Create dirbuf b/rec allot dirbuf b/rec erase | Create fcb0 b/fcb allot fcb0 b/fcb erase | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; | : (expand ( addr len -- ) false -rot bounds ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; | : expand ( fcb -- ) \ expand * to ??? dup filename 8 (expand extension 3 (expand ; : (dir ( addr len -- ) fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 BEGIN dup dos-error? not WHILE $20 * dirbuf + dosfcb> tab .dosfile fcb0 >dosfcb searchnext stop? UNTIL drop ; \ File List UH 10Oct87 User file-link file-link off | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; Forth definitions : forthfiles ( -- ) file-link @ BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; Dos definitions \ Close a file UH 10Oct87 ' save-buffers >body $0C + @ | Alias backup | : filebuffer? ( fcb -- fcb bufaddr/flag ) prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; | : flushfile ( fcb -- ) \ flush file buffers BEGIN filebuffer? ?dup WHILE dup backup emptybuf REPEAT drop ; : (close ( fcb -- ) \ close file in fcb dup flushfile dup opened dup @ 0= IF 2drop exit THEN off >dosfcb closefile Abort" not found!" ; \ Create fcbs UH 10Oct87 : !files ( fcb -- ) dup isfile ! fromfile ! ; ' r@ | Alias newfcb Forth definitions : File ( -- ) Create here >r b/fcb allot newfcb b/fcb erase last @ count $1F and newfcb !name #file newfcb fileno ! file-link @ newfcb nextfile ! r> file-link ! Does> !files ; : direct 0 !files ; \ flush buffers & misc. UH 10Oct87 UH 28Nov87Dos definitions : save-files ( -- ) file-link BEGIN @ ?dup WHILE dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; ' save-files Is save-dos-buffers \ : close-files ( -- ) file-link \ BEGIN @ ?dup WHILE dup (close REPEAT ; Forth definitions : file? isfile@ .file ; \ print current file : list ( n -- ) 3 spaces file? list ; \ words for viewing UH 10Oct87 Forth definitions | $200 Constant viewoffset \ max. %512 kB files : (makeview ( -- n ) \ calc. view filed for a name blk @ dup 0= ?exit loadfile @ ?dup IF fileno @ viewoffset * + THEN ; : (view ( blk -- blk' ) \ select file and leave block dup 0=exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup fileno @ = UNTIL !files drop ; \ not found: direct access \ FORGETing files UH 10Oct87 | : remove? ( dic symb addr -- dic symb addr f ) dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; | : remove-files ( dic symb -- dic symb ) \ flush files ! isfile@ remove? nip IF direct THEN fromfile @ remove? nip IF fromfile off THEN file-link BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT file-link remove ; \ print a list of all buffers UH 20Oct86 : .buffers prev BEGIN @ ?dup WHILE stop? abort" stopped" cr dup u. dup 2+ @ dup 1+ IF ." Block: " over 4+ @ 5 .r ." File : " [ Dos ] .file dup 6 + @ 0< IF ." updated" THEN ELSE ." Buffer empty" drop THEN REPEAT ; \ File Interface User words UH 11Oct87 | : same ( addr -- ) >in ! ; : open isfile@ (open offset off ; : close isfile@ (close ; : assign close isfile@ !fcb open ; : make isfile@ dup !fcb (make ; | : isfile? ( addr -- addr f ) \ is adr a fcb? file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; : use >in @ name find \ create a fcb if not present IF isfile? IF execute drop exit THEN THEN drop dup same File same ' execute open ; \ File Interface User words UH 25May88 : makefile >in @ File dup same ' execute same make ; : emptyfile isfile@ >dosfcb createfile ; : from isfile push use ; : loadfrom ( n -- ) isfile push fromfile push use load close ; : include 1 loadfrom ; : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; : files " *.*" count (dir ; : files" Ascii " word count 2dup upper (dir ; ' files Alias dir ' files" Alias dir" \ extend Files UH 20Nov87 | : >fileend isfile@ >dosfcb size drop ; | : addblock ( n -- ) \ add block n to file dup buffer under b/blk bl fill isfile@ rec/blk over filesize +! false file-r/w IF close Abort" disk full!" THEN ; : more ( n -- ) open >fileend capacity swap bounds ?DO I addblock LOOP close open close ; : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; 0 Drive: a: Drive: b: Drive: c: Drive: d: 5 + Drive: j: drop \ save memory-image as disk-file UH 29Nov86 Forth definitions : savefile ( from count -- ) \ filename isfile push makefile bounds ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" b/rec +LOOP close ; \ Status UH 10OCt87 : .blk ( -- ) blk @ ?dup 0=exit dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; ' .blk Is .status \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFDEMO.SCR b/8080/AmstradCPC/GRAFDEMO.SCR new file mode 100644 index 0000000..5dcc137 --- /dev/null +++ b/8080/AmstradCPC/GRAFDEMO.SCR @@ -0,0 +1 @@ +\ Grafik Demo UH 03Dec86Dieses File enthaelt im Wesentlichen die Definitionen der Grafikdemo vom C64 und vom Atari. Start mit INCLUDE GRAFDEMO.SCR An diesem Beispiel zeigt sich, dass sich mit volksFORTH relativ leicht Programme von einem auf den anderen Rechner uebertragen lassen, auch wenn die Basis (hier das Grafik-Paket) unterschied-lich ist. Natuerlich muss auf spezielle Eigenschaften des LINE-A-Grafic Pakets des Atari verzichtet werden. (z.B. gestrichelte Linien zeichen) Ist die Basis dagegen gleich, wie z.B der Kern aller volksFORTH Systeme, ist eine Uebernahme von Programmen gar kein Problem mehr. \ Demo Loadscreen 05Sep86 \needs Graphics include grafik.scr Onlyforth Graphics also definitions \needs exorwrite include atari.scr \ Atari Grafic-Name Layer \needs 2over include double.scr 1 $0A +thru \ clear moire \ muster kaleidos boxes \ poly lines \ tri.up tri.dn 25feb86 | : yscale [ decimal ] 400 640 */ [ hex ] ; : tri.dn ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - swap r@ - swap 2swap 2over set 2dup r@ yscale - swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; : tri.up ( dim -- ) >r cur.x @ cur.y @ 2dup r@ yscale - 2swap 2over set 2dup r@ yscale + swap r@ + swap draw 2dup r@ yscale + swap r> - swap draw 2swap draw set ; \ diamond UH 05Sep86 : diamond ( size -- ) >r cur.x @ cur.y @ 2dup swap r@ - swap 2swap 2over set 2dup r@ yscale - draw 2dup swap r@ + swap draw 2dup r> yscale + draw 2swap draw set ; | : big.diamond exorwrite &319 0 &639 &200 &319 &399 0 &200 4 polygon ; \ some usefull definitions 05Sep86 | : center &320 &200 set ; \ | : wrap #esc con! Ascii v con! ; wrap | : logo &117 0 DO ." volksFORTH 83 " LOOP ; | : wait BEGIN pause key? UNTIL &25 0 at getkey #cr = abort" stopped" ; | : titel &21 &24 at ." *** v o l k s F O R T H *** " &22 &31 at ." Line-A Graphic " ; \ patterns example 04Sep86\\ : muster page overwrite 1 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $10 I $10 * + dup $80 $80 rectangle LOOP 6 pat.mask ! $10 0 DO patterns I 2* + @ pattern ! $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP 1 pat.mask ! wait ; \ kaleidoskop UH 05Sep86 | : kaleid exorwrite home center \ patterns &30 + @ pattern ! 2 0 DO $40 1 DO $140 0 DO I diamond J 2* +LOOP 2 +LOOP LOOP ; : kaleidos page big.diamond kaleid wait ; : kaleid1 page logo kaleid wait ; : diamonds $10 0 DO \ patterns I 2* + @ pattern ! page big.diamond wait LOOP ; \ polygon example 05Sep86 | : (poly ( x y -- ) 2dup >r &100 + r> &10 + 2dup >r &10 + r> &90 + 2dup >r &30 - r> &20 + 2dup >r &50 - r> &35 - 2dup >r &30 - r> &85 - 6 polygon ; \\ : poly page invtrans &10 0 DO patterns I 5 + 2* + @ pattern ! I I * &5 * I &30 * (poly LOOP &10 0 DO patterns I 5 + 2* + @ pattern ! &510 I I * &5 * - I &30 * (poly LOOP wait ; \ moire 27feb86 : moire page curoff exorwrite &640 0 DO I &399 &639 I - 0 line 3 +loop &399 0 DO &639 &398 I - 0 I line 2 +loop titel wait ; \ boxes 05Sep86 : boxes page &162 0 DO I I set I I box &639 I 2* - I set I I box I &399 I 2* - set I I box &639 I 2* - &399 I 2* - set I I box 2 +LOOP wait ; \ linien 27feb86 | : (lines ( abstand -- ) exorwrite &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP dup +LOOP drop ; : lines page home curoff &45 (lines &90 (lines BEGIN &45 (lines key $FF and $0D = UNTIL &25 0 at ; \ moire punkte muster 05Sep86 : kreis.moire page &320 0 DO &199 0 DO I dup * J dup * + &300 / 1 and IF &320 J + &200 I + 1 put.pixel &320 J - &200 I + 1 put.pixel &320 J - &200 I - 1 put.pixel &320 J + &200 I - 1 put.pixel THEN 2 +LOOP LOOP wait ; \ No newline at end of file diff --git a/8080/AmstradCPC/GRAFIK.SCR b/8080/AmstradCPC/GRAFIK.SCR new file mode 100644 index 0000000..69d60ad --- /dev/null +++ b/8080/AmstradCPC/GRAFIK.SCR @@ -0,0 +1 @@ +\ Grafik UH 03Dec86 Diese File enthaelt Definitionen, die die von der Firmware der AMSTRAD-ROMS vorgegebenen Grafikmoeglichkeiten zur Verfuegung stellt. Die Namen der Worte sind an die im Schneider-Handbuch angege- benen Bezeichnungen angelehnt. Da je nach Systemkonfiguration die Schnittstelle zur Firmware anders aussieht, muss der entsprechende Systemteil geladen werden. Dies geschieht durch auskommentieren auf dem LOAD- Screen (Screen 1 von GRAFIK.SCR). Zur Zeit sind zwei Systemkonfigurationen unterstuetzt: 1) Standard 3" Laufwerk mit 38K-CP/M 2) Vortex-X Laufwerk mit 62K-CP/M Sie koennen als Beispiel fuer andere Systemteile dienen. \ Line Graphics Loadscreen UH 03Dec86 Onlyforth include vdos62kx.scr \ Vortex X-Laufwerk 62K-CP/M \ include amsdos.scr \ original Schneider 3" (Amsdos) 38K-CP/M 1 $08 +thru Onlyforth \ Calling ROM UH 29Nov86 Onlyforth Assembler also definitions Create rom IP push jumprom call IP pop ret end-code : getstart ( -- ) W inx xchg M E mov H inx M D mov xchg 'start shld ; \ Calling Operating-System UH 29Nov86Onlyforth Vocabulary OS Assembler also OS also definitions : Sys ( addr -- ) +org Constant ;code ( -- ) getstart rom call Next end-code : >Sys ( addr -- ) Sys ;code ( n -- ) getstart H pop L A mov rom call Next end-code : Sys> ( addr -- ) Sys ;code ( -- n ) getstart rom call A L mov 0 H mvi Hpush jmp end-code : >>Sys> ( addr -- ) Sys ;code ( x y -- n ) getstart H pop D pop rom call A L mov 0 H mvi Hpush jmp end-code \ Calling Operating-System UH 29Nov86 : >>Sys ( addr - ) Sys ;code ( x y -- ) getstart H pop D pop rom call Next end-code : Sys>> ( addr - ) Sys ;code ( -- x y ) getstart rom call dpush jmp end-code \ Graphic-calls UH 29Nov86Onlyforth Vocabulary Graphics OS also Graphics also definitions $BBBA Sys init $BBBD Sys reset $BBC0 >>Sys move $BBC3 >>Sys mover $BBC6 Sys>> cursor@ $BBC9 >>Sys origin $BBCC Sys>> origin@ $BBCF >>Sys width $BBD2 >>Sys heigth $BBD5 Sys>> width@ $BBD8 Sys>> heigth@ $BBDB Sys clearwindow $BBDE >Sys pen $BBE1 Sys> pen@ $BBE4 >Sys paper $BBE7 Sys> paper@ $BBEA >>Sys plot $BBED >>Sys plotr $BBF0 >>Sys> test $BBF3 >>Sys> testr $BBF6 >>Sys line $BBF9 >>Sys liner $BC59 >Sys access \ Farbwahl Graphic UH 29Nov86 Code (ink ( col1 col2 pen -- ) $BC32 +org H lxi 'start shld H pop L A mov H pop D pop IP push L B mov E C mov jumprom call IP pop Next end-code : ink ( colour -- ) dup pen@ (ink ; Code (ink@ ( pen -- col1 col2 ) $BC35 +org H lxi 'start shld H pop L A mov IP push jumprom call D pop 0 H mvi B L mov H push C L mov D IP mvx Hpush jmp end-code : ink@ ( -- col ) pen@ (ink@ drop ; \ Randfarben UH 29Nov86 Code border ( colour -- ) $BC38 +org H lxi 'start shld H pop IP push L B mov L C mov jumprom call IP pop Next end-code Code border@ ( -- colour ) $BC3B +org H lxi 'start shld IP push jumprom call 0 H mvi C L mov IP pop Hpush jmp end-code \ Schneider Farben 05Sep86\\ 0 Constant schwarz &13 Constant weiss 1 Constant blau &14 Constant pastellblau 2 Constant hellblau &15 Constant orange 3 Constant rot &16 Constant rosa 4 Constant magenta &17 Constant pastellmagenta 5 Constant hellviolett &18 Constant hellgruen 6 Constant hellrot &19 Constant seegruen 7 Constant purpur &20 Constant hellesblaugruen 8 Constant hellmagenta &21 Constant limonengruen 9 Constant gruen &22 Constant pastellgruen &10 Constant blaugruen &23 Constant pastellblaugruen &11 Constant himmelblau &24 Constant hellgelb &12 Constant gelb &25 Constant pastellgelb &26 Constant leuchtendweiss \ polygon box rectangle UH 29Nov86 : polygon ( x1 y1 x2 y2 ... xn yn n -- ) -rot 2dup >r >r move 1 DO line LOOP r> r> line ; : box ( width heigth -- ) 0 over liner over 0 liner 0 swap negate liner negate 0 liner ; : rectangle ( x1 y1 width heigth -- ) 2swap move box ; \ No newline at end of file diff --git a/8080/AmstradCPC/HASHCASH.SCR b/8080/AmstradCPC/HASHCASH.SCR new file mode 100644 index 0000000..a456b88 --- /dev/null +++ b/8080/AmstradCPC/HASHCASH.SCR @@ -0,0 +1 @@ +\ HashCash Suchalgorithmus UH 11Nov86 Ein Algorithmus, der die Dictionarysuche beschleunigt: Zuerst wird uebr das gesucht Wort gehasht und in in einer Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normalgesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchenherunter. Hinzu kommen die Worte: cash, hash-thread, erase-cash, 'cash, und found? Im Kernal neudefiniert oder gepatched werden muessen: (find, hide, reveal, forget-words (find und (forget benutzen jejweils die alten Worte. Sie muessenumbenannt oder in die neuen Worte eingebettet werden. \ Hash Cash fuer volksFORTH UH 11Nov86 Create cash $200 allot ' Forth >body Constant hash-thread : erase-cash ( -- ) cash $200 erase ; erase-cash 1 3 +thru patch (find ( patch forget-words ) ' forget-words \ forget-words dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen dup ' (forget >body $12 + ! \ Adresse, sodass das automa- dup ' empty >body 8 + ! \ tische Patchen nicht klappt. ' save >body 4+ ! patch hide patch reveal forget (patch save \ 'cash found? hfind UH 23Oct86 : 'cash ( nfa -- 'cash ) count $1F and under bounds ?DO I c@ + LOOP $FF and 2* cash + ; : found? ( str nfa -- f ) count rot count rot over = IF swap -text 0= exit THEN drop 2drop false ; : (find ( str thread -- str false | nfa true ) dup hash-thread - IF (find exit THEN drop dup 'cash @ 2dup found? IF nip true exit THEN drop hash-thread (find dup 0= ?exit over dup 'cash ! ; \ Kernal changes UH 23Oct86 ' hide >body @ | Alias last? : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; ' clear >body 6 + @ | Alias forget-words | : forget-words erase-cash forget-words ; : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; \ patching UH 23Oct86 : (patch ( new old -- ) ['] cash 0 DO i @ over = IF cr I u. over I ! THEN LOOP 2drop ; : patch \ name >in @ ' swap >in ! dup >name 2- context push context ! ' (patch ; \ No newline at end of file diff --git a/8080/AmstradCPC/INSTALL.SCR b/8080/AmstradCPC/INSTALL.SCR new file mode 100644 index 0000000..95552da --- /dev/null +++ b/8080/AmstradCPC/INSTALL.SCR @@ -0,0 +1 @@ +\\ Install Editor Dieses File enthaelt einen Installer fuer den Editor. Es werden nacheinander die Tasten erfragt, die einen bestimmten Befehl ausloesen sollen. Damit ist es moeglich, die Tastatur an die individuellen Beduerfnisse anzupassen. \ install Editor UH 17Nov86 Onlyforth Editor also save warning on : tab &20 col &20 mod - spaces ; : .key ( c -- ) dup $7E > IF ." $" u. exit THEN dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; : install \ install editor's keyboard page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" #keys 0 ?DO cr I 2* actiontable + @ >name .name tab ." : " I keytable + dup c@ .key tab ." -> " key dup bl = IF drop dup c@ THEN dup .key swap c! LOOP ; --> \ define action-names UH 28Nov86: :a ( addr -- adr' ) dup @ Alias 2+ ; actiontable :a up :a left :a down :a right :a push-line :a push-char :a pull-line :a pull-char :a copy-line :a copy-char :a backspace :a backspace :a backspace :a delete-char :a insert-char :a delete-line :a insert-line :a insert-on :a overwrite-on :a erase-line :a clear-to-right :a new-line :a +tab :a -tab :a home :a to-end :a search :a undo :a update-exit :a flushed-exit :a showload :a shadow-screen :a next-Screen :a back-Screen :a alter-Screen :a mark-screen drop warning off install empty UH 17Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/KERNEL.COM b/8080/AmstradCPC/KERNEL.COM new file mode 100644 index 0000000..c97e137 Binary files /dev/null and b/8080/AmstradCPC/KERNEL.COM differ diff --git a/8080/AmstradCPC/MATHE.SCR b/8080/AmstradCPC/MATHE.SCR new file mode 100644 index 0000000..e33ab02 --- /dev/null +++ b/8080/AmstradCPC/MATHE.SCR @@ -0,0 +1 @@ +\ Mathematics calculating sin & cos nach FD IV 1 6UH 03Dec86 Dieses File enthaelt Definitionen zur Berechnung von Integer-Sinus und -Cosinus. Sie werden z.B. von der Turtle-Grafik benutzt. \ Mathematics calculating sin & cos nach FD IV 1 6 05Sep86 Create sintab decimal 0000 , 0175 , 0349 , 0523 , 0698 , 0872 , 1045 , 1219 , 1392 , 1564 , 1736 , 1908 , 2079 , 2250 , 2419 , 2588 , 2756 , 2924 , 3090 , 3256 , 3420 , 3584 , 3746 , 3907 , 4067 , 4226 , 4384 , 4540 , 4695 , 4848 , 5000 , 5150 , 5299 , 5446 , 5592 , 5736 , 5878 , 6018 , 6157 , 6293 , 6428 , 6561 , 6691 , 6820 , 6947 , 7071 , 7193 , 7314 , 7431 , 7547 , 7660 , 7771 , 7880 , 7986 , 8090 , 8192 , 8290 , 8387 , 8480 , 8572 , 8660 , 8746 , 8829 , 8910 , 8988 , 9063 , 9135 , 9205 , 9272 , 9336 , 9397 , 9455 , 9511 , 9563 , 9613 , 9659 , 9703 , 9744 , 9781 , 9816 , 9848 , 9877 , 9903 , 9925 , 9945 , 9962 , 9976 , 9986 , 9994 , 9998 , 10000 , : sintable ( deg -- sine*10000 ) 2* sintab + @ ; --> \ sin 05Sep86 : s180 ( deg -- sine*10000 ) dup 90 > IF 180 swap - ( reflect ) THEN sintable ; : sin ( deg -- sine*10000 ) 360 mod dup 180 > IF 180 - s180 negate exit THEN s180 ; : cos ( deg -- cosine*10000 ) 90 + sin ; hex \ No newline at end of file diff --git a/8080/AmstradCPC/PORT8080.SCR b/8080/AmstradCPC/PORT8080.SCR new file mode 100644 index 0000000..c0bf563 --- /dev/null +++ b/8080/AmstradCPC/PORT8080.SCR @@ -0,0 +1 @@ +\ 8080-Portzugriff UH 11Nov86 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit Adressen anzusprechen. Der Code ist leider selbstmodifizierend, da beim 8080 die Portadresse im Code ausdruecklich angegeben werden muss. Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, kann auch das File portz80.scr benutzt werden, indem die Z80-IO-Befehle (16Bit-Adressen) benutzt werden. \ 8080-Portzugriff pc@, pc! 15Jul86 ' 0 | Alias patch Code pc@ ( addr -- c ) H pop L A mov here 4 + sta patch in 0 H mvi A L mov Hpush jmp end-code Code pc! ( c addr -- ) H pop L A Mov here 6 + sta H pop L A mov patch out Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PORTZ80.SCR b/8080/AmstradCPC/PORTZ80.SCR new file mode 100644 index 0000000..1e11c85 --- /dev/null +++ b/8080/AmstradCPC/PORTZ80.SCR @@ -0,0 +1 @@ +\ Z80-Portzugriff UH 05Nov86 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit Adressen anzusprechen. Einige Komputer, so die der Schneider Serie dekodieren ihre Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit Adressen angesprochen werden muessen. Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 Assembler definitions | : Z80-io ( base -- ) \ define special Z80-io instruction Create c, Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; $40 Z80-io (c)in $41 Z80-io (c)out Forth definitions --> \ store and fetch values with 16-bit port-adresses UH 05Nov86 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr H pop IP push H B mvx L (c)in 0 H mvi IP pop hpush jmp end-code Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr H pop D pop IP push H B mvx E (c)out IP pop Next end-code \ No newline at end of file diff --git a/8080/AmstradCPC/PRIMED.SCR b/8080/AmstradCPC/PRIMED.SCR new file mode 100644 index 0000000..e4194d3 --- /dev/null +++ b/8080/AmstradCPC/PRIMED.SCR @@ -0,0 +1 @@ +\\ Primitivst Editor zur Installation UH 17Nov86 Da zur Installationszeit der Full-Screen Editor noch nicht funtionsfaehig ist, muessen die zu aendernden Screens auf eine andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, der nur ein Benutzer wort enthaelt: Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, dann mit "ll NEW" den Screen aendern. Es koennen immer nur ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. Nach jeder Eingabe von RETURN wird die eingegebene Zeile in den Screen uebernommen, und der ganze Screen zur Kontrolle nocheinmal ausgegeben. \ primitivst Editor PRIMED UH 17Nov86 | : !line ( adr count line# -- ) scr @ block swap c/l * + dup c/l bl fill swap cmove update ; : new ( n -- ) l/s 1+ swap ?DO cr I . pad c/l expect span @ 0= IF leave THEN pad span @ I !line cr scr @ list LOOP ; \ PRIMED Demo-Screen Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender Eingabe dieses Textes Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit "0 NEW" erzeugt. Ulrich Hoffmann \ No newline at end of file diff --git a/8080/AmstradCPC/PRINTER.SCR b/8080/AmstradCPC/PRINTER.SCR new file mode 100644 index 0000000..b642433 --- /dev/null +++ b/8080/AmstradCPC/PRINTER.SCR @@ -0,0 +1 @@ +\\ Printer Interface 08Nov86 Dieses File enthaelt das Printer Interface zwischen volksFORTH und dem Drucker. Damit ist es moeglich Source-Texte auf bequeme Art und Weise in uebersichtlicher Form auszudrucken (6 auf eine Seite). In Verbindung mit dem Multitasker ist es moeglich, auch Texte imHintergrund drucken zu lassen und trotztdem weiterzuarbeiten. \ Printer Interface Epson RX80 18Aug86\ angepasst auf M 130i 07dec85we Onlyforth Variable shadow capacity 2/ shadow ! \ s. Editor Vocabulary Printer Printer definitions also | Variable printsem printsem off 01 +load 04 0C +thru \ M 130i - Printer \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer Onlyforth \ Printer p! and controls UH 02Nov87 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; : p! ( n --) BEGIN pause stop? IF printsem unlock true abort" stopped! " THEN ready? UNTIL [ Dos ] 5 bios ; | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi \ Printer Escapes 24dec85 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; \ Printer Escapes 29jan86 Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii P on: (10cpi Ascii P off: (12cpi : 10cpi (-17cpi (10cpi ; : 12cpi (-17cpi (12cpi ; : 17cpi (10cpi (+17cpi ; : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Escapes 16Jul86 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark Ascii 4 esc: +cursive Ascii 5 esc: -cursive Ascii M esc: 12cpi Ascii P | esc: (-12cpi : 10cpi (-12cpi (-17cpi ; : 17cpi (-12cpi (+17cpi ; ' 10cpi Alias pica ' 12cpi Alias elite \ Printer Escapes 16Jul86 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii p on: +prop Ascii p off: -prop : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Output 04Jul86 : prinit ; \ initializing Printer | Variable pcol pcol off | Variable prow prow off | : pemit ( 8b --) p! 1 pcol +! ; | : pcr ( --) RET LF 1 prow +! pcol off ; | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; | : ppage ( --) FF prow off pcol off ; | : pat ( row col --) over prow @ < IF ppage THEN swap prow @ - 0 ?DO pcr LOOP dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; | : pat? ( -- row col) prow @ pcol @ ; | : ptype ( adr len --) dup pcol +! bounds ?DO I c@ p! LOOP ; \ Printer output 28Jun86 | Output: >printer pemit pcr ptype pdel ppage pat pat? ; Forth definitions : print >printer normal ; : printable? ( char -- f) bl Ascii ~ uwithin ; \ Variables and Setup 23Oct86 Printer definitions $00 | Constant logo | Variable pageno | Create scr#s $0E allot \ enough room for 6 screens | : header ( -- ) 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " 5 spaces file? -dark 1 pageno +! 17cpi ; \ Print 2 screens across on a page 03dec85 | : text? ( scr# -- f) block dup c@ printable? IF b/blk -trailing nip 0= THEN 0= ; | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN 1 scr#s +! scr#s dup @ 2* + ! ; | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r pad $101 bl fill swap block r@ + pad c/l cmove block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark cr l/s 0 DO 2dup I 2pr LOOP 2drop ; \ Printer 6 screens on a page 03dec85 | : pr-start ( --) scr#s off 1 pageno ! ; | : pagepr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; | : shadowpr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; | : pr-flush ( -- f) scr#s @ dup \ any screens left over? IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN 0<> ; \ Printer 6 screens on a page 23Nov86Forth definitions : pthru ( first last --) printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN LOOP pr-flush IF pagepr THEN printsem unlock ; : document ( first last --) isfile@ IF capacity 2/ shadow ! THEN printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr I shadow @ + pr THEN scr#s @ 6 = IF shadowpr THEN LOOP pr-flush IF shadowpr THEN printsem unlock ; : listing ( --) 0 capacity 2/ 1- document ; \ Printerspool 03Nov86 \needs Task \\ | Input: noinput 0 false drop 2drop ; $100 $200 noinput Task spooler keyboard : spool ( from to -- ) isfile@ spooler 3 pass isfile ! pthru stop ; \ No newline at end of file diff --git a/8080/AmstradCPC/README-german.org b/8080/AmstradCPC/README-german.org new file mode 100644 index 0000000..46fb2ff --- /dev/null +++ b/8080/AmstradCPC/README-german.org @@ -0,0 +1,129 @@ +Änderungen im CP/M-volksFORTH von Version 3.80 zu Version 3.80a UH 04Mär88 +============================================================================= + +Die Unverträlichkeit des ursprünglichen CP/M-volksFORTHs mit CP/M+ und die +damit verbundene Vielzahl von unterschiedlichen Versionen hat eine allgmeine +Ãœberarbeitung des CP/M-volksFORTHs notwendig gemacht. + +Bei dieser Gelegenheit wurden gleich einige Fehler beseitigt und einige +neue Funktionen eingeführt. + +1. Änderungen im Kern (SOURCE.SCR) + + - Die Terminal-Ein- und Ausgabe wurde auf ein Mindestmaß begrenzt, + sodaß auch unmittelbar mit dem Kern gearbeitet werden kann. Es + gibt keinen Zeileneditor für die Eingabezeile mehr, dieser wurde + zusammen mit der "Terminal:" Funktion in die Datei XINOUT.SCR + ausgelagert. + + - Der Kern enthält kein Fileinterface mehr, sondern arbeitet nur + in dem File, welches bei Aufruf in der Kommandozeile mit + angegeben wird (default-file). Typischerweise wird mit diesem + Mechanismus zuerst das File-Interface geladen. + + - Direkter Diskettenzugriff wird im Kern nicht mehr unterstützt, + da er unter CP/M+ nicht problemlos zu implementieren ist. + Außerdem kann in Ermangelung eines CP/M+ Systems der Code hier + nicht getestet werden. Diskettenzugriff findet nur noch über das + BDOS statt. + + - Zahlreiche Funktionen des Kerns wurden neu überarbeitet und in + Code geschrieben, als wichtige neue Funktion des Kerns ist + "search" hinzugekommen, das eine schnelle Suche mit + Berücksichtigung der Groß/Klein- schreibung ermöglicht. + + - Die Funktion CAPITALIZE ist durch die ähnliche Funktion UPPER + ersetzt worden. Das EXIT in NAME verschiebt sich dadurch. + + - Der Kern gibt beim Verlassen eine Größenangabe in (256 + Byte)-Seiten aus. Diese Angabe kann direkt benutzt werden, um + mit dem CP/M =SAVE= Kommando das System auf Diskette zu schreiben. + (Forth: =SAVE= nicht vergessen! ) + + - SAVE-BUFFERS ist um ein defered Wort SAVE-DOS-BUFFERS erweitert + worden. Damit sollte der lästige CP/M+ Fehler ausgeschaltet + sein. + + - Das defered Wort POSTLUDE regelt die letzte Handlung des Systems + vor dem CP/M Warmstart (Cursor anschalten, Bildschirm löschen + oder Systemgröße ausgeben...) + + - Die Kommandozeile des Aufrufs wird in den TIB kopiert und kann + dort interpretiert werden. Das Öffnen des default-Files löscht + allerdings den TIB wieder, sodaß diese Funktion erst ausgenutzt + werden kann, wenn das Fileinterface geladen ist. (DRVINIT öffnet + nicht mehr das default-File.) + + - Die Interpret-Loop wurde überarbeitet und um das Wort PROMPT + erweitert. Das Sonderwort >INTERPRET ist weggefallen. Seine + Funktion übernimmt jetzt das (normale) defered Wort PARSER. + + - Die Kontrollstruktur-Anweisungen (IF, WHILE ... ) sind jetzt + auch inter- aktiv verwendbar. + + - Diverse kleinere Änderungen haben stattgefunden. + + +2. Änderungen im Editor (Dateien =EDITOR.SCR=, =STRING.SCR=) + + - Das Markieren der Screens wurde korrigiert und geschieht jetzt + auch beim Suchen/Ersetzen und bei =showload= richtig. + + - =VIEW= wurde geändert und sucht nun nach dem in Blanks + eingerahmten Wort. + + - Es wird nun zusätzlich das Associative File angezeigt. + + - Beim Suchen/Ersetzen wird die Screennummer hochgezählt, um eine + Kontrolle über das Suchen zu geben. + + - Die Textsuche ist nun schon im Kern definiert, die elementaren + Stringfunktionen sind mit in das EDITOR.SCR genommen worden. + STRING.SCR ist daher entfallen. + +3. Änderungen im Multi-Tasker (TASKER.SCR) + + - Das Wort TASK wurde geändert: Die Konstante ist nun vor der Task + definiert. Man kann also nun mit FORGET tatsächlich + die Task vergessen. + + - Der PAUSE/WAKE/STOP-Mechanismus wurde geändert. In der Benutzung + ergibt sich daraus keine Änderung. + +4. Änderungen im Fileinterface (FILEINT.SCR) + + - Das Fileinterface wurde überarbeitet und einige Fehler + beseitigt. Die Namen zahlreicher Worte haben sich geändert, sind + dadurch aber systematischer geworden. Die Funktionen sind im + Wesentlichen gleich geblieben. + + +5. Terminal-Installation (Zusatz zu Anpassung von VolksForth an den Computer) + + - Da der Kern kein Fileinterface mehr enthält, muß dies noch vor + dem Primitivst-Editor geladen werden. Es ergibt sich also die + Kommandosequenz: + #+begin_example + A> kernel fileint.scr + 1 load + use primed.scr 1 load + use terminal.scr + #+end_example + +6. Erstellen eines Standard-Systems + + - Mit folgender Kommandosequenz wird aus =KERNEL.COM= das File + =VOLKS4TH.COM= gemacht: + #+begin_example + A> kernel fileint.scr + 1 load + include startup.scr + #+end_example + +7. Neue Dateien auf der Diskette + + - READ.ME diese Datei + - XINOUT.SCR Terminalfunktionen und Zeileneditor für Eingabe + - COPY.SCR Die Funktionen COPY und CONVEY (früher im Kern). + + - STRING.SCR Entfällt, da in EDITOR.SCR und SOURCE.SCR integriert. diff --git a/8080/AmstradCPC/RELOCATE.SCR b/8080/AmstradCPC/RELOCATE.SCR new file mode 100644 index 0000000..832e6bd --- /dev/null +++ b/8080/AmstradCPC/RELOCATE.SCR @@ -0,0 +1 @@ +\\ Relocate System 11Nov86 Dieses File enthaelt das Utility-Wort BUFFERS. Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, die volksFORTH benutzt. Voreingestellt sind 4 Buffer. Benutzung: nn BUFFERS \ Relocate a system 16Jul86 | : relocate-tasks ( mainup -- ) up@ dup BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; | : relocate ( stacklen rstacklen -- ) 2dup + b/buf + 2+ limit origin - u> abort" kills all buffers" over pad $100 + origin - u< abort" cuts the dictionary" dup udp @ $40 + u< abort" a ticket to the moon with no return ..." flush empty over + origin + origin $0A + ! \ r0 origin + dup relocate-tasks \ multitasking link 6 - origin 8 + ! \ s0 cold ; --> \ bytes.more buffers 29Jun86 | : bytes.more ( n+- -- ) up@ origin - + r0 @ up@ - relocate ; : buffers ( +n -- ) b/buf * 4+ limit r0 @ - swap - bytes.more ; \ No newline at end of file diff --git a/8080/AmstradCPC/SAVESYS.SCR b/8080/AmstradCPC/SAVESYS.SCR new file mode 100644 index 0000000..a07add8 --- /dev/null +++ b/8080/AmstradCPC/SAVESYS.SCR @@ -0,0 +1 @@ +\\ savesystem 11Nov86 Dieses File enthaelt das Utility-Wort SAVESYSTEM. Mit ihm kann man das gesamte System als File auf Disk schreiben. Achtung: Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM der Heap geloescht! Benutzung: SAVESYSTEM \ savsystem 05Nov86 : savesystem \ filename save $100 here over - savefile ; \\ Einfaches savesystem 18Aug86 | : message ( -- ) base push decimal cr ." ready for SAVE " here 1- $100 / u. ." VOLKS4TH.COM" cr ; : savesystem ( -- ) save message bye ; \ No newline at end of file diff --git a/8080/AmstradCPC/SEE.SCR b/8080/AmstradCPC/SEE.SCR new file mode 100644 index 0000000..d91fa7d --- /dev/null +++ b/8080/AmstradCPC/SEE.SCR @@ -0,0 +1 @@ +\ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 Dieses File enthaelt einen Decompiler, der bereits kompilierte Worte wieder in Sourcetextform bringt. Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang erkannt und umgeformt. Ein Decompiler kann aber keine (Stack-) Kommentare wieder herzaubern, die Benutzung der Screens und dann view, wird daher staerkstens empfohlen. Denn: Es ist immernoch ein Fehler drin! Und um den zu korrigieren, ist der Sourcetext dem Objektkode doch vorzuziehen. Benutzung: see \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 Onlyforth Tools also definitions 1 13 +thru \\ Produces compilable Forth source from normal compiled Forth. These source blocks are based on the works of Henry Laxen, Mike Perry and Wil Baden volksFORTH version: U. Hoffmann \ detacting does> 01Jul86 internal ' does> 4+ @ Alias (;code ' Forth @ 1+ @ Constant (dodoes> : does? ( IP - f ) dup c@ $CD ( call ) = swap 1+ @ (dodoes> = and ; \ indentation. 04Jul86Variable #spaces #spaces off : +in ( -- ) 3 #spaces +! ; : -in ( -- ) -3 #spaces +! ; : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; \ case defining words 01Jul86 : Case: ( -- ) Create: Does> swap 2* + perform ; : Associative: ( n -- ) Constant Does> ( n - index ) dup @ -rot dup @ 0 DO 2+ 2dup @ = IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; \ branching 04Jul86 Variable #branches Variable #branch : branch-type ( n -- a ) 6 * pad + ; : branch-from ( n -- a ) branch-type 2+ ; : branch-to ( n -- a ) branch-type 4+ ; : branched ( adr type -- ) \ Make entry in branch-table. #branches @ branch-type ! dup #branches @ branch-from ! 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } \ branching 01Jul86 : branch-back ( adr type -- ) \ : make entry in branch-table & reclassify branch-type.) over swap branched 2+ dup dup @ + swap 2+ ( loop-start,-end.) 0 #branches @ 1- ?DO over I branch-from @ u> IF LEAVE THEN dup I branch-to @ = IF ['] while I branch-type ! THEN -1 +LOOP 2drop ; \ branching 01Jul86: forward? ( ip -- f ) 2+ @ 0> ; : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] if branched exit THEN ['] until branch-back ; : branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] else branched exit THEN ['] repeat branch-back ; : (loop)+ ( ip -- ip' ) dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; : string+ ( ip -- ip' ) 2+ count + even ; : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; \ classify each word 25Aug86Forth &15 Associative: execution-class ] clit lit ?branch branch (do (." (abort" (;code (" (?do (loop (+loop unnest (is compile [ Case: execution-class+ 3+ 4+ ?branch+ branch+ 2+ string+ string+ (;code+ string+ 2+ 4+ 4+ 0= 4+ 4+ 2+ ; Tools \ first pass 01Jul86 : pass1 ( cfa -- ) #branches off >body BEGIN dup @ execution-class execution-class+ dup 0= stop? or UNTIL drop ; \ identify branch destinations. 04Jul86: thru.branchtable ( -- limit start ) #branches @ 0 ; : ?.then ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< IF I branch-type @ dup ['] else = swap ['] if = or IF -in ." THEN " ind-cr LEAVE THEN THEN THEN LOOP ; : ?.begin ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< not IF I branch-type @ dup ['] repeat = swap ['] until = or IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN LOOP ; ( put "BEGIN" and "THEN" where used.) \ decompile each type of word 01Jul86 : .word ( ip -- ip' ) dup @ >name .name 2+ ; : .(word ( ip -- ip' ) dup @ >name ?dup 0= IF ." ??? " ELSE count $1f and swap 1+ swap 1- type space THEN 2+ ; : .inline ( val16b -- ) dup >name ?dup IF ." ['] " .name drop exit THEN . ; : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; : .string ( ip -- ip' ) .(word count 2dup type Ascii " emit space + even ?.then ; : .unnest ( ip -- 0 ) ." ; " 0= ; \ decompile each type of word 01Jul86 : .default ( ip -- ip' ) dup @ >name ?dup IF c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; : .compile ( ip -- ip' ) .word .word ?.then ; \ decompiling conditionals 04Jul86 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; 5 Associative: branch-class ' if , ' while , ' else , ' repeat , ' until , Case: .branch-class .if .else .else .repeat .repeat ; : .branch ( ip -- ip' ) #branch @ branch-type @ 1 #branch +! dup >name swap branch-class .branch-class ; \ decompile Does> ;code 04Jul86 : .(;code ( IP - IP' f) 2+ dup does? IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; \ classify word's output 01Jul86 Case: .execution-class .clit .lit .branch .branch .do .string .string .(;code .string .do .loop .loop .unnest .['] .compile .default ; \ decompile colon-definitions 04Jul86 : pass2 ( cfa -- ) #branch off >body BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class dup 0= stop? or UNTIL drop ; : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; : .immediate ( cfa - ) >name c@ dup ?ind-cr 40 and IF ." IMMEDIATE " THEN ?ind-cr 80 and IF ." RESTRICT" THEN ; : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; \ display category of word 01Jul86external Defer (see internal : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; : .user-variable ( cfa - ) ." USER " dup >name dup .name 3 spaces swap execute @ u. .name ." ! " ; : .defer ( cfa - ) ." deferred " dup >name .name ." Is " >body @ (see ; : .other ( cfa - ) dup >name .name dup @ over >body = IF drop ." is Code " exit THEN dup @ does? IF .does> exit THEN drop ." is unknown " ; \ decompiling variables and constants 01Jul86 : .constant ( cfa - ) dup >body @ u. ." CONSTANT " >name .name ; : .variable ( cfa - ) ." VARIABLE " dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; \ classify a word UH 25Jan88 5 Associative: definition-class ' quit @ , ' 0 @ , ' scr @ , ' base @ , ' 'cold @ , Case: .definition-class .: .constant .variable .user-variable .defer .other ; \ Top level of Decompiler 04Jul86 external : ((see ( cfa -) #spaces off cr dup dup @ definition-class .definition-class .immediate ; ' ((see Is (see Forth definitions : see ' (see ; \ No newline at end of file diff --git a/8080/AmstradCPC/SIMPFILE.SCR b/8080/AmstradCPC/SIMPFILE.SCR new file mode 100644 index 0000000..1fd4b38 --- /dev/null +++ b/8080/AmstradCPC/SIMPFILE.SCR @@ -0,0 +1 @@ +\\ Simple Files 11Nov86 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es trotzdem wuenschenswert eine Art File-Struktur zu besitzen. Dieses File enthaelt eine einfache Implementation eines Filesystems. Der/die Programmierer/in muss selbst die Direktory auf dem laufenden halten: in ihr sind die Start-Bloecke des entsprechenden Diskettenteils gespeichert. Sogar eine Hierarchie von Direktories laesst sich so relisieren. Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). \ simple files 12feb86 \needs search .( search missing) \\ | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root | : read" ( -- n) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in push >in ! bl dir block b/blk (word number drop ; : load" read" dir + load ; : dir" read" (dir +! ; : list" read" dir + list ; \ 1 +load \ Only if file" is needed \ simple files 01feb86 | : snap ( n0 -- n1) $20 / 3 max $20 * ; : file" ( n --) Ascii " word count 2dup dir block b/blk search IF + nip ELSE drop dir block b/blk -trailing nip snap $20 + dup b/blk 1- > abort" directory full" 2dup + >r dir block + swap cmove r> THEN snap $18 + >r dir - extend under dabs <# # # # # base @ $0A = IF Ascii & ELSE Ascii $ THEN hold rot 0< IF Ascii - ELSE bl THEN hold #> r> dir block + swap cmove update ; \ dir load" 11feb86 \needs search .( search missing) \\ 0 Constant dir : load" ( -- ) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in @ blk @ rot >in ! dir blk ! bl word number drop -rot blk ! >in ! load ; \ No newline at end of file diff --git a/8080/AmstradCPC/SOURCE.SCR b/8080/AmstradCPC/SOURCE.SCR new file mode 100644 index 0000000..1ee646d --- /dev/null +++ b/8080/AmstradCPC/SOURCE.SCR @@ -0,0 +1 @@ +\\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck, U. Hoffmann Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann Dieses File enthaelt den kompletten Sourcetext des Kern-Systems fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- System erzeugt, daher finden sich an einigen Stellen Anweisungenan den Target-Compiler, die fuer das Verstaendnis des Systems nicht wichtig sind. Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. \ CP/M 2.2 volksForth Load Screen 27Nov87 Onlyforth $9000 displace ! Target definitions $100 here! 1 $74 +thru \ Standard 8080-System cr .( unresolved: ) .unresolved ( ' .blk is .status ) save-target KERNEL.COM \ FORTH Preamble and ID 04Oct87 Assembler nop 0 jmp here 2- >label >boot nop 0 jmp here 2- >label >cold nop 0 jmp here 2- >label >restart here dup origin! \ Hier beginnen die Kaltstartwerte der Benutzervariablen 6 rst 0 jmp end-code \ for multitasker $100 allot | Create logo ," volksFORTH-83 rev. 3.80a" \ Assembler Labels Next Forth-Register 29Jun86 Label dpush D push Label hpush H push Label >next IP ldax IP inx A L mov IP ldax IP inx A H mov Label >next1 M E mov H inx M D mov xchg pchl end-code Variable RP Variable UP \ IP in BC \ W in DE \ SP in SP Variable IPsave \ Assembler Macros 20Oct86Compiler Assembler also definitions Forth : Next T >next jmp [ Forth ] ; T hpush Forth Constant hpush T dpush Forth Constant dpush T >next Forth Constant >next : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld [ Forth ] ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld [ Forth ] ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; Target \ recover ;c: noop 20Oct86 Create recover Assembler W pop IP rpush W IP mvx Next end-code Compiler Assembler also definitions Forth : ;c: 0 T recover call end-code ] [ Forth ] ; Target | Code di di Next end-code | Code ei ei Next end-code Code noop >next here 2- ! end-code \ User variables 04Oct87 Constant origin 8 uallot drop \ Multitasker \ Felder: entry link spare SPsave \ Laenge kompatibel zum 68000 und 6502 volksFORTH User s0 User r0 User dp User offset 0 offset ! User base $0A base ! User output User input User errorhandler \ pointer for Abort" -code User voc-link User udp \ points to next free addr in User \ manipulate system pointers 11Jun86 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code Code sp! ( addr --) H pop sphl Next end-code Code up@ ( -- addr) UP lhld hpush jmp end-code Code up! ( addr --) H pop UP shld Next end-code \ manipulate returnstack 11Jun86 Code rp@ ( -- addr ) RP lhld hpush jmp end-code Code rp! ( addr -- ) H pop RP shld Next end-code Code >r ( 16b -- ) D pop D rpush Next end-code restrict Code r> ( -- 16b ) D rpop D push Next end-code restrict \ r@ rdrop exit unnest ?exit 07Oct87Code r@ ( -- 16b ) RP lhld M E mov H inx M D mov D push Next end-code Code rdrop RP lhld H inx H inx RP shld Next end-code restrict Code exit Label >exit IP rpop Next end-code Code unnest >exit here 2- ! Code ?exit ( flag -- ) H pop H A mov L ora >exit jnz Next end-code Code 0=exit ( flag -- ) H pop H A mov L ora >exit jz Next end-code \ : ?exit ( flag -- ) IF rdrop THEN ; \ execute perform 11Jun86 18Nov87 Code execute ( cfa -- ) H pop >Next1 jmp end-code Code perform ( 'cfa -- ) H pop M A mov H inx M H mov A L mov >Next1 jmp end-code \\ : perform ( addr -- ) @ execute ; \ c@ c! ctoggle 07Oct87 Code c@ ( addr -- 8b ) H pop M L mov 0 H mvi hpush jmp end-code Code c! ( 16b addr -- ) H pop D pop E M mov Next end-code Code flip ( 16b1 -- 16b2 ) H pop H A mov L H mov A L mov Hpush jmp end-code Code ctoggle ( 8b addr -- ) H pop D pop M A mov E xra A M mov Next end-code \\ : ctoggle ( 8b addr --) under c@ xor swap c! ; \ @ ! 2@ 2! 11Jun86 18Nov87 Code @ ( addr -- 16b ) H pop Label fetch M E mov H inx M D mov D push Next end-code Code ! ( 16b addr -- ) H pop D pop E M mov H inx D M mov Next end-code Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ +! drop swap 11Jun86 18Nov87 Code +! ( 16b addr -- ) H pop Label +store D pop M A mov E add A M mov H inx M A mov D adc A M mov Next end-code \ : +! ( n addr -- ) under @ + swap ! ; Code drop ( 16b -- ) H pop Next end-code Code swap ( 16b1 16b2 -- 16b2 16b1 ) H pop xthl hpush jmp end-code \ dup ?dup 16May86 Code dup ( 16b -- 16b 16b ) H pop H push hpush jmp end-code Code ?dup ( 16b -- 16b 16b / false) H pop H A mov L ora 0<> ?[ H push ]? hpush jmp end-code \\ : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; : dup ( 16b -- 16b 16b ) sp@ @ ; \ over rot nip under 11Jun86 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) D pop H pop H push dpush jmp end-code Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) D pop H pop xthl dpush jmp end-code Code nip ( 16b1 16b2 -- 16b2) H pop D pop hpush jmp end-code Code under ( 16b1 16b2 -- 16b2 16b1 16b2) H pop D pop H push dpush jmp end-code \\ : over >r swap r> swap ; : rot >r dup r> swap ; : nip swap drop ; : under swap over ; \ -rot pick roll -roll 11Jun86Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) H pop D pop xthl H push D push Next end-code Code pick ( n -- 16b.n ) H pop H dad SP dad M E mov H inx M D mov D push Next end-code : roll ( n -- ) dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; : -roll ( n -- ) >r dup sp@ dup 2+ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; \\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; \ double word stack manipulation 09May86Code 2swap ( 32b1 32b2 -- 32b2 32b1) H pop D pop xthl H push 5 H lxi SP dad M A mov D M mov A D mov H dcx M A mov E M mov A E mov H pop dpush jmp end-code Code 2drop ( 32b -- ) H pop H pop Next end-code Code 2dup ( 32b -- 32b 32b) H pop D pop D push H push dpush jmp end-code \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; : 2drop ( 32b -- ) drop drop ; : 2dup ( 32b -- 32b 32b) over over ; \ + and or xor not 09May86Code + ( n1 n2 -- n3 ) H pop D pop D dad hpush jmp end-code Code or ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ora A H mov L A mov E ora A L mov hpush jmp end-code Code and ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ana A H mov L A mov E ana A L mov hpush jmp end-code Code xor ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D xra A H mov L A mov E xra A L mov hpush jmp end-code Code not ( 16b1 -- 16b2 ) H pop Label >not H A mov cma A H mov L A mov cma A L mov hpush jmp end-code \ - negate 16May86 Code - ( n1 n2 -- n3 ) D pop H pop L A mov E sub A L mov H A mov D sbb A H mov hpush jmp end-code Code negate ( n1 -- n2 ) H pop H dcx >not jmp end-code \\ : - ( n1 n2 -- n3 ) negate + ; \ dnegate d+ 10Mar86 18Nov87 Code dnegate ( d1 -- -d1 ) H pop Label >dnegate D pop A sub E sub A E mov 0 A mvi D sbb A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb A H mov dpush jmp end-code Code d+ ( d1 d2 -- d3) 6 H lxi SP dad M E mov C M mov H inx M D mov B M mov B pop H pop D dad xchg H pop L A mov C adc A L mov H A mov B adc A H mov B pop dpush jmp end-code \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code Code 2+ ( n1 -- n2 ) H pop H inx H inx hpush jmp end-code Code 3+ ( n1 -- n2 ) H pop H inx H inx H inx hpush jmp end-code Code 4+ ( n1 -- n2 ) H pop 4 D lxi D dad hpush jmp end-code | Code 6+ ( n1 -- n2 ) H pop 6 D lxi D dad hpush jmp end-code Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code Code 2- ( n1 -- n2 ) H pop H dcx H dcx hpush jmp end-code Code 4- ( n1 -- n2 ) H pop -4 D lxi D dad hpush jmp end-code \ number Constants 07Oct87-1 Constant true 0 Constant false 0 ( -- 0 ) Constant 0 1 ( -- 1 ) Constant 1 2 ( -- 2 ) Constant 2 3 ( -- 3 ) Constant 3 4 ( -- 4 ) Constant 4 -1 ( -- -1 ) Constant -1 Code on ( addr -- ) H pop $FF A mvi Label set A M mov H inx A M mov Next Code off ( addr -- ) H pop A xra set jmp end-code \ : on ( addr -- ) true swap ! ; \ : off ( addr -- ) false swap ! ; \ words for number literals 16May86 Code lit ( -- 16b ) IP ldax A L mov IP inx IP ldax A H mov IP inx hpush jmp end-code Code clit ( -- 8b ) IP ldax A L mov 0 H mvi IP inx hpush jmp end-code : Literal ( 16b -- ) dup $FF00 and IF compile lit , exit THEN compile clit c, ; immediate restrict \ comparision words 18Nov87Label (u< ( HL,DE -> HL u< DE c,z ) H A mov D cmp rnz L A mov E cmp ret Label (< ( HL,DE -> HL < DE c,z ) H A mov D xra (u< jp D A mov H cmp ret Label yes true H lxi hpush jmp Code u< ( u1 u2 -- flag ) D pop H pop Label uless (u< call yes jc Label no false H lxi hpush jmp Code < ( n1 n2 -- flag ) D pop H pop Label less (< call yes jc no jmp end-code Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code \ comparision words 18Nov87Code 0< ( n1 n2 -- flag ) H pop Label negative H dad yes jc no jmp end-code Code 0> ( n -- flag ) H pop H A mov A ora no jm L ora yes jnz no jmp end-code Code 0= ( n -- flag ) H pop Label zero= H A mov L ora yes jz no jmp end-code Code 0<> ( n -- flag ) H pop H A mov L ora yes jnz no jmp end-code Code = ( n1 n2 -- flag ) H pop D pop L A mov E cmp no jnz H A mov D cmp no jnz yes jmp end-code \\ comparision words high level 18Nov87: 0< ( n1 -- flag ) 8000 and 0<> ; : > ( n1 n2 -- flag ) swap < ; : 0> ( n -- flag ) negate 0< ; : 0<> ( n -- flag ) 0= not ; : u> ( u1 u2 -- flag ) swap u< ; : = ( n1 n2 -- flag ) - 0= ; : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; : min ( n1 n2 -- n3 ) 2dup > minimax ; : max ( n1 n2 -- n3 ) 2dup < minimax ; : umax ( u1 u2 -- u3 ) 2dup u< minimax ; : umin ( u1 u2 -- u3 ) 2dup u> minimax ; : extend ( n -- d ) dup 0< ; : dabs ( d -- ud ) extend IF dnegate THEN ; : abs ( n -- u) extend IF negate THEN ; \ uwthin double number comparison words 18Nov87 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl (u< call cs ?[ H pop no jmp ]? D pop (u< call yes jc no jmp end-code Code d0= ( d -- flag ) H pop H A mov L ora H pop no jnz zero= jmp end-code : d= ( d1 d2 -- flag ) rot = -rot = and ; : d< ( d1 d2 -- flag ) rot 2dup = IF 2drop u< exit THEN > nip nip ; \\ : d0= ( d -- flag ) or 0= ; \ minimum maximum 18Nov87 Code umax ( u1 u2 -- u3 ) H pop D pop (u< call Label minimax cs ?[ xchg ]? hpush jmp end-code Code umin ( u1 u2 -- u3 ) H pop D pop (u< call cmc minimax jmp end-code Code max ( n1 n2 -- n3 ) H pop D pop (< call minimax jmp end-code Code min ( n1 n2 -- n3 ) H pop D pop (< call cmc minimax jmp end-code \ sign extension absolute values 18Nov87 Code extend ( n -- d ) H pop H push negative jmp end-code Code abs ( a -- u ) H pop H A mov A ora hpush jp H dcx >not jmp end-code Code dabs ( d -- ud ) H pop H A mov A ora hpush jp >dnegate jmp end-code \ branch ?branch 20Nov87 Code branch ( -- ) Label >branch IP H mvx M E mov H inx M D mov H dcx D dad H IP mvx Next end-code Code ?branch ( fl -- ) H pop H A mov L ora >branch jz IP inx IP inx Next end-code \\ : branch r> dup @ + >r ; \ loop primitives 11Jun86 20Nov87 Code bounds ( start count -- limit start ) H pop D pop D dad H push D push Next end-code Code endloop RP lhld 6 D lxi D dad RP shld next end-code restrict \\ dodo puts "index | limit | adr.of.DO" on return-stack : bounds ( start count -- limit start ) over + swap ; | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; : (do ( limit start -- ) over - dodo ; restrict : (?do ( limit start -- ) over - ?dup IF dodo THEN r> dup @ + >r drop ; restrict \ loop primitives 20Nov87 Code (do ( limit start -- ) H pop D pop Label >do L A mov E sub A L mov H A mov D sbb A H mov H push IP inx IP inx RP lhld H dcx IP M mov H dcx IP' M mov H dcx D M mov H dcx E M mov D pop H dcx D M mov H dcx E M mov RP shld Next end-code restrict Code (?do ( limit start -- ) H pop D pop H A mov D cmp >do jnz L A mov E cmp >do jnz >branch jmp end-code restrict \ (loop (+loop 14May86 20Nov87 Code (loop RP lhld M inr 0= ?[ H inx M inr >next jz ]? Label doloop RP lhld 4 D lxi D dad M IP' mov H inx M IP mov Next end-code restrict Code (+loop RP lhld D pop M A mov E add A M mov H inx M A mov D adc A M mov rar D xra doloop jp Next end-code restrict \ loop indices 06May86 20Nov87 Code I ( -- n ) RP lhld Label >I M E mov H inx M D mov D push H inx M E mov H inx M D mov H pop D dad hpush jmp end-code Code J ( -- n ) RP lhld 6 D lxi D dad >I jmp end-code \ interpretive conditionals UH 25Jan88 | Create: remove>> r> rp! ; | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! swap >r remove>> >r swap >r dup >r swap cmove r> ; | Variable saved-dp 0 saved-dp ! | Variable level 0 level ! | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit 1 level ! here saved-dp ! ] ; | : -level ( -- ) state @ 0= Abort" unstructured" level @ 0=exit -1 level +! level @ ?exit compile unnest [compile] [ saved-dp @ here over dp ! over - >>r >r ; \ resolve loops and branches UH 25Jan88 : >mark ( -- addr ) here 0 , ; : +>mark ( acf -- addr ) +level , >mark ; : >resolve ( addr -- ) here over - swap ! -level ; : mark 1 ; immediate : THEN abs 1 ?pairs >resolve ; immediate : ELSE 1 ?pairs ['] branch +>mark swap >resolve -1 ; immediate : BEGIN mark -2 2swap ; immediate | : (reptil resolve REPEAT ; : REPEAT 2 ?pairs compile branch (reptil ; immediate : UNTIL 2 ?pairs compile ?branch (reptil ; immediate \ Loops UH 25Jan88 : DO ['] (do +>mark 3 ; immediate : ?DO ['] (?do +>mark 3 ; immediate : LOOP 3 ?pairs compile (loop compile endloop >resolve ; immediate : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; immediate Code LEAVE RP lhld 4 D lxi D dad M E mov H inx M D mov H inx RP shld xchg H dcx M D mov H dcx M E mov D dad H IP mvx Next end-code restrict \\ Returnstack: calladr | index limit | adr of DO : LEAVE endloop r> 2- dup @ + >r ; restrict \ um* 16May86Label (um* 0 H lxi ( 0=Teil-Produkt ) 4 C mvi ( Schleifen-Zaehler ) [[ H dad ( Schiebe HL 24 bits nach links ) ral cs ?[ D dad 0 aci ]? H dad ral cs ?[ D dad 0 aci ]? C dcr 0= ?] ret Code um* ( u1 u2 -- ud ) D pop H pop B push H B mov L A mov (um* call H push A H mov B A mov H B mov (um* call D pop D C mov B dad 0 aci L D mov H L mov A H mov B pop dpush jmp end-code \ m* * 2* 2/ 16May86 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap dup 0< IF negate r> not >r THEN um* r> IF dnegate THEN ; : * ( n1 n2 - prod ) um* drop ; Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code Code 2/ ( n -- n/2 ) H pop H A mov rlc rrc rar A H mov L A mov rar A L mov hpush jmp end-code \\ : 2* ( n -- 2*n ) 2 * ; : 2/ ( n -- n/2 ) 2 / ; \ um/mod 14May86Label usl0 A E mov H A mov C sub A H mov E A mov B sbb cs ?[ H A mov C add A H mov E A mov D dcr rz Label usla H dad ral usl0 jnc A E mov H A mov C sub A H mov E A mov B sbb ]? L inr D dcr usla jnz ret Label usbad -1 H lxi B pop H push hpush jmp Code um/mod ( d1 n1 -- rem quot ) IP H mvx B pop D pop xthl xchg L A mov C sub H A mov B sbb usbad jnc H A mov L H mov D L mov 8 D mvi D push usla call D pop H push E L mov usla call A D mov H E mov B pop C H mov B pop D push hpush jmp end-code \ m/mod 16May86 : m/mod ( d n -- mod quot) dup >r abs over 0< IF under + swap THEN um/mod r@ 0< IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; \ /mod / mod */mod */ u/mod ud/mod 16May86 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; : / ( n1 n2 -- quot ) /mod nip ; : mod ( n1 n2 -- rem ) /mod drop ; : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; : */ ( n1 n2 n3 -- quot ) */mod nip ; : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r um/mod r> ; \ cmove cmove> 16May86 18Nov87 Code cmove ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove [[ B A mov C ora 0= not ?[[ M A mov H INX D stax D inx B dcx ]]? IPsave lhld H IP mvx Next end-code Code cmove> ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove> B dad H dcx xchg B dad H dcx xchg [[ B A mov C ora 0= not ?[[ M A mov H dcx D stax D dcx B dcx ]]? IPsave lhld H IP mvx Next end-code \ move place count 17Oct86 18Nov87 Code move ( from to quan -- ) IP H mvx Ipsave shld B pop D pop H pop Label domove (u< call (cmove jnc (cmove> jmp end-code | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld D pop B pop H pop B push D push D inx domove jmp end-code : place ( addr len to -- ) (place c! ; Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi H inx H push D push Next end-code \ fill erase 18Nov87 Code fill ( addr quan 8b -- ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora 0<> ?[[ E M mov H inx B dcx ]]? IPsave lhld H IP mvx Next end-code : erase ( addr quan --) 0 fill ; \\ : fill ( addr quan 8b -- ) swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; : count ( adr -- adr+1 len ) dup 1+ swap c@ ; : move ( from to quan -- ) >r 2dup u< IF r> cmove> exit THEN r> cmove ; : place ( addr len to --) over >r rot over 1+ r> move c! ; \ here allot , c, pad compile 11Jun86 18Nov87 Code here ( -- addr ) user' dp D lxi UP lhld D dad fetch jmp end-code Code allot ( n -- ) user' dp D lxi UP lhld D dad +store jmp end-code : , ( 16b -- ) here ! 2 allot ; : c, ( 8b -- ) here c! 1 allot ; : pad ( -- addr ) here $42 + ; : compile r> dup 2+ >r @ , ; restrict \ : here ( -- addr ) dp @ ; \ : allot ( n -- ) dp +! ; \ input strings 11Jun86 Variable #tib 0 #tib ! Variable >tib here >tib ! $50 allot Variable >in 0 >in ! Variable blk 0 blk ! Variable span 0 span ! : tib ( -- addr ) >tib @ ; : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; \\ scan skip /string 16May86 18Nov87 : scan ( addr0 len0 char -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT rdrop ; : skip ( addr len del -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT rdrop ; : /string ( addr0 len0 +n - addr1 len1 ) over umin rot over + -rot - ; \ skip scan 18Nov87Label done H push B push IPsave lhld H IP mvx Next Code skip ( addr len del -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jnz H inx B dcx ]] end-code Code scan ( addr len chr -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jz H inx B dcx ]] end-code Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl L A mov E sub A L mov H A mov D sbb A H mov Hpush jmp end-code \ capitalize ohne Umlaute !! 16May86UH 25Jan88Variable caps 0 caps ! Label ?capital caps lda A ana rz Label (capital ( e --> A,E ) E A mov Ascii a cpi rc Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret Code capital ( char -- char') D pop (capital call D push Next end-code Code upper ( addr len -- ) D pop E D mov H pop D inr [[ D dcr >next jz M E mov (capital call E M mov H inx ]] end-code \\ : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; \ (word 16May86 Code (word ( char adr0 len0 -- addr ) IP H mvx IPsave shld B pop B dcx D pop >in lhld D dad xchg xthl xchg H push >in lhld C A mov L sub A L mov B A mov H sbb A H mov cs ?[ B inx C A mov >in sta B A mov >in 1+ sta D pop H pop D push ][ H inx H B mvx H pop [[ B A mov C ora 0<> ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? H push [[ B A mov C ora 0<> ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? xchg H pop xthl E A mov L sub A L mov D A mov H sbb A H mov \ (word Part2 16May86 B A mov C ora 0<> ?[ H inx ]? >in shld ]? H pop E A mov L sub A C mov D A mov H sbb A B mov H push user' dp D lxi UP lhld D dad M A mov H inx M H mov A L mov D pop H push C M mov H inx [[ B A mov C ora 0<> ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi IPsave lhld H IP mvx Next end-code \\ : (word ( char adr0 len0 -- addr ) rot >r over swap >in @ /string r@ skip over swap r> scan >r rot over swap - r> 0<> - >in ! over - here dup >r place bl r@ count + c! r> ; \ source word parse name 20Oct86UH 25Jan88 Variable loadfile : source ( -- addr len ) blk @ ?dup IF loadfile @ (block b/blk exit THEN tib #tib @ ; : word ( char -- addr ) source (word ; : parse ( char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; : name ( -- addr ) bl word dup count upper exit ; \ state Ascii ," "lit (" " 18Nov87 Variable state 0 state ! : Ascii ( char -- n ) bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate Code "lit RP lhld M E mov H inx M D mov H dcx D push D ldax D inx E add A M mov H inx D A mov 0 aci A M mov Next end-code : ," Ascii " parse here over 1+ allot place ; : (" "lit ; restrict : " compile (" ," align ; immediate restrict \ : "lit r> r> under count + even >r >r ; restrict \ ." ( .( \ \\ hex decimal 07Oct87 : (." "lit count type ; restrict : ." compile (." ," align ; immediate restrict : ( ascii ) parse 2drop ; immediate : .( ascii ) parse type ; immediate : \ >in @ negate c/l mod >in +! ; immediate : \\ b/blk >in ! ; immediate : \needs name find nip 0=exit [compile] \ ; : hex $10 base ! ; : decimal $0A base ! ; \ number conversion: digit? 16May86 18Nov87 Code digit? ( char -- n true : false ) user' base D lxi UP lhld D dad D pop E A mov Ascii 0 sui no jc $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc Ascii A Ascii 9 - 1- sui ]? M cmp no jnc 0 H mvi A L mov H push yes jmp end-code \\ : digit? ( char -- digit true/ false ) dup Ascii 9 > IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN Ascii 0 - dup base @ u< dup ?exit nip ; \ number conversion: accumulate convert 11Jun86 | : end? ( -- flag ) >in @ 0= ; | : char ( addr0 -- addr1 char ) count -1 >in +! ; | : previous ( addr0 -- addr0 char ) 1- count ; : accumulate ( +d0 adr digit - +d1 adr ) swap >r swap base @ um* drop rot base @ um* d+ r> ; : convert ( +d1 addr0 -- +d2 addr2 ) 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; \ number conversion: ?nonum punctuation? 07Oct87 | : ?nonum ( flag -- exit if true ) 0=exit rdrop 2drop drop rdrop false ; | : punctuation? ( char -- flag ) Ascii , over = swap Ascii . = or ; \ number conversion: fixbase? 07Oct87 | : fixbase? ( char - char false / newbase true ) capital Ascii & case? IF $0A true exit THEN Ascii $ case? IF $10 true exit THEN Ascii H case? IF $10 true exit THEN Ascii % case? IF 2 true exit THEN false ; \ number conversion: ?num ?dpl 07Oct87 Variable dpl -1 dpl ! | : ?num ( flag -- exit if true ) 0=exit rdrop drop r> IF dnegate THEN rot drop dpl @ 1+ ?dup ?exit drop true ; | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; \ number conversion: number? number 11Jun86 : number? ( string - string false / n 0< / d 0> ) base push >in push dup count >in ! dpl on 0 >r ( +sign) 0.0 rot end? ?nonum char Ascii - case? IF rdrop true >r end? ?nonum char THEN fixbase? IF base ! end? ?nonum char THEN BEGIN digit? 0= ?nonum BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL previous punctuation? 0= ?nonum dpl off end? ?num char REPEAT ; : number ( string -- d ) number? ?dup 0= Abort" ?" 0< IF extend THEN ; \ hide reveal immediate restrict 11Jun86 Variable last 0 last ! | : last? ( -- false / acf true) last @ ?dup ; : hide last? IF 2- @ current @ ! THEN ; : reveal last? IF 2- current @ ! THEN ; : Recursive reveal ; immediate restrict | : flag! ( 8b --) last? IF under c@ or over c! THEN drop ; : immediate $40 flag! ; : restrict $80 flag! ; \ clearstack hallot heap heap? 04Sep86 Code clearstack user' s0 D lxi UP lhld D dad M E mov H inx M D mov xchg sphl Next end-code : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot - dup s0 ! 2 pick over - di move clearstack ei s0 ! ; : heap ( -- addr ) s0 @ 6 + ; : heap? ( addr -- flag ) heap up@ uwithin ; | : heapmove ( from -- from ) dup here over - dup hallot heap swap cmove heap over - last +! reveal ; \ Does> ; 11Jun86 20Nov87 Label (dodoes> IP rpush IP pop W inx W push Next end-code : (;code r> last @ name> ! ; : Does> compile (;code $CD ( 8080-Call ) c, compile (dodoes> ; immediate restrict \ ?head | alignments 20Oct86 18Nov87 Variable ?head 0 ?head ! : | ?head @ ?exit -1 ?head ! ; \ machen nichts beim 8080: : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate Variable warning 0 warning ! | : exists? warning @ ?exit last @ current @ (find nip 0=exit space last @ .name ." exists " ?cr ; \ warning Create 20Oct86 18Nov87 Defer makeview ' 0 Is makeview : (create ( string -- ) align here swap count $1F and here 4+ place makeview , current @ @ , here last ! here c@ 1+ allot align exists? ?head @ IF 1 ?head +! dup , \ Pointer to Code halign heapmove $20 flag! dup dp ! THEN drop reveal 0 , ;Code W inx W push Next end-code : Create name count 1 $20 uwithin not Abort" invalid name" 1- (create ; \ nfa? 30Jun86 Code nfa? ( thread cfa -- nfa / false ) D pop H pop [[ M A mov H inx M H mov A L mov H ora Hpush jz H push H inx H inx H push D push M A mov H inx $1F ani A E mov 0 D mvi D dad D pop xthl M A mov H pop $20 ani 0<> ?[ M A mov H inx M H mov A L mov ]? H A mov D cmp 0= ?[ L A mov E cmp ]? H pop 0= ?] H inx H inx Hpush jmp end-code \\ : nfa? ( thread cfa -- nfa / false) >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = UNTIL 2+ rdrop ; \ >name name> >body .name 30Jun86 07Oct87 : >name ( cfa -- nfa / false ) voc-link BEGIN @ dup WHILE 2dup 4 - swap nfa? ?dup IF -rot 2drop exit THEN REPEAT nip ; Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani A E mov 0 D mvi D dad hpush jmp end-code \ : (name> ( nfa -- cfa ) count $1F and + ; : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN count $1F and type ELSE ." ???" THEN space ; \ : ; Constant Variable 07Nov87 : Create: Create hide current @ context ! 0 ] ; : : Create: ;Code IP rpush W inx W IP mvx Next end-code : ; 0 ?pairs compile unnest [compile] [ reveal ; immediate restrict : Constant ( n -- ) Create , ;Code W inx xchg M E mov H inx M D mov D push Next end-code : Variable Create 0 , ; \ uallot User Alias Defer 11Jun86 18Nov87: uallot ( quan -- offset ) even dup udp @ + $FF u> Abort" Userarea full" udp @ swap udp +! ; : User Create 2 uallot c, ;Code W inx W ldax A E mov 0 D mvi UP lhld D dad hpush jmp end-code : Alias ( cfa -- ) Create last @ dup c@ $20 and IF -2 allot ELSE $20 flag! THEN (name> ! ; | : crash true Abort" crash" ; : Defer Create ['] crash , ;Code W inx xchg M E mov H inx M D mov xchg >next1 jmp end-code \ vp current context also toss 11Jun86 Create vp $10 allot Variable current : context ( -- adr ) vp dup @ + 2+ ; | : thru.vocstack ( -- from to ) vp 2+ context ; \ "Only Forth also Assembler" gives \ vp: countword = 6 | Only | Forth | Assembler | : also vp @ $0A > Error" Vocabulary stack full" context @ 2 vp +! context ! ; : toss vp @ IF -2 vp +! THEN ; \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; \ | Name | Code | Thread | Coldthread | Voc-link | Vocabulary Forth Vocabulary Root : Only vp off Root also ; : Onlyforth Only Forth also definitions ; \ definitions order words 10Oct87 20Nov87 | : init-vocabularys voc-link @ BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; : definitions context @ current ! ; | : .voc ( adr -- ) @ 2- >name .name ; : order vp 4+ context DO I .voc -2 +LOOP 2 spaces current .voc ; : words context @ BEGIN @ dup stop? 0= and WHILE ?cr dup 2+ .name space REPEAT drop ; \ found -text 11Jun86| : found ( nfa -- cfa n ) dup c@ >r (name> r@ $20 and IF @ THEN -1 r@ $80 and IF 1- THEN r> $40 and IF negate THEN ; \\ : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN THEN drop REPEAT string @ 1- false ; \ (find 11Jun86 Code (find ( str thr - str false/ NFA true ) H pop D pop IP push D ldax $1F ani A C mov D inx Label findloop M A mov H inx M H mov A L mov H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? H push H inx H inx M A mov $1F ani C cmp 0<> ?[ H pop findloop jmp ]? D push H inx C B mov B inr [[ B dcr 0<> ?[[ D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? H inx D inx ]]? D pop H pop H inx H inx IP pop H push yes jmp end-code \\ HL: thread, nfa DE: string C: strlen B: counter \ find ' [compile] ['] nullstring? 18Nov87 : find ( string -- cfa n / string false ) context dup @ over 2- @ = IF 2- THEN BEGIN under @ (find IF nip found exit THEN over vp 2+ u> WHILE swap 2- REPEAT nip false ; : ' ( -- cfa ) name find ?exit Error" ?" ; : [compile] ' , ; immediate restrict : ['] ' [compile] Literal ; immediate restrict : nullstring? ( string -- string false / true ) dup c@ 0= dup 0=exit nip ; \ notfound 17Oct86UH 25Jan88 : no.extensions ( string -- ) state @ IF Abort" ?" THEN Error" ?" ; Defer notfound ' no.extensions Is notfound \ interpret interpreter compiler parser UH 25Jan88Defer parser : interpret ( -- ) BEGIN ?stack name nullstring? ?exit parser REPEAT ; | : interpreter ( str -- ) find ?dup IF 1 and IF execute exit THEN Error" compile only" THEN number? ?exit notfound ; ' interpreter Is parser | : compiler ( str -- ) find ?dup IF 0> IF execute exit THEN , exit THEN number? ?dup IF 0> IF swap [compile] Literal THEN [compile] Literal exit THEN notfound ; \ [ ] UH 25Jan88 : [ ['] interpreter Is Parser state off ; immediate : ] ['] compiler Is Parser state on ; \ Is 09May86UH 25Jan88 : (is r> dup 2+ >r @ ! ; | : def? ( cfa -- ) @ [ ' notfound @ ] Literal - Abort" not deferred" ; : Is ( adr -- ) ' dup def? >body state @ IF compile (is , exit THEN ! ; immediate \ ?stack 30Jun86| : stackfull ( -- ) depth $20 > Abort" tight stack" reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN true Abort" Dictionary full" ; Code ?stack UP lhld user' dp D lxi D dad M E mov H inx M D mov 0 H lxi SP dad L A mov E sub H A mov D sbb 0= ?[ ;c: stackfull ; Assembler ]? H push UP lhld user' s0 D lxi D dad M E mov H inx M D mov H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? >next jnc ;c: true abort" Stack empty" ; \\ : ?stack sp@ here - 100 u< IF stackfull THEN sp@ s0 @ u> Abort" Stack empty" ; \ .status push load 20Oct86 Defer .status ' noop Is .status | Create: pull r> r> ! ; : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; restrict : (load ( blk offset -- ) isfile push loadfile push fromfile push blk push >in push >in ! blk ! isfile@ loadfile ! .status interpret ; : load ( blk --) ?dup 0=exit 0 (load ; \ +load thru +thru --> rdepth depth 20Oct86 : +load ( offset --) blk @ + load ; : thru ( from to --) 1+ swap DO I load LOOP ; : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n) sp@ s0 @ swap - 2/ ; \ quit (quit abort UH 25Jan88 : (prompt ( -- ) state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; Defer prompt ' (prompt Is prompt : (quit BEGIN prompt query interpret REPEAT ; Defer 'quit ' (quit Is 'quit : quit r0 @ rp! level off [compile] [ 'quit ; : standardi/o [ output ] Literal output 4 cmove ; Defer 'abort ' noop Is 'abort : abort end-trace clearstack 'abort standardi/o quit ; \ (error Abort" Error" 20Oct86 18Nov87 Variable scr 1 scr ! Variable r# 0 r# ! : (error ( string -- ) standardi/o space here .name count type space ?cr blk @ ?dup IF scr ! >in @ r# ! THEN quit ; ' (error errorhandler ! : (abort" "lit swap IF >r clearstack r> errorhandler perform exit THEN drop ; restrict | : (err" "lit swap IF errorhandler perform exit THEN drop ; restrict : Abort" compile (abort" ," align ; immediate restrict : Error" compile (err" ," align ; immediate restrict \ -trailing 30Jun86 18Nov87 Code -trailing ( addr n1 -- addr n2 ) D pop H pop H push D dad xchg D dcx Label -trail H A mov L ora hpush jz D ldax BL cpi hpush jnz H dcx D dcx -trail jmp end-code \\ : -trailing ( addr n1 -- addr n2) 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; \ space spaces 30Jun86 $20 Constant bl : space bl emit ; : spaces ( u --) 0 ?DO space LOOP ; \ hold <# #> sign # #s 17Oct86 | : hld ( -- addr) pad 2- ; : hold ( char -- ) -1 hld +! hld @ c! ; : <# hld hld ! ; : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; : sign ( n -- ) 0< IF Ascii - hold THEN ; : # ( +d1 -- +d2) base @ ud/mod rot 9 over < IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; \ print numbers 24Dec83 : d.r -rot under dabs <# #s rot sign #> rot over max over - spaces type ; : .r swap extend rot d.r ; : u.r 0 swap d.r ; : d. 0 d.r space ; : . extend d. ; : u. 0 d. ; \ .s list c/l l/s 05Oct87 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; $40 Constant c/l \ Screen line length $10 Constant l/s \ lines per screen : list ( blk -- ) scr ! ." Scr " scr @ u. l/s 0 DO cr I 2 .r space scr @ block I c/l * + c/l -trailing type LOOP cr ; \ multitasker primitives 20Nov87 Code end-trace \ patch Next to its original state $0A A mvi ( IP ldax ) >next sta $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code Code pause >next here 2- ! end-code : lock ( addr -- ) dup @ up@ = IF drop exit THEN BEGIN dup @ WHILE pause REPEAT up@ swap ! ; : unlock ( addr -- ) dup lock off ; Label wake H pop H dcx UP shld 6 D lxi D dad M A mov H inx M H mov A L mov sphl H pop RP shld IP pop Next end-code \ buffer mechanism 20Oct86 07Oct87 User isfile 0 isfile ! \ addr of file control block Variable fromfile 0 fromfile ! Variable prev 0 prev ! \ Listhead | Variable buffers 0 buffers ! \ Semaphor $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \\ Struktur eines Buffers: 0 : link 2 : file 4 : blocknummer 6 : statusflags 8 : Data ... 1 Kb ... Statusflag bits : 15 1 -> updated file : -1 -> empty buffer, 0 -> no fcb, direct access else addr of fcb ( system dependent ) \ search for blocks in memory 30Jun86| Variable pred \ DE:blk BC:file HL:bufadr Label thisbuffer? ( Zero = this buffer ) H push H inx H inx M A mov C cmp 0= ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret Code (core? ( blk file -- adr\blk file ) IP H mvx Ipsave shld user' offset D lxi UP lhld D dad M E mov H inx M D mov B pop H pop H push B push D dad xchg prev lhld thisbuffer? call 0= ?[ \ search for blocks in memory 30Jun86 Label blockfound D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? [[ pred shld M A mov H inx M H mov A L mov H ora 0= ?[ IPsave lhld H IP mvx Next ]? thisbuffer? call 0= ?] xchg pred lhld D ldax A M mov H inx D inx D ldax A M mov D dcx prev lhld xchg E M mov H inx D M mov H dcx prev shld blockfound jmp end-code \ (core? 29Jun86\\ | : this? ( blk file bufadr -- flag ) dup 4+ @ swap 2+ @ d= ; | : (core? ( blk file -- dataaddr / blk file ) BEGIN over offset @ + over prev @ this? IF rdrop 2drop prev @ 8 + exit THEN 2dup >r offset @ + >r prev @ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN dup r> r> 2dup >r >r rot this? 0= WHILE nip REPEAT dup @ rot ! prev @ over ! prev ! rdrop rdrop REPEAT ; \ (diskerr 29Jul86 07Oct87 : (diskerr ." error! r to retry " key $FF and capital Ascii R = not Abort" aborted" ; Defer diskerr ' (diskerr Is diskerr Defer r/w \ backup emptybuf readblk 20Oct86 | : backup ( bufaddr -- ) dup 6+ @ 0< IF 2+ dup @ 1+ \ buffer empty if file = -1 IF input push output push standardi/o BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w WHILE ." write " diskerr REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; | : readblk ( blk file addr -- blk file addr ) dup emptybuf input push output push standardi/o >r BEGIN over offset @ + over r@ 8 + -rot 1 r/w WHILE ." read " diskerr REPEAT r> ; \ take mark updates? core? 10Mar86 19Nov87 | : take ( -- bufaddr) prev BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL buffers lock dup backup ; | : mark ( blk file bufaddr -- blk file ) 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off buffers unlock ; | : updates? ( -- bufaddr / flag) prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; : core? ( blk file -- addr /false ) (core? 2drop false ; \ block & buffer manipulation 20Oct86 18Nov87 : (buffer ( blk file -- addr ) BEGIN (core? take mark REPEAT ; : (block ( blk file -- addr ) BEGIN (core? take readblk mark REPEAT ; Code isfile@ ( -- addr ) user' isfile D lxi UP lhld D dad fetch jmp end-code : buffer ( blk -- addr ) isfile@ (buffer ; : block ( blk -- addr ) isfile@ (block ; \ : isfile@ ( -- addr ) isfile @ ; \ block & buffer manipulation 05Oct87 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; Defer save-dos-buffers : save-buffers ( -- ) buffers lock BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers buffers unlock ; : empty-buffers ( -- ) buffers lock prev BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; : flush save-buffers empty-buffers ; \ Allocating buffers 10Oct87$10000 Constant limit Variable first : allotbuffer ( -- ) first @ r0 @ - b/buf 2+ u< ?exit b/buf negate first +! first @ dup emptybuf prev @ over ! prev ! ; : freebuffer ( -- ) first @ limit b/buf - u< IF first @ backup prev BEGIN dup @ first @ - WHILE @ REPEAT first @ @ swap ! b/buf first +! THEN ; : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; | : init-buffers prev off limit first ! all-buffers ; \ endpoints of forget 01Jul86 | : |? ( nfa -- flag ) c@ $20 and ; | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? name> under 1+ u< swap heap? or ; | : endpoints ( addr -- addr symb ) heap voc-link @ >r BEGIN r> @ ?dup \ through all Vocabs WHILE dup >r 4- >r \ link on returnstack BEGIN r> @ >r over 1- dup r@ u< \ until link or swap r@ 2+ name> u< and \ code under adr WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap r@ 2+ |? IF over r@ 2+ forget? IF r@ 2+ (name> 2+ umax THEN \ then update symb THEN REPEAT rdrop REPEAT ; \ remove, -words, -tasks 20Oct86 : remove ( dic sym thread - dic sym ) BEGIN dup @ ?dup \ unlink forg. words WHILE dup heap? IF 2 pick over u> ELSE 3 pick over 1+ u< THEN IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; | : remove-words ( dic sym -- dic sym ) voc-link BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; | : remove-tasks ( dic -- ) up@ BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin IF dup @ 2+ @ over ! 2- ELSE @ THEN REPEAT 2drop ; \ remove-vocs trim 20Oct86 07Oct87 | : remove-vocs ( dic symb -- dic symb ) voc-link remove thru.vocstack DO 2dup I @ -rot uwithin IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP 2dup current @ -rot uwithin IF [ ' Forth 2+ ] Literal current ! THEN ; Defer custom-remove ' noop Is custom-remove | : trim ( dic symb -- ) over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! 0 last ! ; \ deleting words from dict. 01Jul86 18Nov87 : clear here dup up@ trim dp ! ; : (forget ( adr --) dup heap? Abort" is symbol" endpoints trim ; : forget ' dup [ dp ] Literal @ u< Abort" protected" >name dup heap? IF name> ELSE 4- THEN (forget ; : empty [ dp ] Literal @ up@ trim [ udp ] Literal @ udp ! ; \ save bye stop? ?cr 18Nov87 : save here up@ trim voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL up@ origin $100 cmove ; : bye flush empty (bye ; | : end? key #cr = IF true rdrop THEN ; : stop? ( -- flag ) key? IF end? end? THEN false ; : ?cr col c/l u> 0=exit cr ; \ in/output structure 07Jun86 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; : Output: Create: Does> output ! ; 0 Out: emit Out: cr Out: type Out: del Out: page Out: at Out: at? drop : row ( -- row) at? drop ; : col ( -- col) at? nip ; | : In: Create dup c, 2+ Does> c@ input @ + perform ; : Input: Create: Does> input ! ; 0 In: key In: key? In: decode In: expect drop \ Alias only definitionen 18Nov87 Root definitions Forth : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. ' Only Alias Only ' Forth Alias Forth ' words Alias words ' also Alias also ' definitions Alias definitions Host Target \ 'restart 'cold 22Oct86 10Oct87 Defer 'restart ' noop Is 'restart | : (restart ['] (quit Is 'quit drvinit 'restart [ errorhandler ] Literal @ errorhandler ! ['] noop Is 'abort clearstack standardi/o interpret quit ; Defer 'cold ' noop Is 'cold | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off init-vocabularys init-buffers flush 'cold Onlyforth page &24 spaces logo count type cr (restart ; \ cold bootsystem 20Oct86 Code cold here >cold ! s0 lhld 6 D lxi D dad origin D lxi $3F C mvi [[ D ldax A M mov H inx D inx C dcr 0= ?] ' (cold >body IP lxi Label bootsystem s0 lhld 6 D lxi D dad UP shld user' s0 D lxi D dad M E mov H inx M D mov xchg sphl user' r0 D lxi UP lhld D dad M E mov H inx M D mov xchg RP shld $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) Next end-code \ restart boot 20Oct86 Code restart here >restart ! ' (restart >body IP lxi bootsystem jmp end-code Label boot here >boot ! \ find link to Main: s0 lhld 6 D lxi D dad H B mvx origin D lxi [[ [[ xchg H inx H inx M E mov H inx M D mov D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx 6 lhld 0 L mvi ' limit >body shld -$1100 D lxi D dad r0 shld \ set initial RP -$400 D lxi D dad s0 shld \ set initial SP 6 D lxi D dad xchg B H mvx D M mov H dcx E M mov \ set link to Maintask >cold 2- jmp end-code \ "search 05Mar88 Label notfound H pop H pop IPsave lhld H IP mvx False H lxi hpush jmp Code "search ( text tlen buf blen -- addr tf / ff ) IP H mvx IPsave shld D pop H pop xthl H A mov L ora notfound jz E A mov L sub A C mov D A mov H sbb A B mov notfound jc B inx D pop xthl M A mov xthl H push xchg Label scanfirst A E mov ?capital call E D mov [[ M E mov H inx B A mov C ora notfound jz B dcx ?capital call E A mov D cmp 0= ?] B D mvx B pop xchg xthl xchg H push B push D push \ "search part 2 27Nov87 Label match B dcx B A mov C ora 0<> ?[ D inx D ldax D push A E mov ?capital call E D mov M E mov H inx ?capital call E A mov D cmp D pop match jz H pop B pop D pop M A mov xthl B push H B mvx xchg scanfirst jmp ]? D pop D pop H pop D pop H dcx H push IPsave lhld H IP mvx True H lxi hpush jmp end-code \ Rest of Standard-System 04Oct87 07Oct87 2 +load \ Operating System Host ' Transient 8 + @ Transient Forth Context @ 6 + ! Target Forth also definitions Vocabulary Assembler Assembler definitions Transient Assembler >Next Constant >Next hpush Constant hpush dpush Constant dpush Target Forth also definitions : forth-83 ; \ last word in Dictionary \ System patchup 04Oct87 $EF00 r0 ! $EB00 s0 ! s0 @ 6 + origin 2+ ! \ link Maintask to itself \ s0 und r0 werden beim Booten neu an die Speichergroesse \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask here dp ! Host Tudp @ Target udp ! Host Tvoc-link @ Target voc-link ! Host move-threads \ System dependent Load-Screen 20Nov87 1 +load \ CP/M interface 2 4 +thru \ Character IO 5 7 +thru \ Default Disk IO 8 +load \ Postlude \ 9 +load \ Index \ CP/M-Interface 05Oct87Vocabulary Dos Dos definitions also Label >bios pchl Code biosa ( arg fun -- res ) 1 lhld D pop D dcx D dad D dad D dad D pop IP push D IP mvx >bios call Label back IP pop 0 H mvi A L mov Hpush jmp end-code Code bdosa ( arg fun -- res ) H pop D pop IP push L C mov 5 call back jmp end-code : bios ( arg fun -- ) biosa drop ; : bdos ( arg fun -- ) bdosa drop ; \ Character-IO Constants Character input 05Oct87 Target Dos also $08 Constant #bs $0D Constant #cr $0A Constant #lf $1B Constant #esc $09 Constant #tab $7F Constant #del $07 Constant #bel $0C Constant #ff : con! ( c -- ) 4 bios ; : (key? ( -- ? ) 0 2 biosa 0= not ; : getkey ( -- c ) 0 3 biosa ; : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; \ Character output 07Oct87 UH 27Feb88 | Code ?ctrl ( c -- c' ) H pop L A mov $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code : (emit ( c -- ) ?ctrl con! pause ; : (cr #cr con! #lf con! ; : (del #bs con! bl con! #bs con! ; : (at? ( -- row col ) 0 0 ; : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; Output: display [ here output ! ] (emit (cr tipp (del noop 2drop (at? ; \ Line input 04Oct87 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; : (decode ( addr pos1 key -- addr pos2 ) #bs case? IF backspace exit THEN #del case? IF backspace exit THEN #cr case? IF dup span ! space exit THEN dup emit >r 2dup + r> swap c! 1+ ; : (expect ( addr len -- ) span ! 0 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; Input: keyboard [ here input ! ] (key (key? (decode (expect ; \ Default Disk Interface: Constants and Primitives 18Nov87 $80 Constant b/rec b/blk b/rec / Constant rec/blk Dos definitions ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb : dos-error? ( n -- f ) $FF = ; $5C Constant fcb : reset ( -- ) 0 &13 bdos ; : openfile ( fcb -- f ) &15 bdosa dos-error? ; : closefile ( fcb -- f ) &16 bdosa dos-error? ; : dma! ( dma -- ) &26 bdos ; : rec@ ( fcb -- f ) &33 bdosa ; : rec! ( fcb -- f ) &34 bdosa ; \ Default Disk Interface: open and close 20Nov87 Target Dos also Defer drvinit Dos definitions | Variable opened : default ( -- ) opened off fcb 1+ c@ bl = ?exit $80 count here place #tib off fcb dup dosfcb> dup isfile ! fromfile ! openfile Abort" default file not found!" opened on ; ' default Is drvinit : close-default ( -- ) opened @ not ?exit fcb closefile Abort" can't close default-file!" ; ' close-default Is save-dos-buffers \ Default Disk Interface: read/write 14Feb88 Target Dos also | : rec# ( 'dosfcb -- 'rec# ) &33 + ; : (r/w ( adr blk file r/wf -- flag ) >r dup 0= Abort" no Direct Disk IO supported! " >dosfcb swap rec/blk * over rec# 0 over 2+ c! ! r> rot b/blk bounds DO I dma! 2dup IF rec@ drop ELSE rec! IF 2drop true endloop exit THEN THEN over rec# 0 over 2+ c! 1 swap +! b/rec +LOOP 2drop false ; ' (r/w Is r/w \ Postlude 20Nov87 Defer postlude | : (bye ( -- ) postlude 0 0 bdos ; | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; : .size ( -- ) base push decimal cr ." Size: &" #pages u. ." Pages" ; ' .size Is postlude \ index findex 20Nov87 | : range ( from to -- to+1 from ) 2dup > IF swap THEN 1+ swap ; : index ( from to --) range DO cr I 4 .r I space block c/l type stop? IF LEAVE THEN LOOP ; \ No newline at end of file diff --git a/8080/AmstradCPC/STARTUP.SCR b/8080/AmstradCPC/STARTUP.SCR new file mode 100644 index 0000000..dc51604 --- /dev/null +++ b/8080/AmstradCPC/STARTUP.SCR @@ -0,0 +1 @@ +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth ( 10.02.89/KK ) include ass8080.scr include xinout.scr \ Erweiterte Ein- u. Ausgabe include terminal.scr save \ Terminal include copy.scr cr .( copy und convey geladen.) cr include savesys.scr cr .( Savesystem geladen.) cr include editor.scr cr .( Editor geladen.) cr include tools.scr cr .( Tools geladen.) cr include see.scr cr .( Decompiler geladen.) cr include tasker.scr cr .( Multitasker geladen.) cr include printer.scr cr .( Printer Interface geladen.) cr include relocate.scr cr .( Relocating geladen. ) cr .( May the volksFORTH be with you ...) cr decimal caps on editor.scr scr off r# off ( savesystem volks4th.com ) \ UH 22Oct86 \ No newline at end of file diff --git a/8080/AmstradCPC/TASKER.SCR b/8080/AmstradCPC/TASKER.SCR new file mode 100644 index 0000000..c148f80 --- /dev/null +++ b/8080/AmstradCPC/TASKER.SCR @@ -0,0 +1 @@ +\\ Multitasker 11Nov86 Dieses File enthaelt den Multitasker des volksFORTHs. Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt die Kontrolle ueber den Prozessor solange, bis sie sie ausdruecklich abgibt. Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet auf den Massenspeicher und auf den Drucker zugreifen. In Verbindung mit dem Printer-Interface ist es moeglich Files im Hintergrund auszudrucken. (SPOOL) \ Multitasker Loadscreen 27Jun86 20Nov87 Onlyforth \needs multitask 1 +load 02 05 +thru \ Tasker \ stop singletask multitask 28Aug86 20Nov87 Code stop UP lhld 0 ( nop ) M mvi Label taskpause IP push RP lhld H push UP lhld 6 D lxi D dad xchg H L mov SP dad xchg E M mov H inx D M mov UP lhld H inx pchl end-code : singletask [ ' pause @ ] Literal ['] pause ! ; : multitask [ taskpause ] Literal ['] pause ! ; \ pass activate 28Aug86 : pass ( n0 ... nr-1 Taddr r -- ) BEGIN [ rot ( Trick !! ) ] swap $F7 over c! \ awake Task ( rst 6 ) r> -rot \ Stack: IP r addr 8 + >r \ s0 of Task r@ 2+ @ swap \ Stack: IP r0 r 2+ 2* \ bytes on Taskstack incl. r0 & IP r@ @ over - \ new SP dup r> 2- ! \ into Ssave swap bounds ?DO I ! 2 +LOOP ; restrict : activate ( Taddr -- ) 0 [ -rot ( Trick !! ) ] REPEAT ; restrict \ sleep wake taskerror 28Aug86 20Nov87 : sleep ( Taddr -- ) $00 ( nop ) swap c! ; : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; | : taskerror ( string -- ) standardi/o singletask ." Task error : " count type multitask stop ; \ Task 20Nov87 : Task ( rlen slen -- ) 0 Constant here 2- >r \ addr of task constant here -rot \ here for Task dp even allot even \ allot dictionary area here r@ ! \ set task constant addr up@ here $100 cmove \ init user area here dup $C300 , \ nop-jmp opcode to sleep task up@ 2+ dup @ , ! \ link task r> , \ spare used for pointer to header dup 6 - dup , , \ ssave and s0 2dup + , \ here + rlen = r0 rot , \ dp under + dp ! 0 , \ allot rstack ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; \ rendezvous 's tasks 27Jun86 20Nov87 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ; | : statesmart state @ IF [compile] Literal THEN ; : 's ( Taddr -- adr.of.tasks.userarea ) ' >body c@ + statesmart ; immediate : tasks ( -- ) ." Main " cr up@ dup 2+ @ BEGIN 2dup - WHILE dup 4+ @ body> >name .name dup c@ 0= ( nop ) IF ." sleeping" THEN cr 2+ @ REPEAT 2drop ; \ No newline at end of file diff --git a/8080/AmstradCPC/TERMINAL.SCR b/8080/AmstradCPC/TERMINAL.SCR new file mode 100644 index 0000000..1a93705 --- /dev/null +++ b/8080/AmstradCPC/TERMINAL.SCR @@ -0,0 +1 @@ +\\ Terminal-Anpassung 11Nov86 In diesem File wird volksFORTH an das benutzte Terminal angepasst. Ueber folgende Faehigkeiten muss das Terminal verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt werden koennen: curon, curoff \ Ein- bzw. Ausschalten des Cursors curleft, currite \ Cursor nach links bzw. rechts bewegen rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellungdark \ Loeschen des Bildschirms locate \ Positionieren des Cursors auf eine \ bestimmte Position auf dem Bildschirm \ Schneider CPC464-Terminal Anpassung UH 18Mar87 | : CPCcuron ( -- ) 3 con! ; | : CPCcuroff ( -- ) 2 con! ; | Variable reverse reverse off | : CPCrvson ( -- ) reverse @ ?exit reverse on $18 con! ; | : CPCrvsoff ( -- ) reverse @ 0= ?exit reverse off $18 con! ; | : CPCdark ( -- ) $0C con! ; | : CPClocate ( row col -- ) $1F con! 1+ con! &24 min 1+ con! ; Terminal: schneider CPCcuron CPCcuroff CPCrvson CPCrvsoff CPCdark CPClocate ; schneider page .( CPC-464 Terminal installiert. ) cr cr \ No newline at end of file diff --git a/8080/AmstradCPC/TIMES.SCR b/8080/AmstradCPC/TIMES.SCR new file mode 100644 index 0000000..c4c42c3 --- /dev/null +++ b/8080/AmstradCPC/TIMES.SCR @@ -0,0 +1 @@ +\\ Times Often: interactive loops 11Nov86 Dieses File enthaelt die Definitionen der beiden Utility-Worte TIMES, OFTEN, die interaktiv benutzt werden koennen, was normalerweise mit BEGIN WHILE ... nicht moeglich ist. Benutzung: nur interaktiv! a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, \ oder bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt, a b ... often \ Wiederhole die Befehlsfolge "a b ..." \ so oft, bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt. \ Times, Often 02feb86 also Forth definitions : often stop? ?exit >in off ; | Variable #times #times off : times ( n --) ?dup IF #times @ 2+ u< stop? or IF #times off exit THEN 1 #times +! ELSE stop? ?exit THEN >in off ; toss definitions \ No newline at end of file diff --git a/8080/AmstradCPC/TOOLS.SCR b/8080/AmstradCPC/TOOLS.SCR new file mode 100644 index 0000000..fceccbb --- /dev/null +++ b/8080/AmstradCPC/TOOLS.SCR @@ -0,0 +1 @@ +\\ Tools 11Nov86Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- entwicklung: - den einfachen Decompiler - der DUMP-Befehl - den Tracer Der einfache Decompiler wird benutzt, um neue Defining-Words zu ueberpruefen. Der automatische Decompiler kann ja dafuer nicht benutzt werden, da ihm diese Strukturen unbekannt sind. (Benutzung: addr und dann, je nach Art: S N D L C oder B) DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) Der Tracer erlaubt Einzelschrittausfuehrung von Worten. Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. (Benutzung: DEBUG und END-TRACE) \ Loadscreen for simple decompiler and tracer 11Nov86 Onlyforth Vocabulary Tools Tools also definitions 01 05 +thru 06 +load \ Tracer Onlyforth : internal \ start headerless definitions 1 ?head ! ; : external \ end headerless definitions ?head off ; \ Tools for decompiling 22feb86 | : ?: dup 4 u.r ." :" ; | : @? dup @ 6 u.r ; | : c? dup c@ 3 .r ; : s ( adr - adr+ ) ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; \ Tools for decompiling 22feb86 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; : c ( adr - adr+1) 1 d ; : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; \\ : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; \ General Dump Utility - Output UH 07Jun86 | : .2 ( n -- ) 0 <# # # #> type space ; | : .6 ( d -- ) <# # # # # # # #> type ; | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; | : emit. ( char -- ) $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; | : dln ( addr --- ) cr dup 6 u.r 2 spaces 8 2dup d.2 space over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; | : ?.n ( n1 n2 -- n1 ) 2dup = IF ." \/" drop ELSE 2 .r THEN space ; | : ?.a ( n1 n2 -- n1 ) 2dup = IF ." V" drop ELSE 1 .r THEN ; \ .head UH 03Jun86 | : .head ( addr len -- addr' len' ) swap dup -$10 and swap $0F and cr 8 spaces 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP space $10 0 DO I ?.a LOOP rot + ; \ Dump and Fill Memory Utility UH 25Aug86 Forth definitions : dump ( addr len -- ) base push hex .head bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; Tools definitions : du ( addr -- addr+$40 ) dup $40 dump $40 + ; : dl ( line# -- ) c/l * scr @ block + c/l dump ; Forth definitions \ Trace Loadscreen 29Jun86 Onlyforth \needs Tools Vocabulary Tools Tools also definitions 1 8 +thru Onlyforth \ clear \ don't forget END-TRACE after using DEBUG \ Variables do-trace UH 04Nov86 | Variable Wsave \ Variable for saving W | Variable \ end of trace trap range | Variable 'ip \ holds IP (preincrement!) | Variable nest? \ True if NEST shall be performed | Variable newnext \ Address of new Next for tracing | Variable #spaces \ for indenting nested trace | Variable tracing \ true if trace mode active \ install Tracer UH 18Nov87 Tools definitions | Code do-trace \ patch Next to new definition $C3 A mvi ( jmp ) >next sta newnext lhld >next 1+ shld Next end-code \ throw status on Return-Stack 29Jun86 | Create: npull rp@ count 2dup + even rp! r> swap cmove ; : npush ( addr len --) r> -rot over >r rp@ over 1+ - even dup rp! place npull >r >r ; | : oneline .status space query interpret -&82 allot rdrop ( delete quit from tracenext ) ; \ reenter tracer 04Nov86 | Code (step true H lxi tracing shld IP rpop Wsave lhld H W mvx Label fnext xchg M E mov H inx M D mov xchg pchl end-code | Create: nextstep (step ; | : (debug ( addr --) \ start tracing at addr dup ! ; \ check trace conditions 04Nov86 Label tracenext tracenext newnext ! IP ldax IP inx A L mov IP ldax IP inx A H mov xchg tracing lhld H A mov L ora fnext jz nest? 1+ lda A ana 0= ?[ lhld H A mov IP cmp fnext jc 0= ?[ L A mov IP' cmp fnext jc ]? ][ A xra nest? 1+ sta ]? \ low byte still set \ one trace condition satisfied W H mvx Wsave shld false H lxi tracing shld \ tracer display UH 25Jan88 ;c: nest? @ IF nest? off r> ip> push r THEN r@ nextstep >r input push output push standardi/o cr #spaces @ spaces dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces >name .name $1C col - 0 max spaces .s state push blk push >in push ['] 'quit >body push [ ' parser >body ] Literal push span push #tib push tib #tib @ npush r0 push rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; \ DEBUG with errorchecking 28Nov86 | : traceable ( cfa -- cfa' ) recursive dup @ ['] : @ case? ?exit ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN ['] r/w @ case? IF >body traceable exit THEN dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN drop >name .name ." can't be DEBUGged" quit ; also Forth definitions : debug ( -- ) \ reads a word ' traceable (debug Tools nest? off #spaces off tracing on do-trace ; \ misc. words for tracing 28Nov86Tools definitions : nest \ trace next high-level word executed 'ip @ 2- @ traceable drop nest? on ; : unnest \ ends tracing of actual word off ; \ clears trap range : endloop \ stop tracing loop 'ip @ is curvleft ] ( size order -- ) dup 0= IF 2drop exit THEN 1- &90 right 2dup curvright over forward &90 left 2dup curvleft over forward 2dup curvleft &90 left over forward curvright &90 right ; : hilbert ( size order -- ) page 0 0 setxy 0 setheading pendown curvright ; \ No newline at end of file diff --git a/8080/AmstradCPC/TURTLE.SCR b/8080/AmstradCPC/TURTLE.SCR new file mode 100644 index 0000000..3c63275 --- /dev/null +++ b/8080/AmstradCPC/TURTLE.SCR @@ -0,0 +1 @@ +\ Turtle-Graphic UH 03Dec86 Dieses File enthaelt die Definitionen fuer eine LOGO-aehnliche Turtle-Grafik. (Siehe volksFORTH-Handbuch.) \ Turtle-Graphic 05Sep86 \needs Graphics include grafik.scr \needs sin include mathe.scr 1 $05 +thru \ Turtle Variables UH 05Sep86 Onlyforth Graphics also definitions | Variable direction &90 ( degrees ) direction ! | Variable pendown? pendown? on : heading ( -- deg ) direction @ ; : seth ( deg -- ) &360 mod direction ! ; : lt ( deg -- ) heading + seth ; : rt ( deg -- ) negate lt ; \ Turtle moves 10Oct86| : scale ( trig len -- len' ) &10000 */ &5 + &10 / ; : fd ( n -- ) heading cos over scale heading sin rot scale pendown? @ IF liner ELSE mover THEN ; : bk ( n -- ) negate fd ; : xcor ( -- x ) cursor@ drop ; : ycor ( -- y ) cursor@ nip ; : setx ( x -- ) ycor move ; : sety ( y -- ) xcor swap move ; ' move Alias setxy \ Turtle writes 05Sep86 : pd ( -- ) pendown? on ; : pu ( -- ) pendown? off ; : home ( -- ) &320 &200 setxy &90 seth pd ; : ts ( -- pen papercolour pencolour ) pendown? @ paper@ (ink drop pen@ (ink drop ; \ Farben setzen UH 05Sep86 ' ink Alias pc : bg ( color -- ) dup paper@ (ink ; ' clearwindow Alias cs : fullscreen ; : splitscreen ; \ long Names 05Sep86 ' pc Alias pencolor ' bg Alias background ' cs Alias clearscreen ' seth Alias setheading ' rt Alias right ' lt Alias left ' fd Alias forward ' bk Alias back ' pd Alias pendown ' pu Alias penup ' ts Alias turtlestate \ No newline at end of file diff --git a/8080/AmstradCPC/VDOS62KX.SCR b/8080/AmstradCPC/VDOS62KX.SCR new file mode 100644 index 0000000..b39ccfd --- /dev/null +++ b/8080/AmstradCPC/VDOS62KX.SCR @@ -0,0 +1 @@ +\ Calling ROM fuer x-Laufwerk 62K-CP/M UH 03Dec86 Dieses File enthaelt die Definitionen der Schnittstelle fuer Firmware-Aufrufe unter dem 62K-CP/M, das mit dem Vortex-X Floppylaufwerken und Speichererweiterung gefahren wird. Bei anderen Systemkonfigurationen (Standard 3" Laufwerke oder ohne Speichererweiterung) kann es sein, dass die Firmware- Aufrufe anders organisiert sein muessen. (Siehe AMSDOS.SCR) Dieses File wird von dem Grafikpaket geladen, falls der entsprechende Kommentar in GRAFIK.SCR richtig gesetzt ist. \ Calling ROM fuer x-Laufwerk 62K-CP/M UH 29Nov86 Assembler definitions $F4DB | Constant systementry $004F Constant 'start Create jumprom \ Startaddr+3 in 'start, returns like a subrout.Assembler systementry call $57 c, end-code ' 3+ Alias +org UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 UH 29Nov86 \ No newline at end of file diff --git a/8080/AmstradCPC/VOLKS4TH.COM b/8080/AmstradCPC/VOLKS4TH.COM new file mode 100644 index 0000000..ce2aa6e Binary files /dev/null and b/8080/AmstradCPC/VOLKS4TH.COM differ diff --git a/8080/AmstradCPC/XINOUT.SCR b/8080/AmstradCPC/XINOUT.SCR new file mode 100644 index 0000000..5c47ef5 --- /dev/null +++ b/8080/AmstradCPC/XINOUT.SCR @@ -0,0 +1 @@ +\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 Dieses File enthaelt Definitionen, die eine erweiterte Bild- schirmdarstellung ermoeglichen: - Installation eines Terminals mit Hilfe des Wortes "Terminal:" - Editieren von Eingabezeilen In der Version 3.80a sind diese Teile aus dem Kern genommen worden, um diesen einfacher zu gestalten. \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 1 3 +thru \ Erweiterte Ausgabe 4 6 +thru \ Erweiterte Eingabe ' curon Is postlude \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87| Variable terminal : Term: ( off -- off' ) Create dup c, 2+ Does> c@ terminal @ + perform ; : Terminal: Create: Does> terminal ! ; 0 Term: curon Term: curoff Term: rvson Term: rvsoff Term: dark Term: locate drop : curleft ( -- ) at? 1- at ; : currite ( -- ) at? 1+ at ; Terminal: dumb noop noop noop noop noop 2drop ; dumb \ Erweiterte Ausgabe: Schneider 25 Zeilen UH 06Mar88 &80 Constant c/row &25 Constant c/col | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col : (at ( row col -- ) c/row 1- min swap c/col 1- min swap 2dup 'at 2! locate ; : (at? ( -- row col ) 'at 2@ ; : (page ( -- ) 0 0 'at 2! dark ; : (type ( addr len -- ) dup 'col +! 0 ?DO count (emit LOOP drop ; : (emit ( c -- ) 1 'col +! (emit ; \ Erweiterte Ausgabe: UH 04Mar88 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; ' (emit ' display 2+ ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! \ Erweiterte Eingabe UH 08OCt87| Variable maxchars | Variable oldspan oldspan off | : redisplay ( addr pos -- ) at? 2swap under + span @ rot - type space at ; | : del ( addr pos1 -- ) dup >r + dup 1+ swap span @ r> - 1- cmove -1 span +! ; | : ins ( addr pos1 -- ) dup >r + dup dup 1+ span @ r> - cmove> bl swap c! 1 span +! ; | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; | : (back ( a p1 -- a p2 ) 1- curleft (del ; | : (recall ( a p1 -- a p2 ) ?dup ?exit oldspan @ span ! 0 2dup redisplay ; \ Tastenbelegung fuer Zeilen-Editor Schneider UH 08Oct87: (decode ( addr pos1 key -- addr pos2 ) &243 case? IF dup span @ < 0=exit currite 1+ exit THEN &242 case? IF dup 0=exit curleft 1- exit THEN &224 case? IF dup span @ = ?exit (ins exit THEN #bs case? IF dup 0=exit (back exit THEN #del case? IF dup 0=exit (back exit THEN $10 case? IF span @ 2dup < and 0=exit (del exit THEN &252 case? IF (recall exit THEN #cr case? IF span @ dup maxchars ! oldspan ! dup at? rot span @ - - at space exit THEN dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; : (expect ( addr len -- ) maxchars ! span off 0 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; \ Patch UH 08Oct87 : (key ( -- char ) curon BEGIN pause (key? UNTIL curoff getkey ; ' (key ' keyboard 2+ ! ' (decode ' keyboard 6 + ! ' (expect ' keyboard 8 + ! \ No newline at end of file diff --git a/8080/AmstradCPC/disks/makedisks.sh b/8080/AmstradCPC/disks/makedisks.sh new file mode 100755 index 0000000..e50f6c4 --- /dev/null +++ b/8080/AmstradCPC/disks/makedisks.sh @@ -0,0 +1,53 @@ +#!/bin/sh +echo "Creating base.dsk ..." +iDSK base.dsk -n +iDSK base.dsk -i ../AMDDOS.SCR -t 2 +iDSK base.dsk -i ../ATARI.SCR -t 2 +iDSK base.dsk -i ../DOUBLE.SCR -t 2 +iDSK base.dsk -i ../GRAFDEMO.SCR -t 2 +iDSK base.dsk -i ../GRAFIK.SCR -t 2 +iDSK base.dsk -i ../INSTALL.SCR -t 2 +iDSK base.dsk -i ../MATHE.SCR -t 2 +iDSK base.dsk -i ../TERMINAL.SCR -t 2 +iDSK base.dsk -i ../TURTDEMO.SCR -t 2 +iDSK base.dsk -i ../TURTLE.SCR -t 2 +iDSK base.dsk -i ../VDOS62KX.SCR -t 2 +iDSK base.dsk -i ../VOLKS4TH.COM -t 2 +echo "base.dsk created!" + +echo "Creating kernel.dsk ..." +iDSK kernel.dsk -n +iDSK kernel.dsk -i ../ASS8080.SCR -t 2 +iDSK kernel.dsk -i ../ASSTRAN.SCR -t 2 +iDSK kernel.dsk -i ../DISASS.SCR -t 2 +iDSK kernel.dsk -i ../FILEINT.SCR -t 2 +iDSK kernel.dsk -i ../HASHCASH.SCR -t 2 +iDSK kernel.dsk -i ../KERNEL.COM -t 2 +iDSK kernel.dsk -i ../PORT8080.SCR -t 2 +iDSK kernel.dsk -i ../PORTZ80.SCR -t 2 +iDSK kernel.dsk -i ../PRIMED.SCR -t 2 +iDSK kernel.dsk -i ../SIMPFILE.SCR -t 2 +iDSK kernel.dsk -i ../TIMES.SCR -t 2 +echo "kernel.dsk created!" + +echo "Creating tools.dsk ..." +iDSK tools.dsk -n +iDSK tools.dsk -i ../ASS8080.SCR -t 2 +iDSK tools.dsk -i ../COPY.SCR -t 2 +iDSK tools.dsk -i ../EDITOR.SCR -t 2 +iDSK tools.dsk -i ../PRINTER.SCR -t 2 +iDSK tools.dsk -i ../RELOCATE.SCR -t 2 +iDSK tools.dsk -i ../SAVESYS.SCR -t 2 +iDSK tools.dsk -i ../SEE.SCR -t 2 +iDSK tools.dsk -i ../STARTUP.SCR -t 2 +iDSK tools.dsk -i ../TASKER.SCR -t 2 +iDSK tools.dsk -i ../TERMINAL.SCR -t 2 +iDSK tools.dsk -i ../TOOLS.SCR -t 2 +iDSK tools.dsk -i ../XINOUT.SCR -t 2 +echo "tools.dsk created!" + +echo "Creating source.dsk ..." +iDSK source.dsk -n +iDSK source.dsk -i ../SOURCE.SCR -t 2 +echo "source.dsk created!" + diff --git a/8080/AmstradCPC/disks/readme.org b/8080/AmstradCPC/disks/readme.org new file mode 100644 index 0000000..e3a6dd1 --- /dev/null +++ b/8080/AmstradCPC/disks/readme.org @@ -0,0 +1,8 @@ +* Creating Disk Images for Amstrad/Schneider CPC + +The script =makedisks.sh= will create disk images to use in Amstrad CPC +Emulator or modern disk emulator systems for the Amstrad CPC system. + +The script requires =iDSK= (https://github.com/cpcsdk/idsk) to be +installed. + diff --git a/8080/CPM/startup.fb b/8080/CPM/startup.fb index 0026e26..a68c375 100644 --- a/8080/CPM/startup.fb +++ b/8080/CPM/startup.fb @@ -1 +1 @@ -\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr include see.fb cr .( Decompiler loaded) cr include tasker.fb cr .( Multitasker loaded) cr include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O \ include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr \ include see.fb cr .( Decompiler loaded) cr \ include tasker.fb cr .( Multitasker loaded) cr \ include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file diff --git a/8080/CPM/volks4th.com b/8080/CPM/volks4th.com index ccf8f4b..a7d2060 100644 Binary files a/8080/CPM/volks4th.com and b/8080/CPM/volks4th.com differ diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile new file mode 100644 index 0000000..2760555 --- /dev/null +++ b/8086/msdos/Makefile @@ -0,0 +1,237 @@ + +fbfiles = $(wildcard src/*.fb tests/*.fb) +fthfiles = $(patsubst %.fb, %.fth, $(fbfiles)) + +fbfiles_uppercase = $(wildcard src/*.FB tests/*.FB) +fthfiles_caseconverted = $(patsubst %.fb, %.fth, \ + $(shell ../../tools/echo-tolower.py $(fbfiles_uppercase))) + +test: incltest.result logtest.result test-std.result test-blk.result \ + incltest-volks4th.result test-volks4th-min.result + +fth: $(fthfiles) $(fthfiles_caseconverted) + +clean: + rm -f *.log *.LOG *.result *.golden + rm -f dosfiles/* + +*.log: emulator/run-in-dosbox.sh + +metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb + rm -f METAFILE.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include mk-meta.fth" + dos2unix -n OUTPUT.LOG metafile.log + grep -F 'Metacompiler saved as metafile.com' metafile.log + +v4th.com: metafile.com src/meta.fb src/v4th.fth src/vf86core.fth \ + src/vf86dos.fth src/vf86file.fth src/vf86end.fth + rm -f v4th.com V4TH.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + metafile.com "include v4th.fth" + dos2unix -n OUTPUT.LOG v4th.log + mv V4TH.COM v4th.com + grep -F 'unresolved:' v4th.log + grep -F 'new kernel written as v4th.com' v4th.log + grep -i 'unresolved:.*[^ ]' v4th.log && exit 1 || true + +v4thblk.com: metafile.com src/meta.fb src/v4thblk.fth src/vf86core.fth \ + src/vf86dos.fth src/vf86file.fth src/vf86bufs.fth src/vf86end.fth + rm -f v4thblk.com V4THBLK.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + metafile.com "include v4thblk.fth" + dos2unix -n OUTPUT.LOG v4thblk.log + mv V4THBLK.COM v4thblk.com + grep -F 'unresolved:' v4thblk.log + grep -F 'new kernel written as v4thblk.com' v4thblk.log + grep -i 'unresolved:.*[^ ]' v4thblk.log && exit 1 || true + +# o4th for old volks4th - the new v4th is built with precompiled +# metacompiler metafile.com and mk-v4th.fth which writes a compile log. +o4th.com o4th.log: volks4th.com src/kernel.fb + rm -f FORTH.COM forth.com o4th.com + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + volks4th.com "include kernel.fb" + dos2unix -n OUTPUT.LOG o4th.log + mv FORTH.COM o4th.com + +v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \ + emulator/run-in-dosbox.sh + rm -f V4THFILE.COM v4thfile.com + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include v4thfile.fb" + mv V4THFILE.COM v4thfile.com + +logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb" + dos2unix -n OUTPUT.LOG $@ + +logappendtest.log: v4thfile.com tests/logapp.fth + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh v4thfile.com "include logapp.fth" + dos2unix -n OUTPUT.LOG $@ + +prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb + +prepfths = asm.fb extend.fb multi.vid dos.fb include.fb 86asm.fth \ + t86asm.fth extend2.fth multivid.fth dos2.fth dos3.fth + +incltest.log: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepsrcs) log2file.fb \ + incltest.fth) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh \ + v4thblk.com "include incltest.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + +test-std.log: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include logprep.fth include test-std.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + +test-blk.log: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include test-blk.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + +forthblkdos: v4thblk.dos v4thblk.forth + +forthdos: forthblkdos v4thfile.dos v4thfile.forth v4th0.dos v4th0.forth + +v4th0.dos: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include logprep.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4th0.forth: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include logprep.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thblk.dos: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thblk.forth: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thfile.dos: \ + $(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \ + "include log2file.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thfile.forth: \ + $(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \ + "include log2file.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +incltest-volks4th.log: v4thfile.com tests/log2file.fb tests/incltest.fth + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include incltest.fth" + dos2unix -n OUTPUT.LOG $@ + +test-volks4th-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include test-min.fth" + dos2unix -n OUTPUT.LOG $@ + + +run-editor: volks4th.com emulator/run-in-dosbox.sh + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com + + +test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core) + cat $^ > $@ + +test-std.golden: $(patsubst %, tests/golden/%.golden, \ + prelim core coreplus coreext doubltst report-noblk) + cat $^ > $@ + +test-blk.golden: $(patsubst %, tests/golden/%.golden, \ + prelim core coreplus coreext doubltst block report-blk) + cat $^ > $@ + +test-volks4th-min.golden: $(patsubst %, tests/golden/%.golden, \ + volks4th-prelim core) + cat $^ > $@ + + +%.golden: tests/golden/%.golden + cp -p $< $@ + +%-volks4th.golden: tests/golden/%.golden + cp -p $< $@ + +%.result: %.log %.golden tests/evaluate-test.sh + rm -f $@ + tests/evaluate-test.sh $(basename $@) + + +dosfiles/%: % + test -d dosfiles || mkdir dosfiles + cp $< $@ + +dosfiles/%: src/% + test -d dosfiles || mkdir dosfiles + cp $< $@ + +dosfiles/%: tests/% + test -d dosfiles || mkdir dosfiles + cp $< $@ + + +src/%.fth: src/%.fb ../../tools/fb2fth.py + ../../tools/fb2fth.py $< $@ + +tests/%.fth: tests/%.fb ../../tools/fb2fth.py + ../../tools/fb2fth.py $< $@ + +# Collective rule for converting uppercase *.FB to lowercase *.fth. +# Because make doesn't provide case changing pattern matching, +# file-by-file dependencies as with the src/%.fth and tests/%.fth +# rules doesn't seem feasible here, hence the one collective rule. + +.ONESHELL: +$(fthfiles_caseconverted): $(fbfiles_uppercase) + set -x + for fb in $^ + do + echo fb: $$fb + fth=$$(../../tools/echo-tolower.py $$fb | sed -e 's/fb$$/fth/') + ../../tools/fb2fth.py $$fb $$fth + done diff --git a/8086/msdos/emu2-4th.sys b/8086/msdos/emu2-4th.sys new file mode 100644 index 0000000..dd803c1 --- /dev/null +++ b/8086/msdos/emu2-4th.sys @@ -0,0 +1 @@ +\\ Startup: Load Standard System cas 10nov05 This file contains commands to create a full volksFORTH from theKERNEL.COM file. The new system will be saved as "VOLKS4TH.COM". If needed this file must be adapted with the simple editor in MINIMAL.COM to create a volksFORTH that can work with not 100% compatible display hardware. \ System LOAD-Screen for MS-DOS volksFORTH cas 18jul20 Onlyforth warning off include asm.fb include extend.fb include multi.vid include dos.fb include tasker.fb include timer.fb include tools.fb include neditor.fb include graphic.prn warning on clear status on .status savesystem volks4th.com bell .( new system saved as VOLKS4TH.COM ) cr \ No newline at end of file diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh new file mode 100755 index 0000000..8613f8e --- /dev/null +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -0,0 +1,30 @@ +#!/bin/bash + +set -e + +forth="$1" +forthcmd="$2" +exit="" +bye="" +if [ -n "${forthcmd}" ]; then + logname="output.log" + doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" + rm -f "${logname}" "${doslogname}" + if [ -z "${KEEPEMU}" ]; then + exit="-c exit" + bye="bye" + fi +fi + +auto_c="" +autocmd="" +pathcmd="" +if [ -n "${forth}" ]; then + auto_c="-c" + if [ -n "${FORTHPATH}" ]; then + pathcmd="path ${FORTHPATH}" + fi + autocmd="${forth} ${pathcmd} ${forthcmd} ${bye}" +fi + +dosbox -c "mount f ." -c "f:" "${auto_c}" "${autocmd}" $exit diff --git a/8086/msdos/krnlbios.fb b/8086/msdos/krnlbios.fb new file mode 100644 index 0000000..b1f6469 Binary files /dev/null and b/8086/msdos/krnlbios.fb differ diff --git a/8086/msdos/metafile.com b/8086/msdos/metafile.com new file mode 100644 index 0000000..c7a2268 Binary files /dev/null and b/8086/msdos/metafile.com differ diff --git a/8086/msdos/kernel.org b/8086/msdos/o4th.com similarity index 76% rename from 8086/msdos/kernel.org rename to 8086/msdos/o4th.com index 4c30e9f..e89aa86 100644 Binary files a/8086/msdos/kernel.org and b/8086/msdos/o4th.com differ diff --git a/8086/msdos/readme.org b/8086/msdos/readme.org index d14e788..80cfcdb 100644 --- a/8086/msdos/readme.org +++ b/8086/msdos/readme.org @@ -1,15 +1,82 @@ #+TITLE: VolksForth MS-DOS README -#+AUTHOR: Carsten Strotmann -#+DATE: <2020-06-19 Fri> +#+AUTHOR: Carsten Strotmann, Philip Zembrod +#+DATE: <2022-03-13 Sun> -* How to meta-compile a new kernel +* Refactoring in progress + +MSDOS VolksForth is currently in transition towards make based +and stream file (.fth) based builds. + +* Documentation for make based builds + +The central Makefile is written for GNU make on Linux and uses +the DOS emulator dosbox to run VolksForth and Metacompiler +binaries for building new VolksForth binaries and for running +tests. The make rules also use several Linux tools, e.g. +bash, Python, grep or dos2unix. + +volks4th.com is the old checked-in full VolksForth binary +with editor etc, manually compiled from block sources as +described in the "Previous .fb-based manual build instructions". +It is intended to remain untouched throughout the transition +period until it can be safely replaced by new .fth-based +kernels with build-in .fth interface. + +** Binary make targets + +=make v4th.com= +builds the new minimal VolksForth kernel v4th.com +from .fth sources using metafile.com. v4th.com does not have the block +words and the buffer mechanism anymore. The only way to load code from +files is via =include filename.fth=. + +=make v4thblk.com= +builds the new minimal VolksForth kernel v4thblk.com +from .fth sources using metafile.com. v4thblk.com contains the block +words and the buffer mechanism and can load and include both .fth +stream sources and .fb block sources. + +=make metafile.com= +builds the metacompiler with included .fth file interface. +It is used to build v4th.com, so metafile.com will be built +as part of the make rule for v4th.com. Note: metafile.com +is mostly still built from meta.fb, i.e. from block sources. + +=make o4th.com= +builds a new minimal VolksForth kernel from kernel.fb, i.e. +from block sources. This is equivalent to the previous +"How to meta-compile a new kernel" instruction. + +=make v4thfile.com= +adds the .fth file interface to the old volks4th binary. + +** Test make targets + +=make test= +runs all current tests. + +=make test-std.result= +runs v4th.com through the standard set of unit tests, without the block +tests, of course + +=make test-blk.result= +runs v4thblk.com through full set of unit tests, including the block +tests. + +=make test-volks4th-min.result= +runs the same initial minimal set of unit tests on v4thfile.com +which is the old volks4th.com binary with added .fth file interface. + +* Previous .fb-based manual build instructions + +** How to meta-compile a new kernel After making changes the the Forth kernel source in =kernel.fb=, restart =volksforth.com= to have a clean system and compile a new "minimal" kernel with =include kernel.fb=. This will create a new =FORTH.COM= executable. -* creating a minimal system with a simple editor +** creating a minimal system with a simple editor Execute =forth.com include minimal.sys= to generate the file =minimal.com= which contains a minimal VolksForth system with the @@ -19,11 +86,12 @@ This system can be used to edit the file =volksforth.sys= or other Forth source block files needed to create a full VolksForth system. -* creating a full VolksForth system from the minimal kernel +** creating a full VolksForth system from the minimal kernel Execute =forth.com include volks4th.sys= to create a new fully equipped VolksForth executable =volks4th.com=. -* creating a version of VolksForth that works with emu2 + +** creating a version of VolksForth that works with emu2 EMU2 is a nice PC Emulator that can run MS-DOS console applications as Linux/MacOS/Windows console applications. EMU2 can be found at diff --git a/8086/msdos/src/86asm.fth b/8086/msdos/src/86asm.fth new file mode 100644 index 0000000..b30614a --- /dev/null +++ b/8086/msdos/src/86asm.fth @@ -0,0 +1,397 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 8086 Assembler cas 10nov05 +\ This 8086 Assembler was written by Klaus Schleisiek. +\ Assembler Definitions are created with the definig word +\ CODE and closed with the word END-CODE. + +\ The 8086 Registers naming and usage in volksFORTH + +\ Intel vForth Used for 8bit-Register +\ AX A free A+ A- +\ DX D topmost Stackitem D+ D- +\ CX C free C+ C- +\ BX R Returnstack Pointer R+ R- +\ BP U User Pointer +\ SP S Stack Pointer +\ SI I Instruction Pointer +\ DI W Word Pointer, mostly free + +\ *** Block No. 1, Hexblock 1 + +\ 8086 Assembler loadscreen cas 10nov05 + Onlyforth + +| : u2/ ( 16b -- 15b ) 2/ $7FFF and ; +| : 8* ( 15b -- 16b ) 2* 2* 2* ; +| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ; + + Vocabulary Assembler + Assembler also definitions + +\ 3 &21 thru clear .( Assembler loaded ) cr + +\ *** Block No. 3, Hexblock 3 + +\ Code generating primitives cas 10nov05 + + Variable >codes \ points at table of execution vectors + +| Create nrc ] c, , here ! c! [ + + : nonrelocate nrc >codes ! ; nonrelocate + +| : >exec ( n -- n+2 ) Create dup c, 2+ + Does> c@ >codes @ + perform ; + +0 | >exec >c, | >exec >, | >exec >here + | >exec >! | >exec >c! drop + + + + +\ *** Block No. 4, Hexblock 4 + +\ 8086 Registers cas 10nov05 + + 0 Constant A 1 Constant C 2 Constant D 3 Constant R + 4 Constant S 5 Constant U 6 Constant I 7 Constant W +' I Alias SI ' W Alias DI ' R Alias BX + + 8 Constant A- 9 Constant C- $A Constant D- $B Constant R- +$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+ +' R- Alias B- ' R+ Alias B+ + + $100 Constant E: $101 Constant C: + $102 Constant S: $103 Constant D: + +| Variable isize ( specifies Size by prefix) +| : Size: ( n -- ) Create c, Does> c@ isize ! ; + 0 Size: byte 1 Size: word word 2 Size: far + +\ *** Block No. 5, Hexblock 5 + +\ 8086 Assembler System variables cas 10nov05 + +| Variable direction \ 0 reg>EA, -1 EA>reg +| Variable size \ 1 word, 0 byte, -1 undefined +| Variable displaced \ 1 direct, 0 nothing, -1 displaced +| Variable displacement + +| : setsize isize @ size ! ; +| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ; +| : wexit rdrop word ; +| : moderr word true Abort" invalid" ; +| : ?moderr ( f -- ) 0=exit moderr ; +| : ?word size @ 1- ?moderr ; +| : far? ( -- f ) size @ 2 = ; + + + +\ *** Block No. 6, Hexblock 6 + +\ 8086 addressing modes cas 10nov05 + +| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c, +| : () ( 8b1 -- 8b2 ) + 3 - dup 4 u> over 1 = or ?moderr (EA + c@ ; + + -1 Constant # $C6 Constant #) -1 Constant C* + + : ) ( u1 -- u2 ) + () 6 case? IF 0 $86 exit THEN $C0 or ; + : I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ; + + : D) ( n u1 -- n u2 ) + () over long? IF $40 ELSE $80 THEN or ; + : DI) ( n u1 u2 -- n u3 ) + I) over long? IF $80 ELSE $40 THEN xor ; + +\ *** Block No. 7, Hexblock 7 + +\ 8086 Registers and addressing modes cas 10nov05 + +| : displaced? ( [n] u1 -- [n] u1 f ) + dup #) = IF 1 exit THEN + dup $C0 and dup $40 = swap $80 = or ; + +| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit + displaced @ ?moderr displaced ! swap displacement ! ; + +| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit + size off $FF07 and ; + +| : mmode? ( 9b - 9b f) dup $C0 and ; + +| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ; + + +\ *** Block No. 8, Hexblock 8 + +\ 8086 decoding addressing modes cas 10nov05 + +| : 2address ( [n] source [displ] dest -- 15b / [n] 16b ) + size on displaced off dup # = ?moderr mmode? + IF displace False ELSE rmode True THEN direction ! + >r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit + THEN direction @ + IF r> 8* >r mmode? IF displace + ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN + ELSE rmode 8* + THEN r> or $C0 xor ; + +| : 1address ( [displ] 9b -- 9b ) + # case? ?moderr size on displaced off direction off + mmode? IF displace setsize ELSE rmode THEN $C0 xor ; + + +\ *** Block No. 9, Hexblock 9 + +\ 8086 assembler cas 10nov05 +| : immediate? ( u -- u f ) dup 0< ; + +| : nonimmediate ( u -- u ) immediate? ?moderr ; + +| : r/m 7 and ; + +| : reg $38 and ; + +| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ; + +| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and + IF dup $100 and IF dup r/m 8* swap reg 8/ + or $C0 or direction off + THEN True exit + THEN False ; + +\ *** Block No. 10, Hexblock a + +\ 8086 Registers and addressing modes cas 10nov05 + +| : w, size @ or >c, ; + +| : dw, size @ or direction @ IF 2 xor THEN >c, ; + +| : ?word, ( u1 f -- ) IF >, exit THEN >c, ; + +| : direct, displaced @ 0=exit + displacement @ dup long? displaced @ 1+ or ?word, ; + +| : r/m, >c, direct, ; + +| : data, size @ ?word, ; + + + +\ *** Block No. 11, Hexblock b + +\ 8086 Arithmetic instructions cas 10nov05 + +| : Arith: ( code -- ) Create , + Does> @ >r 2address immediate? + IF rmode? IF ?akku IF r> size @ + IF 5 or >c, >, wexit THEN + 4 or >c, >c, wexit THEN THEN + r@ or $80 size @ or r> 0< + IF size @ IF 2 pick long? 0= IF 2 or size off THEN + THEN THEN >c, >c, direct, data, wexit + THEN r> dw, r/m, wexit ; + + $8000 Arith: add $0008 Arith: or + $8010 Arith: adc $8018 Arith: sbb + $0020 Arith: and $8028 Arith: sub + $0030 Arith: xor $8038 Arith: cmp + +\ *** Block No. 12, Hexblock c + +\ 8086 move push pop cas 10nov05 + + : mov [ Forth ] 2address immediate? + IF rmode? IF r/m $B0 or size @ IF 8 or THEN + >c, data, wexit + THEN $C6 w, r/m, data, wexit + THEN 6 case? IF $A2 dw, direct, wexit THEN + smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit + THEN $88 dw, r/m, wexit ; + +| : pupo [ Forth ] >r 1address ?word + smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN + rmode? IF r/m $50 or r> or >c, wexit THEN + r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ; + + : push 0 pupo ; : pop 8 pupo ; + +\ *** Block No. 13, Hexblock d + +\ 8086 inc & dec , effective addresses cas 10nov05 + +| : inc/dec [ Forth ] >r 1address rmode? + IF size @ IF r/m $40 or r> or >c, wexit THEN + THEN $FE w, r> or r/m, wexit ; + + : dec 8 inc/dec ; : inc 0 inc/dec ; + +| : EA: ( code -- ) Create c, [ Forth ] + Does> >r 2address nonimmediate + rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ; + + $C4 EA: les $8D EA: lea $C5 EA: lds + + + + +\ *** Block No. 14, Hexblock e + +\ 8086 xchg segment prefix cas 10nov05 + : xchg [ Forth ] 2address nonimmediate rmode? + IF size @ IF dup r/m 0= + IF 8/ true ELSE dup $38 and 0= THEN + IF r/m $90 or >c, wexit THEN + THEN THEN $86 w, r/m, wexit ; + +| : 1addr: ( code -- ) Create c, [ Forth ] + Does> c@ >r 1address $F6 w, r> or r/m, wexit ; + + $10 1addr: com $18 1addr: neg + $20 1addr: mul $28 1addr: imul + $38 1addr: idiv $30 1addr: div + + : seg ( 8b -) [ Forth ] + $100 xor dup $FFFC and ?moderr 8* $26 or >c, ; + +\ *** Block No. 15, Hexblock f + +\ 8086 test not neg mul imul div idiv cas 10nov05 + + : test [ Forth ] 2address immediate? + IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN + $F6 w, r/m, data, wexit + THEN $84 w, r/m, wexit ; + +| : in/out [ Forth ] >r 1address setsize + $C2 case? IF $EC r> or w, wexit THEN + 6 - ?moderr $E4 r> or w, displacement @ >c, wexit ; + + : out 2 in/out ; : in 0 in/out ; + + : int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ; + + + +\ *** Block No. 16, Hexblock 10 + +\ 8086 shifts and string instructions cas 10nov05 + +| : Shifts: ( code -- ) Create c, [ Forth ] + Does> c@ >r C* case? >r 1address + r> direction ! $D0 dw, r> or r/m, wexit ; + + $00 Shifts: rol $08 Shifts: ror + $10 Shifts: rcl $18 Shifts: rcr + $20 Shifts: shl $28 Shifts: shr + $38 Shifts: sar ' shl Alias sal + +| : Str: ( code -- ) Create c, + Does> c@ setsize w, wexit ; + + $A6 Str: cmps $AC Str: lods $A4 Str: movs + $AE Str: scas $AA Str: stos + +\ *** Block No. 17, Hexblock 11 + +\ implied 8086 instructions cas 10nov05 + + : Byte: ( code -- ) Create c, Does> c@ >c, ; + : Word: ( code -- ) Create , Does> @ >, ; + + $37 Byte: aaa $AD5 Word: aad $AD4 Word: aam + $3F Byte: aas $98 Byte: cbw $F8 Byte: clc + $FC Byte: cld $FA Byte: cli $F5 Byte: cmc + $99 Byte: cwd $27 Byte: daa $2F Byte: das + $F4 Byte: hlt $CE Byte: into $CF Byte: iret + $9F Byte: lahf $F0 Byte: lock $90 Byte: nop + $9D Byte: popf $9C Byte: pushf $9E Byte: sahf + $F9 Byte: stc $FD Byte: std $FB Byte: sti + $9B Byte: wait $D7 Byte: xlat + $C3 Byte: ret $CB Byte: lret + $F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep + +\ *** Block No. 18, Hexblock 12 + +\ 8086 jmp call conditions cas 10nov05 +| : jmp/call >r setsize # case? [ Forth ] + IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit + THEN >here 2+ - r> + IF dup long? 0= IF $EB >c, >c, wexit THEN $E9 + ELSE $E8 THEN >c, 1- >, wexit + THEN 1address $FF >c, $10 or r> + + far? IF 8 or THEN r/m, wexit ; + : call 0 jmp/call ; : jmp $10 jmp/call ; + + $71 Constant OS $73 Constant CS + $75 Constant 0= $77 Constant >= + $79 Constant 0< $7B Constant PE + $7D Constant < $7F Constant <= + $E2 Constant C0= $E0 Constant ?C0= + : not 1 [ Forth ] xor ; + +\ *** Block No. 19, Hexblock 13 + +\ 8086 conditional branching cas 10nov05 + + : +ret $C2 >c, >, ; + : +lret $CA >c, >, ; + +| : ?range dup long? abort" out of range" ; + + : ?[ >, >here 1- ; + : ]? >here over 1+ - ?range swap >c! ; + : ][ $EB ?[ swap ]? ; + : ?[[ ?[ swap ; + : [[ >here ; + : ?] >c, >here 1+ - ?range >c, ; + : ]] $EB ?] ; + : ]]? ]] ]? ; + + +\ *** Block No. 20, Hexblock 14 + +\ Next user' end-code ;c: cas 10nov05 + + : Next lods A W xchg W ) jmp + >here next-link @ >, next-link ! ; + + : u' ' >body c@ ; + + Forth definitions + +\needs end-code : end-code toss also ; + + Assembler definitions + + : ;c: recover # call last off end-code 0 ] ; + + + +\ *** Block No. 21, Hexblock 15 + +\ 8086 Assembler, Forth words cas 10nov05 + Onlyforth + + : Assembler Assembler [ Assembler ] wexit ; + + : ;code 0 ?pairs compile (;code + reveal [compile] [ Assembler ; immediate + + : Code Create [ Assembler ] >here dup 2- >! Assembler ; + + : >label ( addr -- ) + here | Create immediate swap , 4 hallot + here 4 - heap 4 cmove heap last @ (name> ! dp ! + Does> ( -- addr ) @ state @ 0=exit [compile] Literal ; + + : Label [ Assembler ] >here >label Assembler ; + + + clear .( Assembler loaded ) cr diff --git a/8086/msdos/ansi.vid b/8086/msdos/src/ansi.vid similarity index 100% rename from 8086/msdos/ansi.vid rename to 8086/msdos/src/ansi.vid diff --git a/8086/msdos/asm.fb b/8086/msdos/src/asm.fb similarity index 100% rename from 8086/msdos/asm.fb rename to 8086/msdos/src/asm.fb diff --git a/8086/msdos/src/asm.fth b/8086/msdos/src/asm.fth new file mode 100644 index 0000000..5b0e289 --- /dev/null +++ b/8086/msdos/src/asm.fth @@ -0,0 +1,437 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 8086 Assembler cas 10nov05 +This 8086 Assembler was written by Klaus Schleisiek. +Assembler Definitions are created with the definig word +CODE and closed with the word END-CODE. + +The 8086 Registers naming and usage in volksFORTH + +Intel vForth Used for 8bit-Register +AX A free A+ A- +DX D topmost Stackitem D+ D- +CX C free C+ C- +BX R Returnstack Pointer R+ R- +BP U User Pointer +SP S Stack Pointer +SI I Instruction Pointer +DI W Word Pointer, mostly free + +\ *** Block No. 1, Hexblock 1 + +\ 8086 Assembler loadscreen cas 10nov05 + Onlyforth + +| : u2/ ( 16b -- 15b ) 2/ $7FFF and ; +| : 8* ( 15b -- 16b ) 2* 2* 2* ; +| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ; + + Vocabulary Assembler + Assembler also definitions + + 3 &21 thru clear .( Assembler loaded ) cr + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ conditional Assembler compiler cas 10nov05 + here + + : temp-assembler ( addr -- ) hide last off dp ! + " ASSEMBLER" find nip ?exit here $1800 + sp@ u> + IF display cr ." Assembler won't fit" abort THEN + here sp@ $1800 - dp ! 1 load dp ! ; + + temp-assembler \\ + + : blocks ( n -- addr / ff ) + first @ >r dup 0 ?DO freebuffer LOOP + [ b/blk negate ] Literal * first @ + r@ u> r> and ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ Code generating primitives cas 10nov05 + + Variable >codes \ points at table of execution vectors + +| Create nrc ] c, , here ! c! [ + + : nonrelocate nrc >codes ! ; nonrelocate + +| : >exec ( n -- n+2 ) Create dup c, 2+ + Does> c@ >codes @ + perform ; + +0 | >exec >c, | >exec >, | >exec >here + | >exec >! | >exec >c! drop + + + + +\ *** Block No. 4, Hexblock 4 + +\ 8086 Registers cas 10nov05 + + 0 Constant A 1 Constant C 2 Constant D 3 Constant R + 4 Constant S 5 Constant U 6 Constant I 7 Constant W +' I Alias SI ' W Alias DI ' R Alias BX + + 8 Constant A- 9 Constant C- $A Constant D- $B Constant R- +$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+ +' R- Alias B- ' R+ Alias B+ + + $100 Constant E: $101 Constant C: + $102 Constant S: $103 Constant D: + +| Variable isize ( specifies Size by prefix) +| : Size: ( n -- ) Create c, Does> c@ isize ! ; + 0 Size: byte 1 Size: word word 2 Size: far + +\ *** Block No. 5, Hexblock 5 + +\ 8086 Assembler System variables cas 10nov05 + +| Variable direction \ 0 reg>EA, -1 EA>reg +| Variable size \ 1 word, 0 byte, -1 undefined +| Variable displaced \ 1 direct, 0 nothing, -1 displaced +| Variable displacement + +| : setsize isize @ size ! ; +| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ; +| : wexit rdrop word ; +| : moderr word true Abort" invalid" ; +| : ?moderr ( f -- ) 0=exit moderr ; +| : ?word size @ 1- ?moderr ; +| : far? ( -- f ) size @ 2 = ; + + + +\ *** Block No. 6, Hexblock 6 + +\ 8086 addressing modes cas 10nov05 + +| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c, +| : () ( 8b1 -- 8b2 ) + 3 - dup 4 u> over 1 = or ?moderr (EA + c@ ; + + -1 Constant # $C6 Constant #) -1 Constant C* + + : ) ( u1 -- u2 ) + () 6 case? IF 0 $86 exit THEN $C0 or ; + : I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ; + + : D) ( n u1 -- n u2 ) + () over long? IF $40 ELSE $80 THEN or ; + : DI) ( n u1 u2 -- n u3 ) + I) over long? IF $80 ELSE $40 THEN xor ; + +\ *** Block No. 7, Hexblock 7 + +\ 8086 Registers and addressing modes cas 10nov05 + +| : displaced? ( [n] u1 -- [n] u1 f ) + dup #) = IF 1 exit THEN + dup $C0 and dup $40 = swap $80 = or ; + +| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit + displaced @ ?moderr displaced ! swap displacement ! ; + +| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit + size off $FF07 and ; + +| : mmode? ( 9b - 9b f) dup $C0 and ; + +| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ; + + +\ *** Block No. 8, Hexblock 8 + +\ 8086 decoding addressing modes cas 10nov05 + +| : 2address ( [n] source [displ] dest -- 15b / [n] 16b ) + size on displaced off dup # = ?moderr mmode? + IF displace False ELSE rmode True THEN direction ! + >r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit + THEN direction @ + IF r> 8* >r mmode? IF displace + ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN + ELSE rmode 8* + THEN r> or $C0 xor ; + +| : 1address ( [displ] 9b -- 9b ) + # case? ?moderr size on displaced off direction off + mmode? IF displace setsize ELSE rmode THEN $C0 xor ; + + +\ *** Block No. 9, Hexblock 9 + +\ 8086 assembler cas 10nov05 +| : immediate? ( u -- u f ) dup 0< ; + +| : nonimmediate ( u -- u ) immediate? ?moderr ; + +| : r/m 7 and ; + +| : reg $38 and ; + +| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ; + +| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and + IF dup $100 and IF dup r/m 8* swap reg 8/ + or $C0 or direction off + THEN True exit + THEN False ; + +\ *** Block No. 10, Hexblock a + +\ 8086 Registers and addressing modes cas 10nov05 + +| : w, size @ or >c, ; + +| : dw, size @ or direction @ IF 2 xor THEN >c, ; + +| : ?word, ( u1 f -- ) IF >, exit THEN >c, ; + +| : direct, displaced @ 0=exit + displacement @ dup long? displaced @ 1+ or ?word, ; + +| : r/m, >c, direct, ; + +| : data, size @ ?word, ; + + + +\ *** Block No. 11, Hexblock b + +\ 8086 Arithmetic instructions cas 10nov05 + +| : Arith: ( code -- ) Create , + Does> @ >r 2address immediate? + IF rmode? IF ?akku IF r> size @ + IF 5 or >c, >, wexit THEN + 4 or >c, >c, wexit THEN THEN + r@ or $80 size @ or r> 0< + IF size @ IF 2 pick long? 0= IF 2 or size off THEN + THEN THEN >c, >c, direct, data, wexit + THEN r> dw, r/m, wexit ; + + $8000 Arith: add $0008 Arith: or + $8010 Arith: adc $8018 Arith: sbb + $0020 Arith: and $8028 Arith: sub + $0030 Arith: xor $8038 Arith: cmp + +\ *** Block No. 12, Hexblock c + +\ 8086 move push pop cas 10nov05 + + : mov [ Forth ] 2address immediate? + IF rmode? IF r/m $B0 or size @ IF 8 or THEN + >c, data, wexit + THEN $C6 w, r/m, data, wexit + THEN 6 case? IF $A2 dw, direct, wexit THEN + smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit + THEN $88 dw, r/m, wexit ; + +| : pupo [ Forth ] >r 1address ?word + smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN + rmode? IF r/m $50 or r> or >c, wexit THEN + r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ; + + : push 0 pupo ; : pop 8 pupo ; + +\ *** Block No. 13, Hexblock d + +\ 8086 inc & dec , effective addresses cas 10nov05 + +| : inc/dec [ Forth ] >r 1address rmode? + IF size @ IF r/m $40 or r> or >c, wexit THEN + THEN $FE w, r> or r/m, wexit ; + + : dec 8 inc/dec ; : inc 0 inc/dec ; + +| : EA: ( code -- ) Create c, [ Forth ] + Does> >r 2address nonimmediate + rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ; + + $C4 EA: les $8D EA: lea $C5 EA: lds + + + + +\ *** Block No. 14, Hexblock e + +\ 8086 xchg segment prefix cas 10nov05 + : xchg [ Forth ] 2address nonimmediate rmode? + IF size @ IF dup r/m 0= + IF 8/ true ELSE dup $38 and 0= THEN + IF r/m $90 or >c, wexit THEN + THEN THEN $86 w, r/m, wexit ; + +| : 1addr: ( code -- ) Create c, [ Forth ] + Does> c@ >r 1address $F6 w, r> or r/m, wexit ; + + $10 1addr: com $18 1addr: neg + $20 1addr: mul $28 1addr: imul + $38 1addr: idiv $30 1addr: div + + : seg ( 8b -) [ Forth ] + $100 xor dup $FFFC and ?moderr 8* $26 or >c, ; + +\ *** Block No. 15, Hexblock f + +\ 8086 test not neg mul imul div idiv cas 10nov05 + + : test [ Forth ] 2address immediate? + IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN + $F6 w, r/m, data, wexit + THEN $84 w, r/m, wexit ; + +| : in/out [ Forth ] >r 1address setsize + $C2 case? IF $EC r> or w, wexit THEN + 6 - ?moderr $E4 r> or w, displacement @ >c, wexit ; + + : out 2 in/out ; : in 0 in/out ; + + : int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ; + + + +\ *** Block No. 16, Hexblock 10 + +\ 8086 shifts and string instructions cas 10nov05 + +| : Shifts: ( code -- ) Create c, [ Forth ] + Does> c@ >r C* case? >r 1address + r> direction ! $D0 dw, r> or r/m, wexit ; + + $00 Shifts: rol $08 Shifts: ror + $10 Shifts: rcl $18 Shifts: rcr + $20 Shifts: shl $28 Shifts: shr + $38 Shifts: sar ' shl Alias sal + +| : Str: ( code -- ) Create c, + Does> c@ setsize w, wexit ; + + $A6 Str: cmps $AC Str: lods $A4 Str: movs + $AE Str: scas $AA Str: stos + +\ *** Block No. 17, Hexblock 11 + +\ implied 8086 instructions cas 10nov05 + + : Byte: ( code -- ) Create c, Does> c@ >c, ; + : Word: ( code -- ) Create , Does> @ >, ; + + $37 Byte: aaa $AD5 Word: aad $AD4 Word: aam + $3F Byte: aas $98 Byte: cbw $F8 Byte: clc + $FC Byte: cld $FA Byte: cli $F5 Byte: cmc + $99 Byte: cwd $27 Byte: daa $2F Byte: das + $F4 Byte: hlt $CE Byte: into $CF Byte: iret + $9F Byte: lahf $F0 Byte: lock $90 Byte: nop + $9D Byte: popf $9C Byte: pushf $9E Byte: sahf + $F9 Byte: stc $FD Byte: std $FB Byte: sti + $9B Byte: wait $D7 Byte: xlat + $C3 Byte: ret $CB Byte: lret + $F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep + +\ *** Block No. 18, Hexblock 12 + +\ 8086 jmp call conditions cas 10nov05 +| : jmp/call >r setsize # case? [ Forth ] + IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit + THEN >here 2+ - r> + IF dup long? 0= IF $EB >c, >c, wexit THEN $E9 + ELSE $E8 THEN >c, 1- >, wexit + THEN 1address $FF >c, $10 or r> + + far? IF 8 or THEN r/m, wexit ; + : call 0 jmp/call ; : jmp $10 jmp/call ; + + $71 Constant OS $73 Constant CS + $75 Constant 0= $77 Constant >= + $79 Constant 0< $7B Constant PE + $7D Constant < $7F Constant <= + $E2 Constant C0= $E0 Constant ?C0= + : not 1 [ Forth ] xor ; + +\ *** Block No. 19, Hexblock 13 + +\ 8086 conditional branching cas 10nov05 + + : +ret $C2 >c, >, ; + : +lret $CA >c, >, ; + +| : ?range dup long? abort" out of range" ; + + : ?[ >, >here 1- ; + : ]? >here over 1+ - ?range swap >c! ; + : ][ $EB ?[ swap ]? ; + : ?[[ ?[ swap ; + : [[ >here ; + : ?] >c, >here 1+ - ?range >c, ; + : ]] $EB ?] ; + : ]]? ]] ]? ; + + +\ *** Block No. 20, Hexblock 14 + +\ Next user' end-code ;c: cas 10nov05 + + : Next lods A W xchg W ) jmp + >here next-link @ >, next-link ! ; + + : u' ' >body c@ ; + + Forth definitions + +\needs end-code : end-code toss also ; + + Assembler definitions + + : ;c: recover # call last off end-code 0 ] ; + + + +\ *** Block No. 21, Hexblock 15 + +\ 8086 Assembler, Forth words cas 10nov05 + Onlyforth + + : Assembler Assembler [ Assembler ] wexit ; + + : ;code 0 ?pairs compile (;code + reveal [compile] [ Assembler ; immediate + + : Code Create [ Assembler ] >here dup 2- >! Assembler ; + + : >label ( addr -- ) + here | Create immediate swap , 4 hallot + here 4 - heap 4 cmove heap last @ (name> ! dp ! + Does> ( -- addr ) @ state @ 0=exit [compile] Literal ; + + : Label [ Assembler ] >here >label Assembler ; + +\ *** Block No. 22, Hexblock 16 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/bios.vid b/8086/msdos/src/bios.vid similarity index 100% rename from 8086/msdos/bios.vid rename to 8086/msdos/src/bios.vid diff --git a/8086/msdos/blocking.fb b/8086/msdos/src/blocking.fb similarity index 100% rename from 8086/msdos/blocking.fb rename to 8086/msdos/src/blocking.fb diff --git a/8086/msdos/src/blocking.fth b/8086/msdos/src/blocking.fth new file mode 100644 index 0000000..657d78b --- /dev/null +++ b/8086/msdos/src/blocking.fth @@ -0,0 +1,57 @@ + +\ *** Block No. 0, Hexblock 0 + +\ cas 11nov05 +Routines to copy physical blocks into files. + +The copy will done from the current file and drive into a new +file created in on the current MS-DOS drive and sub-directory. +So there can be a different drives used in the DIRECT Mode and +in the FILE Mode. + +This command sequence will copy the physical blocks 10-20 on +driver C: into file "TEST.FB" on drive D: in Subdirectory +"\VOLKS". + + +KERNEL.FB D: CD \VOLKS +DIRECT C: +10 20 BLOCKS>FILE TEST.FB + +\ *** Block No. 1, Hexblock 1 + +\ copy physical blocks to file cas 10nov05 + +| File outfile + + : blocks>file ( from to -- ) [ Dos ] + isfile@ -rot outfile make 1+ swap + ?DO I over (block + ds@ swap b/blk isfile@ lfputs + LOOP close isfile ! ; + + + + + + + + +\ *** Block No. 2, Hexblock 2 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/ced.fb b/8086/msdos/src/ced.fb similarity index 100% rename from 8086/msdos/ced.fb rename to 8086/msdos/src/ced.fb diff --git a/8086/msdos/src/ced.fth b/8086/msdos/src/ced.fth new file mode 100644 index 0000000..e2ada58 --- /dev/null +++ b/8086/msdos/src/ced.fth @@ -0,0 +1,152 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Commandline EDitor for volksFORTH rev. 3.80 cas 10nov05 +This File contains definitions to create an editable Forth +command line with history. +The commandline histroy allows older commands to be recalled. +These older commands will be stored in Screen 0 in a file called +"history" and will be preserved even when calling SAVE-SYSTEM. + + +Keys: + Cursor left/right   + Delete Char und <- + Delete Line + toggle Insert + finish line + Jump to Beginning/End of Line + recall older commands   + +\ *** Block No. 1, Hexblock 1 + +\ Commandline EDitor LOAD-Screen cas 10nov05 + + +: curleft ( -- ) at? 1- at ; +: currite ( -- ) at? 1+ at ; + +1 5 +thru \ enhanced Input + +.( Commandline Editor loaded ) cr + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ History -- Commandhistory cas 10nov05 +makefile history 1 more + +| Variable line# line# off +| Variable lastline# lastline# off + +| : 'history ( n -- addr ) isfile push history + c/l * b/blk /mod block + ; + +| : @line ( n -- addr len ) 'history c/l -trailing ; +| : !history ( addr line# -- ) + 'history dup c/l blank span @ c/l min cmove update ; +| : @history ( addr line# -- ) + @line rot swap dup span ! cmove ; + +| : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; + +\ *** Block No. 3, Hexblock 3 + +\ End of input cas 10nov05 + +| Variable maxchars | Variable insert insert on + +| : -text ( a1 a2 l -- 0=equal ) bounds + ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; + +| : done ( a p1 -- a p2 ) 2dup + at? rot - span @ dup maxchars ! + at space blankline + line# @ @line span @ = IF span @ -text 0=exit 2dup THEN + drop lastline# @ !history 1 lastline# +line ; + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ enhanced input cas 10nov05 +| : redisplay ( addr pos -- ) + at? 2swap span @ swap /string type blankline at ; + +| : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap + span @ r> - cmove -1 span +! ; +| : ins ( addr pos1 -- ) dup >r + dup dup 1+ + span @ r> - cmove> bl swap c! 1 span +! ; + +| : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; +| : back ( a p1 -- a p2 ) 1- curleft delete ; + +| : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history + dup 0 redisplay at? span @ + at span @ ; + +| : r insert @ IF 2dup ins THEN 2dup + + r> swap c! 1+ dup span @ max span ! 2dup redisplay ; + +\ *** Block No. 6, Hexblock 6 + +\ Patch cas 10nov05 + +: showcur ( -- ) + insert @ IF &11 ELSE &6 THEN &12 curshape ; + +: (expect ( addr len -- ) maxchars ! span off + lastline# @ line# ! 0 + BEGIN span @ maxchars @ u< + WHILE key decode showcur REPEAT 2drop ; + +' (decode ' keyboard 6 + ! +' (expect ' keyboard 8 + ! + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/disasm.fb b/8086/msdos/src/disasm.fb similarity index 100% rename from 8086/msdos/disasm.fb rename to 8086/msdos/src/disasm.fb diff --git a/8086/msdos/src/disasm.fth b/8086/msdos/src/disasm.fth new file mode 100644 index 0000000..17fb9d5 --- /dev/null +++ b/8086/msdos/src/disasm.fth @@ -0,0 +1,836 @@ + +\ *** Block No. 0, Hexblock 0 + +\ + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ A disassembler for the 8086 by Charles Curley cas 10nov05 +\ adapted to volksFORTH-83 by B. Molte + + | : internal 1 ?head ! ; + | : external ?head off ; + + onlyFORTH forth DEFINITIONS DECIMAL + + VOCABULARY DISAM DISAM also DEFINITIONS + + 2 capacity 1- thru + onlyforth + + cr .( Use DIS to disassemble word. ) + cr .( ESC will stop the output. ) + + +\ *** Block No. 2, Hexblock 2 + +\ cas 10nov05 + + internal + + : [and] and ; \ the forth and + : [or] or ; + + : mask ( n maskb -- n n' ) over and ; + + 5 constant 5 \ save some space + 6 constant 6 + 7 constant 7 + 8 constant 8 + + + + +\ *** Block No. 3, Hexblock 3 + +\ + internal + + : EXEC [and] 2* R> + PERFORM ; + + : STOP[ + 0 ?pairs [compile] [ reveal ; immediate restrict + + code shift> \ n ct --- n' | shift n right ct times + D C mov D pop D C* shr next end-code +\ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ; + + code SEXT \ n --- n' | sign extend lower half of n to upper + D A mov cbw A D mov next end-code +\ : hsext $FF and dup $80 and IF $FF00 or THEN ; + + +\ *** Block No. 4, Hexblock 4 + +\ + external + VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor + internal + + VARIABLE CP + VARIABLE OPS \ operand count + + : cp@ cp @ ; + : C? C@ . ; + + : (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You + \ dump/dis any segment w/ any + : (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting + \ RELOC correctly. + : SETSEG RELOC 2+ ! ; + +\ *** Block No. 5, Hexblock 5 + +\ + external + + DEFER T@ DEFER TC@ + + : HOMESEG ds@ SETSEG ; HOMESEG + + : SEG? RELOC 2+ @ 4 U.r ; + + : .seg:off seg? ." :" cp@ 4 u.r 2 spaces ; + + : MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY + + + + + +\ *** Block No. 6, Hexblock 6 + +\ + internal + + + : oops ." ??? " ; + + : OOPS0 oops ; + : OOPS1 oops drop ; + : OOPS2 oops 2drop ; + + + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ + + : NEXTB CP@ TC@ 1 CP +! ; + : NEXTW CP@ T@ 2 CP +! ; + + : .myself \ --- | have the current word print out its name. + LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ + internal + + VARIABLE IM \ 2nd operand extension flag/ct + + : ?DISP \ op ext --- op ext | does MOD operand have a disp? + DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then + 0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ; + + +: .SELF \ -- | create a word which prints its name + CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc! + + + + + +\ *** Block No. 9, Hexblock 9 + +\ register byte/word + internal + + create wreg-tab ," ACDRSUIW" + create breg-tab ," A-C-D-R-A+C+D+R+" + + : .16REG \ r# --- | register printed out + 7 and wreg-tab 1+ + c@ emit space ; + + : .8REG \ r# --- | register printed out + 7 and 2* breg-tab 1+ + 2 type space ; + + : .A 0 .16reg ; : .A- 0 .8reg ; + : .D 2 .16reg ; + + + +\ *** Block No. 10, Hexblock a + +\ indizierte/indirekte Adressierung cas 10nov05 + + internal + + : ?d DUP 6 shift> 3 [and] 1 3 uwithin ; + + : .D) ( disp_flag ext -- op ) \ indirect + ?d IF ." D" THEN ." ) " ; \ with/without Displacement + + : .I) ( disp_flag ext -- op ) \ indexted indirect + ?d IF ." D" THEN ." I) " ; \ with/without Displacement + + + + + + +\ *** Block No. 11, Hexblock b + +\ indexed/indirect addressing cas 10nov05 + internal + + : I) 6 .16reg .D) ; + : W) 7 .16reg .D) ; + : R) 3 .16reg .D) ; + : S) 4 .16reg .D) ; + : U) 5 .16reg .D) ; + + : U+W) 5 .16reg 7 .16reg .I) ; + : R+I) 3 .16reg 6 .16reg .I) ; + : U+I) 5 .16reg 6 .16reg .I) ; + : R+W) 3 .16reg 7 .16reg .I) ; + + : .# ." # " ; + + +\ *** Block No. 12, Hexblock c + +\ + internal + + : (.R/M) \ op ext --- | print a register + IM OFF SWAP 1 [and] IF .16REG exit then .8REG ; + + : .R/M \ op ext --- op ext | print r/m as register + 2DUP (.R/M) ; + + : .REG \ op ext --- op ext | print reg as register + 2DUP 3 shift> (.R/M) ; + + + + + + +\ *** Block No. 13, Hexblock d + +\ + internal + + CREATE SEGTB ," ECSD" + + : (.seg ( n -- ) + 3 shift> 3 and segtb + 1+ c@ emit ; + + : .SEG \ s# --- | register printed out + (.seg ." : " ; + + : SEG: \ op --- | print segment overrides + (.seg ." S:" ; + + + + +\ *** Block No. 14, Hexblock e + +\ + internal + : disp@ ( ops-cnt -- ) + ops +! CP@ IM @ + IM off ." $" ; + + : BDISP \ --- | do if displacement is byte + 1 disp@ TC@ sext U. ; + + : WDisp \ --- | do if displacement is word + 2 disp@ T@ U. ; + + : .DISP \ op ext --- op ext | print displacement + DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[ + + : BIMM \ --- | do if immed. value is byte + 1 disp@ TC@ . ; + +\ *** Block No. 15, Hexblock f + +\ + internal + + + : .MREG \ op ext --- op ext | register(s) printed out + disp + $C7 mask 6 = IF WDISP ." ) " exit then + $C0 mask $C0 - 0= IF .R/M exit THEN + .DISP DUP 7 exec + R+I) R+W) U+I) U+W) \ I) oder DI) + I) W) U) R) \ ) oder D) + ; + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ + internal + + : .SIZE \ op --- | decodes for size; WORD is default + 1 [and] 0= IF ." BYTE " THEN ; + + create adj-tab ," DAADASAAAAASAAMAAD" + + : .adj-tab 3 * adj-tab 1+ + 3 type space ; + + : ADJUSTS \ op --- | the adjusts + 3 shift> 3 [and] .adj-tab ; + + : .AAM 4 .adj-tab nextb 2drop ; + : .AAD 5 .adj-tab nextb 2drop ; + + +\ *** Block No. 17, Hexblock 11 + +\ + internal + : .POP \ op --- | print pops + DUP 8 = IF OOPS1 THEN .SEG ." POP " ; + + : .PUSH \ op --- | print pushes + .SEG ." PUSH " ; + + : P/P \ op --- | pushes or pops + 1 mask IF .pop ELSE .push THEN ; + + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ +internal + : P/SEG \ op --- | push or seg overrides + DUP 5 shift> 1 exec P/P SEG: STOP[ + + : P/ADJ \ op --- | pop or adjusts + DUP 5 shift> 1 exec P/P ADJUSTS STOP[ + + : 0GP \ op --- op | opcode decoded & printed + 4 mask IF 1 mask + IF WDISP ELSE BIMM THEN .# + 1 [and] IF .A ELSE .A- THEN ELSE + NEXTB OVER 2 [and] + IF .MREG .REG ELSE ?DISP .REG .MREG + THEN 2DROP THEN ; + + +\ *** Block No. 19, Hexblock 13 + +\ + external + .SELF ADD .SELF ADC .SELF AND .SELF XOR + .SELF OR .SELF SBB .SELF SUB .SELF CMP + + internal + + : 0GROUP \ op --- | select 0 group to print + DUP 0GP 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + : LOWS \ op --- | 0-3f opcodes printed out + DUP 7 EXEC + 0GROUP 0GROUP 0GROUP 0GROUP + 0GROUP 0GROUP P/SEG P/ADJ STOP[ + + +\ *** Block No. 20, Hexblock 14 + +\ + internal + + : .REGGP \ op --- | register group defining word + CREATE LAST @ , DOES> @ SWAP .16REG .name ; + + external + + .REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP + + : POPs \ op --- | handle illegal opcode for cs pop + $38 mask 8 = IF ." illegal" DROP ELSE POP THEN ; + +: REGS \ op --- | 40-5f opcodes printed out + DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[ + + +\ *** Block No. 21, Hexblock 15 + +\ conditional branches + + create branch-tab + ," O NO B NB E NE BE NBES NS P NP L GE LE NLE" + + : .BRANCH \ op --- | branch printed out w/ dest. + NEXTB SEXT CP@ + u. ASCII J EMIT + &15 [and] 3 * branch-tab 1+ + 3 type ; + + + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ +\\ + + + + + + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ +internal + + : MEDS \ op --- | 40-7f opcodes printed out + DUP 4 shift> 3 exec + REGS REGS OOPS1 .BRANCH STOP[ + + : 80/81 \ op --- | secondary at 80 or 81 + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ + internal + : 83S \ op --- | secondary at 83 + NEXTB ?DISP BIMM .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[ + + : 1GP \ op --- | r/m reg opcodes + CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP + R> .name ; + + external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal + +: MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89 +: MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B + + +\ *** Block No. 25, Hexblock 19 + +\ + internal +: MOVS>M \ op --- | display instructions 8C-8E + NEXTB OVER $8D = IF .MREG .REG LEA ELSE + OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE + SWAP 1 [or] SWAP \ 16 bit moves only, folks! + OVER 2 [and] IF .MREG DUP .SEG ELSE + DUP .SEG .MREG THEN MOV THEN THEN 2DROP ; + + + : 8MOVS \ op --- | display instructions 80-8F + DUP 2/ 7 exec + 80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[ + + + + +\ *** Block No. 26, Hexblock 1a + +\ + external + .SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP + .SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF + internal + + : INTER \ --- | decode interseg jmp or call + NEXTW 4 u.r ." :" NEXTW U. ; + + : CALLINTER \ --- | decode interseg call + INTER CALL ; + + : 9HIS \ op --- | 98-9F decodes + 7 exec + CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[ + + +\ *** Block No. 27, Hexblock 1b + +\ + internal + : XCHGA \ op --- | 98-9F decodes + dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ; + + : 90S \ op --- | 90-9F decodes + DUP 3 shift> 1 exec XCHGA 9HIS STOP[ + + : MOVSs \ op --- | A4-A5 decodes + .SIZE ." MOVS " ; + + : CMPSs \ op --- | A6-A7 decodes + .SIZE ." CMPS " ; + + + + +\ *** Block No. 28, Hexblock 1c + +\ + internal + : .AL/AX \ op --- | decodes for size + 1 EXEC .A- .A STOP[ + + : MOVS/ACC \ op --- | A0-A3 decodes + 2 mask + IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ; + + create ss-tab ," TESTSTOSLODSSCAS" + + : .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ; + + : .TEST \ op --- | A8-A9 decodes + 1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ; + + +\ *** Block No. 29, Hexblock 1d + +\ + internal + : STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS + : LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS + : SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS + + : A0S \ op --- | A0-AF decodes + DUP 2/ 7 exec + MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[ + + : MOVS/IMM \ op --- | B0-BF decodes + 8 mask + IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ; + + : HMEDS \ op --- | op codes 80 - C0 displayed + DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[ + +\ *** Block No. 30, Hexblock 1e + +\ + external + .SELF LES .SELF LDS .SELF INTO .SELF IRET + internal + + : LES/LDS \ op --- | les/lds instruction C4-C5 + NEXTB .MREG .REG DROP 1 exec LES LDS STOP[ + external + : RET \ op --- | return instruction C2-C3, CA-CB + 1 mask 0= IF WDISP ." SP+" THEN + 8 [and] IF ." FAR " THEN .myself ; + + internal + : MOV#R/M \ op --- | return instruction C2-C3, CA-CB + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG MOV 2DROP ; + +\ *** Block No. 31, Hexblock 1f + +\ + external + + : INT \ op --- | int instruction CC-CD + 1 [and] IF NEXTB ELSE 3 THEN U. .myself ; + + internal + : INTO/IRET \ op --- | int & iret instructions CE-CF + 1 exec INTO IRET STOP[ + + : C0S \ op --- | display instructions C0-CF + DUP 2/ 7 exec + OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[ + + + + +\ *** Block No. 32, Hexblock 20 + +\ + external + .SELF ROL .SELF ROR .SELF RCL .SELF RCR + .SELF SHL/SAL .SELF SHR .SELF SAR + internal + + : SHIFTS \ op --- | secondary instructions d0-d3 + 2 mask IF 0 .8reg ( C-) THEN + NEXTB .MREG NIP 3 shift> 7 exec + ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[ + + : XLAT DROP ." XLAT " ; + + : ESC \ op --- | esc instructions d8-DF + NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ; + + +\ *** Block No. 33, Hexblock 21 + +\ + internal + : D0S \ op --- | display instructions D0-DF + 8 mask IF ESC EXIT THEN + DUP 7 exec + SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[ + + external + .SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ + internal + + : LOOPS \ op --- | display instructions E0-E3 + NEXTB SEXT CP@ + u. 3 exec + LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[ + + external .SELF IN .SELF OUT .SELF JMP + +\ *** Block No. 34, Hexblock 22 + +\ + internal + + : IN/OUT \ op --- | display instructions E4-E6,EC-EF + 8 mask + IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN + ELSE 2 mask + IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN + THEN ; + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ + internal + : CALLs \ op --- | display instructions E7-EB + 2 mask IF 1 mask IF NEXTB SEXT CP@ + u. + ELSE INTER THEN + ELSE NEXTW CP@ + u. THEN + 3 exec CALL JMP JMP JMP STOP[ + + : E0S \ op --- | display instructions E0-EF + DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[ + + : FTEST \ op --- | display instructions F6,7:0 + ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG DROP .SIZE 0 .ss-tab ; \ TEST + + + +\ *** Block No. 36, Hexblock 24 + +\ + external + .SELF NOT .SELF NEG .SELF MUL .SELF IMUL + .SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ + .SELF LOCK .SELF HLT .SELF CMC .SELF CLC + .SELF STC .SELF CLI .SELF STI .SELF CLD + .SELF STD .SELF INC .SELF DEC .SELF PUSH + internal + +: MUL/DIV \ op ext --- | secondary instructions F6,7:4-7 + .MREG .A OVER 1 [and] IF .D THEN NIP + 3 shift> 3 exec MUL IMUL DIV IDIV STOP[ + + + + + +\ *** Block No. 37, Hexblock 25 + +\ + internal + : NOT/NEG \ op ext --- | secondary instructions F6,7:2,3 + .MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[ + + : F6-F7S \ op --- | display instructions F6,7 + NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG + MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[ + + : FES \ op --- | display instructions FE + NEXTB .MREG ." BYTE " NIP 3 shift> + 3 exec INC DEC oops oops STOP[ + + : FCALL/JMP \ op ext --- | display call instructions FF + .MREG 3 shift> 1 mask IF ." FAR " THEN + NIP 2/ 1 exec JMP CALL STOP[ + +\ *** Block No. 38, Hexblock 26 + +\ + internal + + : FPUSH \ op ext --- | display push instructions FF + dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht! + 4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ; + + : FINC \ op ext --- | display inc/dec instructions FF + .MREG NIP 3 shift> 1 exec INC DEC STOP[ + + : FFS \ op --- | display instructions FF + NEXTB DUP 4 shift> 3 exec + FINC FCALL/JMP FCALL/JMP FPUSH STOP[ + + + + +\ *** Block No. 39, Hexblock 27 + +\ + internal + + : F0S \ op --- | display instructions F0-FF + &15 mask 7 mask 6 < IF NIP THEN -1 exec + LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S + CLC STC CLI STI CLD STD FES FFS STOP[ + + : HIGHS \ op -- | op codes C0 - FF displayed + DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[ + + : (INST) \ op --- | highest level vector table + &255 [and] DUP 6 shift> + -1 exec LOWS MEDS HMEDS HIGHS STOP[ + + + +\ *** Block No. 40, Hexblock 28 + +\ + internal + + : INST \ --- | display opcode at ip, advancing as needed + [ disam ] .seg:off + NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ; + + : (DUMP) \ addr ct --- | dump as pointed to by reloc + [ forth ] BOUNDS ?do I TC@ u. LOOP ; + + + + + + + + +\ *** Block No. 41, Hexblock 29 + +\ + internal + + : steps? + 1+ dup &10 mod 0= IF key #esc = exit THEN 0 ; + + create next-code assembler next forth + + : ?next ( steps-count -- steps-count ) + cp@ 2@ next-code 2@ D= + IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U. + cp@ 6 + cp ! \ 4 bytes code, 2 byte link + drop 9 \ forces stop at steps? + THEN ; + + + +\ *** Block No. 42, Hexblock 2a + +\ ks 28 feb 89 + forth definitions + + external + + : DISASM \ addr --- | disassemble until esc key + [ disam ] CP ! base [ forth ] push hex 0 + BEGIN CP@ >R + CR INST R> CP@ OVER - &35 tab (DUMP) + ?next ?stack steps? + UNTIL drop ; + + : dis ( -- ) ' @ disasm ; + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/disks.cfg b/8086/msdos/src/disks.cfg similarity index 100% rename from 8086/msdos/disks.cfg rename to 8086/msdos/src/disks.cfg diff --git a/8086/msdos/dos.fb b/8086/msdos/src/dos.fb similarity index 100% rename from 8086/msdos/dos.fb rename to 8086/msdos/src/dos.fb diff --git a/8086/msdos/src/dos.fth b/8086/msdos/src/dos.fth new file mode 100644 index 0000000..20bfd2b --- /dev/null +++ b/8086/msdos/src/dos.fth @@ -0,0 +1,342 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +DOS loads higher level file functions which go beyond +including a screen file. Calls to MS-DOS are implemented +and used for directory manipulation. These functions may +not work for versions before MS-DOS 3.0. + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS file handli cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : fswap isfile@ fromfile @ isfile ! fromfile ! ; + + $80 Constant dta + +| : COMSPEC ( -- string ) [ dos ] + $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove + filename counted &60 min filename place filename ; + + 1 &12 +thru .( MS-DOS functions loaed ) cr + + Onlyforth + + + +\ *** Block No. 2, Hexblock 2 + +\ moving blocks ks 04 okt 87 + +| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; + + : used? ( blk -- f ) + block count b/blk 1- swap skip nip 0<> ; + +| : (copy ( from to -- ) + full? IF save-buffers THEN isfile@ fromfile @ - + IF dup used? Abort" target block not empty" THEN + dup isfile@ core? IF prev @ emptybuf THEN + isfile@ 0= IF offset @ + THEN + isfile@ rot fromfile @ (block 6 - 2! update ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ moving blocks ks 04 okt 87 + +| : blkmove ( from to quan -- ) 3 arguments save-buffers + >r over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP + THEN save-buffers 2drop ; + + : copy ( from to -- ) 1 blkmove ; + + : convey ( blk1 blk2 to.blk -- ) + 3 arguments >r 2dup swap - >r + fswap dup capacity 1- > isfile@ 0<> and + fswap r> r@ + capacity 1- > isfile@ 0<> and or >r + 1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ; + + +\ *** Block No. 4, Hexblock 4 + +\ MORE extending forth files ks 10 okt 87 + Dos also definitions + +| : addblock ( blk -- ) dup buffer dup b/blk blank + isfile@ f.size dup 2@ b/blk 0 d+ rot 2! + swap isfile@ fblock! ; + + Forth definitions + + : more ( n -- ) 1 arguments isfile@ + IF capacity swap bounds ?DO I addblock LOOP close exit + THEN drop ; + + + + + +\ *** Block No. 5, Hexblock 5 + +\ file eof? create dta-addressing ks 03 apr 88 + Dos definitions + + : ftime ( -- mm hh ) + isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + : .when base push decimal + fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r + ftime 3 .r ." :" 2 .r ; + + + + + +\ *** Block No. 6, Hexblock 6 + +\ ks 20mar88 + + : (.fcb ( fcb -- ) + dup .file ?dup 0=exit pushfile + isfile ! &13 tab ." is" + isfile@ f.handle @ 2 .r + isfile@ f.size 2@ 7 d.r .when + space isfile@ f.name count type ; + + Forth definitions + + : files file-link + BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; + + : ?file isfile@ (.fcb ; + + +\ *** Block No. 7, Hexblock 7 + +\ dir make makefile ks 25 okt 87 + Forth definitions + + : killfile close + isfile@ f.name filename >asciz ~unlink drop ; + + : emptyfile isfile@ 0=exit + isfile@ f.name filename >asciz 0 ~creat ?diskerror + isfile@ f.handle ! isfile@ f.size 4 erase ; + + : make close name isfile@ fname! emptyfile ; + + : makefile File last @ name> execute emptyfile ; + + + + +\ *** Block No. 8, Hexblock 8 + +\ getpath ks 10 okt 87 + Dos definitions + +| &40 Constant pathlen +| Create pathes 0 c, pathlen allot + +| : (setpath ( string -- ) count + dup pathlen u> Abort" path too long" pathes place ; + +| : getpath ( +n -- string / ff ) + >r 0 pathes count r> 0 + DO rot drop Ascii ; skip stash Ascii ; scan LOOP + drop over - ?dup + IF here place here dup count + 1- c@ + ?" :\" ?exit Ascii \ here append exit + THEN 0= ; + +\ *** Block No. 9, Hexblock 9 + +\ pathsearch .path path ks 09 okt 87 + + : pathsearch ( string -- asciz *f ) dup >r + (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 + BEGIN drop 1+ dup getpath ?dup 0= + IF drop r> filename >asciz 2 exit THEN + r@ count 2 pick attach (fsearch + 0= UNTIL nip rdrop false ; + + ' pathsearch Is fsearch + + Forth definitions + + : .path pathes count type ; + + : path name nullstring? IF .path exit THEN (setpath ; + +\ *** Block No. 10, Hexblock a + +\ call another executable file ks 04 aug 87 + Dos definitions + +| Create cpb 0 , \ inherit parent environment + dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , + +| Code ~exec ( asciz -- *f ) + I push R push U push S ssave #) mov cpb # R mov + $4B00 # A mov $21 int C: D mov D D: mov D S: mov + D E: mov ssave #) S mov CS not + ?[ A A xor A push $2F # A+ mov $21 int E: A mov + A D: mov C: A mov A E: mov R I mov dta # W mov + $40 # C mov rep movs A D: mov A pop + ]? A W xchg dta # D mov $1A # A+ mov $21 int + W D mov U pop R pop I pop Next + end-code + +\ *** Block No. 11, Hexblock b + +\ calling MS-DOS thru forth interpreter ks 19 mr 88 + +| : execute? ( extension -- *f ) + count filename count Ascii . scan drop swap + 2dup 1+ erase move filename 1+ ~exec ; + + : fcall ( string -- ) count filename place ds@ cpb 4+ ! + " .EXE" execute? dup IF drop " .COM" execute? THEN + ?diskerror ; + + : fdos ( string -- ) + dta $80 erase " /c " count dta place count dta attach + status push status off .status COMSPEC fcall curat? at ; + + + + +\ *** Block No. 12, Hexblock c + +\ einige MS-DOS Funktionen msdos call ks 10 okt 87 + + : dos: Create ," Does> count here place + Ascii " parse here attach here fdos ; + + Forth definitions + + dos: dir dir " + dos: ren ren " + dos: md md " + dos: cd cd " + dos: rd rd " + dos: fcopy copy " + dos: delete del " + dos: ftype type " + + +\ *** Block No. 13, Hexblock d + +\ msdos call ks 23 okt 88 + + : msdos savevideo status push status off .status + flush dta off COMSPEC fcall restorevideo ; + + : call name source >in @ /string c/l umin + dta place dta dta >asciz drop [compile] \ + status push status off .status fcall curat? at ; + + + + + + + + + +\ *** Block No. 14, Hexblock e + +\ time date ks 19 mr 88 + Dos definitions + + : ftime ( -- mm hh ) + open isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + + + + + + + + +\ *** Block No. 15, Hexblock f + +\ ~lseek position? ks 10 okt 87 + Dos definitions + + Code ~lseek ( d handle method -- d' ) + R W mov D A mov R pop C pop D pop + $42 # A+ mov $21 int W R mov CS not + ?[ A push Next ]? A D xchg ;c: ?diskerror ; + + Forth definitions + + : position? ( -- dfaddr ) + isfile@ f.handle @ 0= Abort" file not open" + 0 0 isfile@ f.handle @ 1 ~lseek ; + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/src/dos2.fth b/8086/msdos/src/dos2.fth new file mode 100644 index 0000000..4618be8 --- /dev/null +++ b/8086/msdos/src/dos2.fth @@ -0,0 +1,255 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +\ This file is a pure .fth-version of dos.fb. + +\ DOS loads higher level file functions which go beyond +\ including a screen file. Calls to MS-DOS are implemented +\ and used for directory manipulation. These functions may +\ not work for versions before MS-DOS 3.0. + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS file handli cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : fswap isfile@ fromfile @ isfile ! fromfile ! ; + + $80 Constant dta + +| : COMSPEC ( -- string ) [ dos ] + $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove + filename counted &60 min filename place filename ; + +\ 1 &12 +thru .( MS-DOS functions loaed ) cr + + + + +\ *** Block No. 2, Hexblock 2 + +\ moving blocks ks 04 okt 87 + +| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; + + : used? ( blk -- f ) + block count b/blk 1- swap skip nip 0<> ; + +| : (copy ( from to -- ) + full? IF save-buffers THEN isfile@ fromfile @ - + IF dup used? Abort" target block not empty" THEN + dup isfile@ core? IF prev @ emptybuf THEN + isfile@ 0= IF offset @ + THEN + isfile@ rot fromfile @ (block 6 - 2! update ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ moving blocks ks 04 okt 87 + +| : blkmove ( from to quan -- ) 3 arguments save-buffers + >r over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP + THEN save-buffers 2drop ; + + : copy ( from to -- ) 1 blkmove ; + + : convey ( blk1 blk2 to.blk -- ) + 3 arguments >r 2dup swap - >r + fswap dup capacity 1- > isfile@ 0<> and + fswap r> r@ + capacity 1- > isfile@ 0<> and or >r + 1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ; + + +\ *** Block No. 4, Hexblock 4 + +\ MORE extending forth files ks 10 okt 87 + Dos also definitions + +| : addblock ( blk -- ) dup buffer dup b/blk blank + isfile@ f.size dup 2@ b/blk 0 d+ rot 2! + swap isfile@ fblock! ; + + Forth definitions + + : more ( n -- ) 1 arguments isfile@ + IF capacity swap bounds ?DO I addblock LOOP close exit + THEN drop ; + + + + + +\ *** Block No. 5, Hexblock 5 + +\ file eof? create dta-addressing ks 03 apr 88 + Dos definitions + + : ftime ( -- mm hh ) + isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + : .when base push decimal + fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r + ftime 3 .r ." :" 2 .r ; + + + + + +\ *** Block No. 6, Hexblock 6 + +\ ks 20mar88 + + : (.fcb ( fcb -- ) + dup .file ?dup 0=exit pushfile + isfile ! &13 tab ." is" + isfile@ f.handle @ 2 .r + isfile@ f.size 2@ 7 d.r .when + space isfile@ f.name count type ; + + Forth definitions + + : files file-link + BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; + + : ?file isfile@ (.fcb ; + + +\ *** Block No. 7, Hexblock 7 + +\ dir make makefile ks 25 okt 87 + Forth definitions + + : killfile close + isfile@ f.name filename >asciz ~unlink drop ; + + : emptyfile isfile@ 0=exit + isfile@ f.name filename >asciz 0 ~creat ?diskerror + isfile@ f.handle ! isfile@ f.size 4 erase ; + + : make close name isfile@ fname! emptyfile ; + + : makefile File last @ name> execute emptyfile ; + + + + +\ *** Block No. 8, Hexblock 8 + +\ getpath ks 10 okt 87 + Dos definitions + +| &40 Constant pathlen +| Create pathes 0 c, pathlen allot + +| : (setpath ( string -- ) count + dup pathlen u> Abort" path too long" pathes place ; + +| : getpath ( +n -- string / ff ) + >r 0 pathes count r> 0 + DO rot drop Ascii ; skip stash Ascii ; scan LOOP + drop over - ?dup + IF here place here dup count + 1- c@ + ?" :\" ?exit Ascii \ here append exit + THEN 0= ; + +\ *** Block No. 9, Hexblock 9 + +\ pathsearch .path path ks 09 okt 87 + + : pathsearch ( string -- asciz *f ) dup >r + (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 + BEGIN drop 1+ dup getpath ?dup 0= + IF drop r> filename >asciz 2 exit THEN + r@ count 2 pick attach (fsearch + 0= UNTIL nip rdrop false ; + + ' pathsearch Is fsearch + + Forth definitions + + : .path pathes count type ; + + : path name nullstring? IF .path exit THEN (setpath ; + +\ *** Block No. 10, Hexblock a + +\ call another executable file ks 04 aug 87 + Dos definitions + +| Create cpb 0 , \ inherit parent environment + dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , + +| Code ~exec ( asciz -- *f ) + I push R push U push S ssave #) mov cpb # R mov + $4B00 # A mov $21 int C: D mov D D: mov D S: mov + D E: mov ssave #) S mov CS not + ?[ A A xor A push $2F # A+ mov $21 int E: A mov + A D: mov C: A mov A E: mov R I mov dta # W mov + $40 # C mov rep movs A D: mov A pop + ]? A W xchg dta # D mov $1A # A+ mov $21 int + W D mov U pop R pop I pop Next + end-code + +\ *** Block No. 11, Hexblock b + +\ calling MS-DOS thru forth interpreter ks 19 mr 88 + +| : execute? ( extension -- *f ) + count filename count Ascii . scan drop swap + 2dup 1+ erase move filename 1+ ~exec ; + + : fcall ( string -- ) count filename place ds@ cpb 4+ ! + " .EXE" execute? dup IF drop " .COM" execute? THEN + ?diskerror ; + + : fdos ( string -- ) + dta $80 erase " /c " count dta place count dta attach + status push status off .status COMSPEC fcall curat? at ; + + + + +\ *** Block No. 12, Hexblock c + +\ einige MS-DOS Funktionen msdos call ks 10 okt 87 + + : dos: Create ," Does> count here place + Ascii " parse here attach here fdos ; + + Forth definitions + + dos: dir dir " + dos: ren ren " + dos: md md " + dos: cd cd " + dos: rd rd " + dos: fcopy copy " + dos: delete del " + dos: ftype type " + + +\ *** Block No. 13, Hexblock d + +\ msdos call ks 23 okt 88 + + : msdos savevideo status push status off .status + flush dta off COMSPEC fcall restorevideo ; + + : call name source >in @ /string c/l umin + dta place dta dta >asciz drop [compile] \ + status push status off .status fcall curat? at ; + + + .( MS-DOS functions loaed ) cr + + Onlyforth diff --git a/8086/msdos/src/dos3.fth b/8086/msdos/src/dos3.fth new file mode 100644 index 0000000..ad3ae7b --- /dev/null +++ b/8086/msdos/src/dos3.fth @@ -0,0 +1,195 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +\ This file is an .fth-version of dos.fb without the block-related +\ words. + +\ DOS loads higher level file functions which go beyond +\ including a screen file. Calls to MS-DOS are implemented +\ and used for directory manipulation. These functions may +\ not work for versions before MS-DOS 3.0. + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS file handli cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : fswap isfile@ fromfile @ isfile ! fromfile ! ; + + $80 Constant dta + +| : COMSPEC ( -- string ) [ dos ] + $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove + filename counted &60 min filename place filename ; + + +\ *** Block No. 5, Hexblock 5 + +\ file eof? create dta-addressing ks 03 apr 88 + Dos also definitions + + : ftime ( -- mm hh ) + isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + : .when base push decimal + fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r + ftime 3 .r ." :" 2 .r ; + + + + + +\ *** Block No. 6, Hexblock 6 + +\ ks 20mar88 + + : (.fcb ( fcb -- ) + dup .file ?dup 0=exit pushfile + isfile ! &13 tab ." is" + isfile@ f.handle @ 2 .r + isfile@ f.size 2@ 7 d.r .when + space isfile@ f.name count type ; + + Forth definitions + + : files file-link + BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; + + : ?file isfile@ (.fcb ; + + +\ *** Block No. 7, Hexblock 7 + +\ dir make makefile ks 25 okt 87 + Forth definitions + + : killfile close + isfile@ f.name filename >asciz ~unlink drop ; + + : emptyfile isfile@ 0=exit + isfile@ f.name filename >asciz 0 ~creat ?diskerror + isfile@ f.handle ! isfile@ f.size 4 erase ; + + : make close name isfile@ fname! emptyfile ; + + : makefile File last @ name> execute emptyfile ; + + + + +\ *** Block No. 8, Hexblock 8 + +\ getpath ks 10 okt 87 + Dos definitions + +| &40 Constant pathlen +| Create pathes 0 c, pathlen allot + +| : (setpath ( string -- ) count + dup pathlen u> Abort" path too long" pathes place ; + +| : getpath ( +n -- string / ff ) + >r 0 pathes count r> 0 + DO rot drop Ascii ; skip stash Ascii ; scan LOOP + drop over - ?dup + IF here place here dup count + 1- c@ + ?" :\" ?exit Ascii \ here append exit + THEN 0= ; + +\ *** Block No. 9, Hexblock 9 + +\ pathsearch .path path ks 09 okt 87 + + : pathsearch ( string -- asciz *f ) dup >r + (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 + BEGIN drop 1+ dup getpath ?dup 0= + IF drop r> filename >asciz 2 exit THEN + r@ count 2 pick attach (fsearch + 0= UNTIL nip rdrop false ; + + ' pathsearch Is fsearch + + Forth definitions + + : .path pathes count type ; + + : path name nullstring? IF .path exit THEN (setpath ; + +\ *** Block No. 10, Hexblock a + +\ call another executable file ks 04 aug 87 + Dos definitions + +| Create cpb 0 , \ inherit parent environment + dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , + +| Code ~exec ( asciz -- *f ) + I push R push U push S ssave #) mov cpb # R mov + $4B00 # A mov $21 int C: D mov D D: mov D S: mov + D E: mov ssave #) S mov CS not + ?[ A A xor A push $2F # A+ mov $21 int E: A mov + A D: mov C: A mov A E: mov R I mov dta # W mov + $40 # C mov rep movs A D: mov A pop + ]? A W xchg dta # D mov $1A # A+ mov $21 int + W D mov U pop R pop I pop Next + end-code + +\ *** Block No. 11, Hexblock b + +\ calling MS-DOS thru forth interpreter ks 19 mr 88 + +| : execute? ( extension -- *f ) + count filename count Ascii . scan drop swap + 2dup 1+ erase move filename 1+ ~exec ; + + : fcall ( string -- ) count filename place ds@ cpb 4+ ! + " .EXE" execute? dup IF drop " .COM" execute? THEN + ?diskerror ; + + : fdos ( string -- ) + dta $80 erase " /c " count dta place count dta attach + status push status off .status COMSPEC fcall curat? at ; + + + + +\ *** Block No. 12, Hexblock c + +\ einige MS-DOS Funktionen msdos call ks 10 okt 87 + + : dos: Create ," Does> count here place + Ascii " parse here attach here fdos ; + + Forth definitions + + dos: dir dir " + dos: ren ren " + dos: md md " + dos: cd cd " + dos: rd rd " + dos: fcopy copy " + dos: delete del " + dos: ftype type " + + +\ *** Block No. 13, Hexblock d + +\ msdos call ks 23 okt 88 + + : msdos savevideo status push status off .status + flush dta off COMSPEC fcall restorevideo ; + + : call name source >in @ /string c/l umin + dta place dta dta >asciz drop [compile] \ + status push status off .status fcall curat? at ; + + + .( MS-DOS functions loaed ) cr + + Onlyforth diff --git a/8086/msdos/double.fb b/8086/msdos/src/double.fb similarity index 100% rename from 8086/msdos/double.fb rename to 8086/msdos/src/double.fb diff --git a/8086/msdos/src/double.fth b/8086/msdos/src/double.fth new file mode 100644 index 0000000..55765cd --- /dev/null +++ b/8086/msdos/src/double.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Double words cas 10nov05 + +This File contains definitions for 32Bit Math + +This definitions are already included in the volksFORTH Kernel: + + 2! 2@ 2drop 2dup 2over 2swap d+ d. d.r + d0= d< d= dabs dnegate + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ 2constant 2rot 2variable d- d2/ ks 22 dez 87 + + : 2constant Create , , does> 2@ ; + + : 2rot ( d1 d2 d3 -- d2 d3 d1 ) 5 roll 5 roll ; + + : 2variable Variable 2 allot ; + + : d- ( d1 d2 -- d3 ) dnegate d+ ; + + Code d2/ ( d1 -- d2 ) + A pop D sar A rcr A push Next end-code + + + + + +\ *** Block No. 2, Hexblock 2 + +\ dmax dmin du< ks 22 dez 87 + + : dmax ( d1 d2 -- d3 ) + 2over 2over d< IF 2swap THEN 2drop ; + + : dmin ( d1 d2 -- d3 ) + 2over 2over d< IF 2drop exit THEN 2swap 2drop ; + + : du< ( 32b1 32b2 -- f ) + rot 2dup = IF 2drop u< exit THEN u> -rot 2drop ; + + + + + + + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/editor.fb b/8086/msdos/src/editor.fb similarity index 100% rename from 8086/msdos/editor.fb rename to 8086/msdos/src/editor.fb diff --git a/8086/msdos/src/editor.fth b/8086/msdos/src/editor.fth new file mode 100644 index 0000000..b04dc97 --- /dev/null +++ b/8086/msdos/src/editor.fth @@ -0,0 +1,798 @@ + +\ *** Block No. 0, Hexblock 0 + + volksFORTH Full-Screen-Editor HELP Screen cas 11nov05 + +Quit Editor : flushed: ESC updated: ^E +discard changes : ^U (UNDO) +move cursor : Cursorkeys (delete with DEL or <- ) +insert : INS (toggle), ^ENTER (insert Screen) +Tabs : TAB (to right), SHIFT TAB (to left) +paging : Pg Dn (next screen), Pg Up (previous scr) + : F9 (alternate), SHIFT F9 (shadow scr) +mark alternate Scr. : F10 +delete/insert line : ^Y (delete), ^N (insert) +split line : ^PgDn (split), ^PgUp (join) +search and replace : F2 (stop with ESC, replace with 'R' ) +linebuffer : F3 (push&delete), F5 (push), F7 (pop) +charbuffer : F4 (push&delete), F6 (push), F8 (pop) +misc : ^F (Fix), ^L (Showload), ^S (Screen #) + +\ *** Block No. 1, Hexblock 1 + +--> \ Full-Screen Editor cas 10nov05 +This is the Full-Screen Editor for MS-DOS volksFORTH + +Features: Line- and Char-Buffer, Find- and Replace, Support for +"Shadow-Screens", View Function and loading of screens with +visual feedback (showload) + +The Keybinding can be easily changed by using the integrated +Keytable. + + +Ported to the MS-DOS volksFORTH by K.Schleisiek on 22 dez 87 +Original design by Ullrich Hoffmann + + + + +\ *** Block No. 2, Hexblock 2 + +\ Load Screen for the Editor cas 10nov05 + + Onlyforth \needs Assembler 2 loadfrom asm.scr + + 3 load \ PC adaption + 4 9 thru \ Editor + +\ &10 load \ ANSI display interface +\ &11 load \ BIOS display interface + &12 load \ MULTItasking display interface + +&13 &39 thru \ Editor + +Onlyforth .( Screen Editor loaded ) cr + + + +\ *** Block No. 3, Hexblock 3 + +\ BIM adaption UH 11dez88 + +| : ?range ( n -- n ) isfile@ 0=exit dup 0< 9 and ?diskerror + dup capacity - 1+ 0 max ?dup 0=exit more ; +| : block ( n -- adr ) ?range block ; + + $1B Constant #esc + + : curon &11 &12 curshape ; + + : curoff &14 dup curshape ; + + Variable caps caps off + + Label ?capital 1 # caps #) byte test + 0= ?[ (capital # jmp ]? ret end-code + +\ *** Block No. 4, Hexblock 4 + +\ search delete insert replace ks 20 dez 87 + +| : delete ( buffer size count -- ) + over min >r r@ - ( left over ) dup 0> + IF 2dup swap dup r@ + -rot swap cmove THEN + + r> bl fill ; + +| : insert ( string length buffer size -- ) + rot over min >r r@ - ( left over ) + over dup r@ + rot cmove> r> cmove ; + +| : replace ( string length buffer size -- ) + rot min cmove ; + + + + +\ *** Block No. 5, Hexblock 5 + +\ usefull definitions and Editor vocabulary UH 11mai88 + +Vocabulary Editor + +' Forth | Alias [F] immediate +' Editor | Alias [E] immediate + +Editor also definitions + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + +| Variable r#' r#' off +| Variable scr' scr' off +' fromfile | Alias isfile' +| Variable lastfile | Variable lastscr | Variable lastr# + +\ *** Block No. 6, Hexblock 6 + +\\ move cursor with position-checking ks 18 dez 87 +\ different versions of cursor positioning error reporting + +| : c ( n --) \ checks the cursor position + r# @ + dup 0 b/blk uwithin not + Abort" There is a border!" r# ! ; + +| : c ( n --) \ goes thru the screens + r# @ + dup b/blk 1- > IF 1 scr +! THEN + dup 0< IF -1 scr +! THEN b/blk mod r# ! ; + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + + + + +\ *** Block No. 7, Hexblock 7 + +\ calculate addresses ks 20 dez 87 +| : *line ( l -- adr ) c/l * ; +| : /line ( n -- c l ) c/l /mod ; +| : top ( -- ) r# off ; +| : cursor ( -- n ) r# @ ; +| : 'start ( -- adr ) scr @ block ; +| : 'end ( -- adr ) 'start b/blk + ; +| : 'cursor ( -- adr ) 'start cursor + ; +| : position ( -- c l ) cursor /line ; +| : line# ( -- l ) position nip ; +| : col# ( -- c ) position drop ; +| : 'line ( -- adr ) 'start line# *line + ; +| : 'line-end ( -- adr ) 'line c/l + 1- ; +| : #after ( -- n ) c/l col# - ; +| : #remaining ( -- n ) b/blk cursor - ; +| : #end ( -- n ) b/blk line# *line - ; + +\ *** Block No. 8, Hexblock 8 + +\ move cursor directed UH 11dez88 +| Create >at 0 , 0 , +| : curup c/l negate c ; +| : curdown c/l c ; +| : curleft -1 c ; +| : curright 1 c ; + +| : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; +| : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; + +| : >last ( adr len -- ) -trailing nip b/blk min r# ! ; +| : #after c ; +| : ( -- ) 'start line# 1+ *line 1- >last ; +| : >""end ( -- ) 'start b/blk >last ; + +\ *** Block No. 9, Hexblock 9 + +\ show border UH 29Sep87 + +&14 | Constant dx 1 | Constant dy + +| : horizontal ( row eck1 eck2 -- row' ) + rot dup >r dx 1- at swap emit + c/l 0 DO Ascii - emit LOOP emit r> 1+ ; + +| : vertical ( row -- row' ) + l/s 0 DO dup dx 1- at Ascii | emit + row dx c/l + at Ascii | emit 1+ LOOP ; + +| : border dy 1- Ascii / Ascii \ horizontal + vertical Ascii \ Ascii / horizontal drop ; + +| : edit-at ( -- ) position swap dy dx d+ at ; + +\ *** Block No. 10, Hexblock a + +\ ANSI display interface ks 03 feb 88 + + + + + + + +| : redisplay ( line# -- ) + dup dy + dx at *line 'start + c/l type ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 11, Hexblock b + +\ BIOS-display interface ks 03 feb 88 +| Code (.line ( line addr videoseg -- ) + A pop W pop I push E: push D E: mov + $0E # W add W W add A I xchg c/l # C mov + attribut #) A+ mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 12, Hexblock c + +\ MULTI-display interface ks UH 10Sep87 +| Code (.line ( line addr videoseg -- ) + C pop W pop I push E: push D E: mov + $0E # W add W W add u' area U D) I mov + u' catt I D) A+ mov C I mov + c/l # C mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) line# 2+ c/col 2- window ; + +| : cleartop ( -- ) 0 l/s 5 + window (page ; +| : install-screen ( -- ) row l/s 6 + u< + IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; + +\ *** Block No. 13, Hexblock d + +\ display screen UH 11mai88 +Forth definitions +: updated? ( -- f) 'start 2- @ 0< ; +Editor definitions +| : .updated ( -- ) 9 0 at + updated? IF 4 spaces ELSE ." not " THEN ." updated" ; + +| : .screen l/s 0 DO I redisplay LOOP ; +\ | : .file ( fcb -- ) +\ ?dup IF body> >name .name exit THEN ." direct" ; +| : .title [ DOS ] 1 0 at isfile@ .file dx 1- tab + 2 0 at drv (.drv scr @ 6 .r + 4 0 at fromfile @ .file dx 1- tab + 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; + +| : .all .title .screen ; + +\ *** Block No. 14, Hexblock e + +\ check errors UH 02Nov86 + +| : ?bottom ( -- ) 'end c/l - c/l -trailing nip + Abort" You would lose a line" ; + +| : ?fit ( n -- ) 'line c/l -trailing nip + c/l > + IF line# redisplay + true Abort" You would lose a char" THEN ; + +| : ?end 1 ?fit ; + + + + + + + +\ *** Block No. 15, Hexblock f + +\ programmer's id ks 18 dez 87 + +$12 | Constant id-len +Create id id-len allot id id-len erase + +| : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; + +| : ?stamp ( -- ) updated? IF stamp THEN ; + +| : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; + +| : get-id ( -- ) id c@ ?exit ID on + cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at + id 2+ 3 expect normal span @ dup id 1+ c! 0=exit + bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; + + +\ *** Block No. 16, Hexblock 10 + +\ update screen-display UH 28Aug87 + +| : emptybuf prev @ 2+ dup on 4+ off ; + +| : undo emptybuf .all ; + +| : modified updated? ?exit update .updated ; + +| : linemodified modified line# redisplay ; + +| : screenmodified modified + l/s line# ?DO I redisplay LOOP ; + +| : .modified ( -- ) >at 2@ at space scr @ . + updated? not IF ." un" THEN ." modified" ?stamp ; + + +\ *** Block No. 17, Hexblock 11 + +\ leave editor UH 10Sep87 +| Variable (pad (pad off +| : memtop ( -- adr) sp@ $100 - ; + +| Create char 1 allot +| Variable imode imode off +| : .imode at? 7 0 at + imode @ IF ." insert " ELSE ." overwrite" THEN at ; +| : setimode imode on .imode ; +| : clrimode imode off .imode ; + +| : done ( -- ) (done + ['] (quit is 'quit ['] (error errorhandler ! quit ; + +| : update-exit ( -- ) .modified done ; +| : flushed-exit ( -- ) .modified save-buffers done ; + +\ *** Block No. 18, Hexblock 12 + +\ handle screens UH 21jan89 + +| : insert-screen ( scr -- ) \ before scr + 1 more fromfile push isfile@ fromfile ! + capacity 2- over 1+ convey ; + +| : wipe-screen ( -- ) 'start b/blk blank ; + +| : new-screen ( -- ) + scr @ insert-screen wipe-screen top screenmodified ; + + + + + + + +\ *** Block No. 19, Hexblock 13 + +\ handle lines UH 01Nov86 + +| : (clear-line 'line c/l blank ; +| : clear-line (clear-line linemodified ; + +| : clear> 'cursor #after blank linemodified ; + +| : delete-line 'line #end c/l delete screenmodified ; + +| : backline curup delete-line ; + +| : (insert-line + ?bottom 'line c/l over #end insert (clear-line ; + +| : insert-line (insert-line screenmodified ; + + +\ *** Block No. 20, Hexblock 14 + +\ join and split lines UH 11dez88 + +| : insert-spaces ( n -- ) 'cursor swap + 2dup over #remaining insert blank ; + +| : split ( -- ) ?bottom cursor col# insert-spaces r# ! + #after insert-spaces screenmodified ; + +| : delete-characters ( n -- ) 'cursor #remaining rot delete ; + +| : join ( -- ) cursor line> col# Abort" next line will not fit!" + #after + dup delete-characters + cursor c/l rot - dup 0< + IF negate insert-spaces ELSE delete-characters THEN r# ! + screenmodified ; + +\ *** Block No. 21, Hexblock 15 + +\ handle characters UH 01Nov86 + +| : delete-char 'cursor #after 1 delete linemodified ; + +| : backspace curleft delete-char ; + +| : (insert-char ?end 'cursor 1 over #after insert ; + + +| : insert-char (insert-char bl 'cursor c! linemodified ; + +| : putchar ( --) char c@ + imode @ IF (insert-char THEN + 'cursor c! linemodified curright ; + + + +\ *** Block No. 22, Hexblock 16 + +\ stack lines UH 31Oct86 + +| Create lines 4 allot \ { 2+pointer | 2base } +| : 'lines ( -- adr) lines 2@ + ; + +| : @line 'lines memtop u> Abort" line buffer full" + 'line 'lines c/l cmove c/l lines +! ; + +| : copyline @line curdown ; +| : line>buf @line delete-line ; + +| : !line c/l negate lines +! 'lines 'line c/l cmove ; + +| : buf>line lines @ 0= Abort" line buffer empty" + ?bottom (insert-line !line screenmodified ; + + +\ *** Block No. 23, Hexblock 17 + +\ stack characters UH 01Nov86 + +| Create chars 4 allot \ { 2+pointer | 2base } +| : 'chars ( -- adr) chars 2@ + ; + +| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" + 'cursor c@ 'chars c! 1 chars +! ; + +| : copychar @char curright ; +| : char>buf @char delete-char ; + +| : !char -1 chars +! 'chars c@ 'cursor c! ; + +| : buf>char chars @ 0= Abort" char buffer empty" + ?end (insert-char !char linemodified ; + + +\ *** Block No. 24, Hexblock 18 + +\ switch screens UH 11mai88 + +| : imprint ( -- ) \ remember valid file + isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; + +| : remember ( -- ) + lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; + +| : associate \ switch to alternate screen + isfile' @ isfile@ isfile' ! isfile ! + scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; + +| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; +| : n ?stamp 1 scr +! .all ; +| : b ?stamp -1 scr +! .all ; +| : a ?stamp associate .all ; + +\ *** Block No. 25, Hexblock 19 + +\ shadow screens UH 03Nov86 + +Variable shadow shadow off + +| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; + +| : >shadow ?stamp \ switch to shadow screen + (shadow dup scr @ u> not IF negate THEN scr +! .all ; + + + + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ load and show screens ks 02 mar 88 + +| : showoff ['] exit 'name ! normal ; + +| : show ( -- ) blk @ 0= IF showoff exit THEN + >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit + blk @ scr ! normal curoff .all invers curon ; + +| : showload ( -- ) ?stamp save-buffers + ['] show 'name ! curon invers + adr .status push ['] noop is .status + scr @ scr push scr off r# push r# @ (load showoff ; + + + + + +\ *** Block No. 27, Hexblock 1b + +\ find strings ks 20 dez 87 +| Variable insert-buffer +| Variable find-buffer + +| : 'insert ( -- addr ) insert-buffer @ ; +| : 'find ( -- addr ) find-buffer @ ; + +| : .buf ( addr -- ) count type ." |" &80 col - spaces ; + +| : get ( addr -- ) >r at? r@ .buf + 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN + at r> .buf ; + +| : get-buffers dy l/s + 2+ dx 1- 2dup at + ." find: |" 'find get swap 1+ swap 2- at + ." ? replace: |" 'insert get ; + +\ *** Block No. 28, Hexblock 1c + +\ ks 20 dez 87 + Code match ( addr1 len1 string -- addr2 len2 ) + D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? + W inc D dec C pop I A mov I pop A push + W ) A- mov W inc ?capital # call A- A+ mov D C sub + >= ?[ I inc Label done I dec + A pop I push A I mov C D add Next ]? + [[ byte lods ?capital # call A+ A- cmp 0= + ?[ D D or done 0= not ?] + I push W push C push A push D C mov + [[ byte lods ?capital # call A+ A- xchg + W ) A- mov W inc ?capital # call A+ A- cmp + 0= ?[[ C0= ?] A pop C pop + W pop I pop done ]] + ]? A pop C pop W pop I pop + ]? C0= ?] I inc done ]] end-code + +\ *** Block No. 29, Hexblock 1d + +\ search for string UH 11mai88 + +| : skip ( addr -- addr' ) 'find c@ + ; + +| : search ( buf len string -- offset flag ) + >r stash r@ match r> c@ < + IF drop 0= false exit THEN swap - true ; + +| : find? ( -- r# f ) 'cursor #remaining 'find search ; + +| : searchthru ( -- r# scr ) + find? IF skip cursor + scr @ exit THEN drop + capacity scr @ 1+ + ?DO I 2 3 at 6 .r I block b/blk 'find search + IF skip I endloop exit THEN stop? Abort" Break!" + LOOP true Abort" not found!" ; + +\ *** Block No. 30, Hexblock 1e + +\ replace strings UH 14mai88 +| : replace? ( -- f ) dy l/s + 3+ dx 3 - at + key dup #cr = IF line# redisplay true Abort" Break!" THEN + capital Ascii R = ; + +| : "mark ( -- ) r# push + 'find count dup negate c edit-at invers type normal ; + +| : (replace 'insert c@ 'find c@ - ?fit + r# push 'find c@ negate c + 'cursor #after 'find c@ delete + 'insert count 'cursor #after insert modified ; + +| : "replace get-buffers BEGIN searchthru + scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint + "mark replace? IF (replace THEN line# redisplay REPEAT ; + +\ *** Block No. 31, Hexblock 1f + +\ Display Help-Screen, misc commands cas 11nov05 + +| : helpfile ( -- ) fromfile push editor.fb ; +| : .help ( --) + isfile push scr push helpfile scr off .screen ; +| : help ( -- ) .help key drop .screen ; + +| : screen# ( -- scr ) scr @ ; + +| Defer (fix-word + +| : fix-word ( -- ) isfile@ loadfile ! + scr @ blk ! cursor >in ! (fix-word ; + + + + +\ *** Block No. 32, Hexblock 20 + +\ Control-Characters IBM-PC Functionkeys UH 10Sep87 + +Forth definitions + +: Ctrl ( -- c ) + name 1+ c@ $1F and state @ IF [compile] Literal THEN ; +immediate + +\needs #del $7F Constant #del + +Editor definitions + +| : flipimode imode @ 0= imode ! .imode ; + +| : F ( # -- 16b ) $FFC6 swap - ; +| : shift ( n -- n' ) dup 0< + &24 - ; + +\ *** Block No. 33, Hexblock 21 + +\ Control-Characters IBM-PC Functionkeys UH 11dez88 + +Create keytable +-&72 , -&75 , -&80 , -&77 , + 3 F , 4 F , 7 F , 8 F , +Ctrl F , Ctrl S , 5 F , 6 F , + 1 F , Ctrl H , #del , -&83 , + Ctrl Y , Ctrl N , +-&82 , + #cr , #tab , #tab shift , + -&119 , -&117 , 2 F , Ctrl U , +Ctrl E , #esc , Ctrl L , 9 F shift , +-&81 , -&73 , 9 F , &10 F , +-&71 , -&79 , -&118 , -&132 , +#lf , +here keytable - 2/ Constant #keys + +\ *** Block No. 34, Hexblock 22 + +\ Try a screen Editor UH 11dez88 + +Create: actiontable +curup curleft curdown curright +line>buf char>buf buf>line buf>char +fix-word screen# copyline copychar +help backspace backspace delete-char +( insert-char ) delete-line insert-line +flipimode ( clear-line clear> ) + +tab -tab +top >""end "replace undo +update-exit flushed-exit showload >shadow +n b a mark + split join +new-screen ; +here actiontable - 2/ 1- #keys - abort( # of actions) + +\ *** Block No. 35, Hexblock 23 + +\ find keys ks 20 dez 87 + +| : findkey ( key -- adr/default ) + #keys 0 DO dup keytable [F] I 2* + @ = + IF drop [E] actiontable [F] I 2* + @ endloop exit THEN + LOOP drop ['] putchar ; + + + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ allocate buffers UH 01Nov86 + +c/l 2* | Constant cstack-size + +| : nextbuf ( adr -- adr' ) cstack-size + ; + +| : ?clearbuffer pad (pad @ = ?exit + pad dup (pad ! + nextbuf dup find-buffer ! 'find off + nextbuf dup insert-buffer ! 'insert off + nextbuf dup 0 chars 2! + nextbuf 0 lines 2! ; + + + + + +\ *** Block No. 37, Hexblock 25 + +\ enter and exit the editor, editor's loop UH 11mai88 + +| Variable jingle jingle on | : bell 07 charout jingle off ; + +| : clear-error ( -- ) + jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; + +| : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! + findkey imprint execute ( .status ) clear-error REPEAT ; + +| : fullerror ( string -- ) jingle @ IF bell THEN count + dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal + &80 col - spaces remember .all quit ; + +| : install ( -- ) + ['] fullquit Is 'quit ['] fullerror errorhandler ! ; + +\ *** Block No. 38, Hexblock 26 + +\ enter and exit the Editor UH 11mai88 + +Forth definitions + +: v ( -- ) + [E] 'start drop get-id install-screen + install ?clearbuffer + border .all .imode .status quit ; + + ' v Alias ed + +: l ( scr -- ) 1 arguments scr ! [E] top [F] v ; + + ' l Alias edit + + + +\ *** Block No. 39, Hexblock 27 + +\ savesystem enhanced view UH 24jun88 + +: savesystem [E] id off (pad off savesystem ; + +Editor definitions +| : >find ?clearbuffer >in push + name dup c@ 2+ >r bl over c! r> 'find place ; + +Forth definitions +: fix [ Dos ] >find ' @view >file + isfile ! scr ! [E] top curdown + find? IF skip 1- THEN c v ; + +' fix Is (fix-word + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/epson.prn b/8086/msdos/src/epson.prn similarity index 100% rename from 8086/msdos/epson.prn rename to 8086/msdos/src/epson.prn diff --git a/8086/msdos/extend.fb b/8086/msdos/src/extend.fb similarity index 100% rename from 8086/msdos/extend.fb rename to 8086/msdos/src/extend.fb diff --git a/8086/msdos/src/extend.fth b/8086/msdos/src/extend.fth new file mode 100644 index 0000000..998053e --- /dev/null +++ b/8086/msdos/src/extend.fth @@ -0,0 +1,209 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 11 mai 88 +Dieses File enthält Definitionen, die zum Laden der weiteren +System- und Applikationsfiles benötigt werden. + +Unter anderem finden sich hier auch MS-DOS spezifische +Befehle wie zum Beispiel das Allokieren von Speicher- +platz ausserhalb des auf 64k begrenzten Forthsystems +und einige Routinen, die das Arbeiten mit dem Video- +Display erleichtern sowie einige Operatoren zur String- +manipulation. + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for often used words ks cas 25sep16 + + Onlyforth \needs Assembler 2 loadfrom asm.fb + + ' save-buffers Alias sav + + ' name &12 + Constant 'name + + ' page Alias cls + + 1 8 +thru .( Systemerweiterung geladen) cr + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ Postkernel words ks 22 dez 87 + + : blank ( addr quan -- ) bl fill ; + + Code stash ( u1 u2 -- u1 u1 u2 ) + S W mov W ) push Next end-code +\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ; + + : >expect ( addr len -- ) stash expect span @ over place ; + + : .field ( addr len quan -- ) + over - >r type r> 0 max spaces ; + + : tab ( n -- ) col - 0 max spaces ; + + + +\ *** Block No. 3, Hexblock 3 + +\ postkernel ks 08 mär 89 +\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT + +\needs end-code : end-code toss also ; + + : u? ( addr -- ) @ u. ; + + : adr ' >body state @ 0=exit [compile] Literal ; immediate + + : Abort( ( f -- ) IF [compile] .( true abort" !" THEN + [compile] ( ; + + : arguments ( n -- ) + depth 1- > Error" zu wenige Parameter" ; + + + +\ *** Block No. 4, Hexblock 4 + +\ MS-DOS memory management + + Code lallocate ( pages -- seg ff / rest err# ) + R push D R mov $48 # A+ mov $21 int CS + ?[ A D xchg A pop R push A R xchg + ][ R pop A push 0 # D mov ]? Next end-code + + Code lfree ( seg -- err# ) + E: push D E: mov $49 # A+ mov $21 int CS + ?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ postkernel ks 03 aug 87 + + c/row c/col * 2* Constant c/dis \ characters per display + + Code video@ ( -- seg ) D push R D mov $F # A+ mov + $10 int R D xchg 0 # D- mov 7 # A- cmp + 0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next + end-code + + : savevideo ( -- seg / ff ) + [ c/dis b/seg /mod swap 0<> - ] Literal lallocate + IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ; + + : restorevideo ( seg -- ) ?dup 0=exit + dup 0 video@ 0 c/dis lmove lfree drop ; + + +\ *** Block No. 6, Hexblock 6 + +\ string operators append attach ks 21 jun 87 + +| : .stringoverflow true Abort" String zu lang" ; + + Code append ( char addr -- ) + D W mov D pop W ) A- mov 1 # A- add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A- W ) mov 0 # A+ mov A W add + D- W ) mov D pop Next end-code + + Code attach ( addr len addr1 -- ) D W mov C pop + I D mov I pop W ) A- mov A- A+ mov C- A+ add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc + rep byte movs D I mov D pop Next end-code + + +\ *** Block No. 7, Hexblock 7 + +\\ string operators append attach detract ks 21 jun 87 + + : append ( char addr -- ) + under count + c! dup c@ 1+ swap c! ; + + : attach ( addr len addr.to -- ) + >r under r@ count + swap move r@ c@ + r> c! ; + + : detract ( addr -- char ) + dup c@ 1- dup 0> and over c! + count >r dup count -rot swap r> cmove ; + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ ?" string operator ks 09 feb 88 + +\ : (?" ( 8b -- index ) "lit under count rot +\ scan IF swap - exit THEN 2drop false ; + +| Create months ," janfebmäraprmaijunjulaugsepoktnovdez" + + : >months ( n -- addr len ) 3 * 2- months + 3 ; + +| Code (?" ( 8b -- index ) + A D xchg I ) C- mov 0 # C+ mov C I add + I W mov I inc std 0<>rep byte scas cld + 0= ?[ C inc ]? C D mov Next + end-code + + : ?" compile (?" ," align ; immediate restrict + +\ *** Block No. 9, Hexblock 9 + +\ Conditional compilation ks 12 dez 88 +| Defer cond + + : .THEN ; immediate + + : .ELSE ( -- ) 0 + BEGIN name nullstring? IF drop exit THEN + find IF cond -1 case? ?exit ELSE drop THEN + REPEAT ; immediate + + : .IF ( f -- ) ?exit [compile] .ELSE ; immediate + +| : (cond ( n cfa -- n' ) + ['] .THEN case? IF 1- exit THEN + ['] .ELSE case? IF dup 0= + exit THEN + ['] .IF = 0=exit 1+ ; ' (cond is cond + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/src/extend2.fth b/8086/msdos/src/extend2.fth new file mode 100644 index 0000000..0852488 --- /dev/null +++ b/8086/msdos/src/extend2.fth @@ -0,0 +1,182 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 11 mai 88 + +\ This file is a pure .fth-version of extend.fb. +\ It contains definitions needed for several further system +\ and application files. + +\ Among others there are MSDOS specific commands such as allocating +\ memory outside the Forth core 64k memory segment, some routines +\ that make using the video display easier, and some string +\ manipulation words. + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for often used words ks cas 25sep16 + + Onlyforth \needs Assembler include t86asm.fth + + ' save-buffers Alias sav + + ' name &12 + Constant 'name + + ' page Alias cls + +\ 1 8 +thru + +\ *** Block No. 2, Hexblock 2 + +\ Postkernel words ks 22 dez 87 + + : blank ( addr quan -- ) bl fill ; + + Code stash ( u1 u2 -- u1 u1 u2 ) + S W mov W ) push Next end-code +\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ; + + : >expect ( addr len -- ) stash expect span @ over place ; + + : .field ( addr len quan -- ) + over - >r type r> 0 max spaces ; + + : tab ( n -- ) col - 0 max spaces ; + + + +\ *** Block No. 3, Hexblock 3 + +\ postkernel ks 08 mär 89 +\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT + +\needs end-code : end-code toss also ; + + : u? ( addr -- ) @ u. ; + + : adr ' >body state @ 0=exit [compile] Literal ; immediate + + : Abort( ( f -- ) IF [compile] .( true abort" !" THEN + [compile] ( ; + + : arguments ( n -- ) + depth 1- > Error" zu wenige Parameter" ; + + + +\ *** Block No. 4, Hexblock 4 + +\ MS-DOS memory management + + Code lallocate ( pages -- seg ff / rest err# ) + R push D R mov $48 # A+ mov $21 int CS + ?[ A D xchg A pop R push A R xchg + ][ R pop A push 0 # D mov ]? Next end-code + + Code lfree ( seg -- err# ) + E: push D E: mov $49 # A+ mov $21 int CS + ?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ postkernel ks 03 aug 87 + + c/row c/col * 2* Constant c/dis \ characters per display + + Code video@ ( -- seg ) D push R D mov $F # A+ mov + $10 int R D xchg 0 # D- mov 7 # A- cmp + 0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next + end-code + + : savevideo ( -- seg / ff ) + [ c/dis b/seg /mod swap 0<> - ] Literal lallocate + IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ; + + : restorevideo ( seg -- ) ?dup 0=exit + dup 0 video@ 0 c/dis lmove lfree drop ; + + +\ *** Block No. 6, Hexblock 6 + +\ string operators append attach ks 21 jun 87 + +| : .stringoverflow true Abort" String zu lang" ; + + Code append ( char addr -- ) + D W mov D pop W ) A- mov 1 # A- add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A- W ) mov 0 # A+ mov A W add + D- W ) mov D pop Next end-code + + Code attach ( addr len addr1 -- ) D W mov C pop + I D mov I pop W ) A- mov A- A+ mov C- A+ add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc + rep byte movs D I mov D pop Next end-code + + +\ *** Block No. 7, Hexblock 7 + +\ string operators append attach detract ks 21 jun 87 + +\ : append ( char addr -- ) +\ under count + c! dup c@ 1+ swap c! ; + +\ : attach ( addr len addr.to -- ) +\ >r under r@ count + swap move r@ c@ + r> c! ; + +\ : detract ( addr -- char ) +\ dup c@ 1- dup 0> and over c! +\ count >r dup count -rot swap r> cmove ; + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ ?" string operator ks 09 feb 88 + +\ : (?" ( 8b -- index ) "lit under count rot +\ scan IF swap - exit THEN 2drop false ; + +| Create months ," janfebmäraprmaijunjulaugsepoktnovdez" + + : >months ( n -- addr len ) 3 * 2- months + 3 ; + +| Code (?" ( 8b -- index ) + A D xchg I ) C- mov 0 # C+ mov C I add + I W mov I inc std 0<>rep byte scas cld + 0= ?[ C inc ]? C D mov Next + end-code + + : ?" compile (?" ," align ; immediate restrict + +\ *** Block No. 9, Hexblock 9 + +\ Conditional compilation ks 12 dez 88 +| Defer cond + + : .THEN ; immediate + + : .ELSE ( -- ) 0 + BEGIN name nullstring? IF drop exit THEN + find IF cond -1 case? ?exit ELSE drop THEN + REPEAT ; immediate + + : .IF ( f -- ) ?exit [compile] .ELSE ; immediate + +| : (cond ( n cfa -- n' ) + ['] .THEN case? IF 1- exit THEN + ['] .ELSE case? IF dup 0= + exit THEN + ['] .IF = 0=exit 1+ ; ' (cond is cond + +.( Systemerweiterung geladen) cr diff --git a/8086/msdos/f83asm.fb b/8086/msdos/src/f83asm.fb similarity index 100% rename from 8086/msdos/f83asm.fb rename to 8086/msdos/src/f83asm.fb diff --git a/8086/msdos/src/f83asm.fth b/8086/msdos/src/f83asm.fth new file mode 100644 index 0000000..6827b54 --- /dev/null +++ b/8086/msdos/src/f83asm.fth @@ -0,0 +1,646 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 8086 Assembler cas 10nov05 + +The 8086 Assembler was written by Mike Perry. +To create and assembler language definition, use the defining +word CODE. It must be terminated with either END-CODE or +its synonym C;. How the assembler operates is a very +interesting example of the power of CREATE DOES> Basically +the instructions are categorized and a defining word is +created for each category. When the nmemonic for the +instruction is interpreted, it compiles itself. + +Adapted for volksFORTH by Klaus Schleisiek + +No really tested, but + CODE TEST TOS PUSH 1 # TOS MOV NEXT END-CODE +works! + +\ *** Block No. 1, Hexblock 1 + +\ 8086 Assembler ks cas 10nov05 +Onlyforth +Vocabulary Assembler +: octal 8 Base ! ; + +decimal 1 14 +THRU clear + +Onlyforth + + : Code Create [ Assembler ] here dup 2- ! Assembler ; + +CR .( 8086 Assembler loaded ) +Onlyforth + + + + +\ *** Block No. 2, Hexblock 2 + +\ 8086 Assembler ks 19 mär 88 +: LABEL CREATE ASSEMBLER ; +\ 232 CONSTANT DOES-OP +\ 3 CONSTANT DOES-SIZE +\ : DOES? ( IP -- IP' F ) +\ DUP DOES-SIZE + SWAP C@ DOES-OP = ; +ASSEMBLER ALSO DEFINITIONS +: C; ( -- ) END-CODE ; +OCTAL +DEFER C, FORTH ' C, ASSEMBLER IS C, +DEFER , FORTH ' , ASSEMBLER IS , +DEFER HERE FORTH ' HERE ASSEMBLER IS HERE +DEFER ?>MARK +DEFER ?>RESOLVE +DEFER ? @ SWAP 7000 AND = 0<> ; +| 0 MD R8? | 1 MD R16? | 2 MD MEM? | 3 MD SEG? | 4 MD #? +| : REG? ( n -- f ) 7000 AND 2000 < 0<> ; +| : BIG? ( N -- F ) ABS -200 AND 0<> ; +| : RLOW ( n1 -- n2 ) 7 AND ; +| : RMID ( n1 -- n2 ) 70 AND ; +| VARIABLE SIZE SIZE ON +: BYTE ( -- ) SIZE OFF ; +| : OP, ( N OP -- ) OR C, ; +| : W, ( OP MR -- ) R16? 1 AND OP, ; +| : SIZE, ( OP -- OP' ) SIZE @ 1 AND OP, ; +| : ,/C, ( n f -- ) IF , ELSE C, THEN ; +| : RR, ( MR1 MR2 -- ) RMID SWAP RLOW OR 300 OP, ; +| VARIABLE LOGICAL +| : B/L? ( n -- f ) BIG? LOGICAL @ OR ; + +\ *** Block No. 5, Hexblock 5 + +\ Addressing ks 19 mär 88 +| : MEM, ( DISP MR RMID -- ) OVER #) = + IF RMID 6 OP, DROP , + ELSE RMID OVER RLOW OR -ROT [BP] = OVER 0= AND + IF SWAP 100 OP, C, ELSE SWAP OVER BIG? + IF 200 OP, , ELSE OVER 0= + IF C, DROP ELSE 100 OP, C, + THEN THEN THEN THEN ; +| : WMEM, ( DISP MEM REG OP -- ) OVER W, MEM, ; +| : R/M, ( MR REG -- ) + OVER REG? IF RR, ELSE MEM, THEN ; +| : WR/SM, ( R/M R OP -- ) 2 PICK DUP REG? + IF W, RR, ELSE DROP SIZE, MEM, THEN SIZE ON ; +| VARIABLE INTER +: FAR ( -- ) INTER ON ; +| : ?FAR ( n1 -- n2 ) INTER @ IF 10 OR THEN INTER OFF ; + +\ *** Block No. 6, Hexblock 6 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 1MI CREATE C, DOES> C@ C, ; +| : 2MI CREATE C, DOES> C@ C, 12 C, ; +| : 3MI CREATE C, DOES> C@ C, HERE - 1- + DUP -200 177 uWITHIN NOT ABORT" Branch out of Range" C, ; +| : 4MI CREATE C, DOES> C@ C, MEM, ; +| : 5MI CREATE C, DOES> C@ SIZE, SIZE ON ; +| : 6MI CREATE C, DOES> C@ SWAP W, ; +| : 7MI CREATE C, DOES> C@ 366 WR/SM, ; +| : 8MI CREATE C, DOES> C@ SWAP R16? 1 AND OR SWAP # = + IF C, C, ELSE 10 OR C, THEN ; +| : 9MI CREATE C, DOES> C@ OVER R16? + IF 100 OR SWAP RLOW OP, ELSE 376 WR/SM, THEN ; +| : 10MI CREATE C, DOES> C@ OVER CL = + IF NIP 322 ELSE 320 THEN WR/SM, ; + + +\ *** Block No. 7, Hexblock 7 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 11MI CREATE C, C, DOES> OVER #) = + IF NIP C@ INTER @ + IF 1 AND IF 352 ELSE 232 THEN C, SWAP , , INTER OFF + ELSE SWAP HERE - 2- SWAP 2DUP 1 AND SWAP BIG? NOT AND + IF 2 OP, C, ELSE C, 1- , THEN THEN + ELSE OVER S#) = IF NIP #) SWAP THEN + 377 C, 1+ C@ ?FAR R/M, THEN ; +| : 12MI CREATE C, C, C, DOES> OVER REG? + IF C@ SWAP RLOW OP, ELSE 1+ OVER SEG? + IF C@ RLOW SWAP RMID OP, + ELSE COUNT SWAP C@ C, MEM, + THEN THEN ; +| : 14MI CREATE C, DOES> C@ + DUP ?FAR C, 1 AND 0= IF , THEN ; + + +\ *** Block No. 8, Hexblock 8 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 13MI CREATE C, C, DOES> COUNT >R C@ LOGICAL ! DUP REG? + IF OVER REG? + IF R> OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF R> 2 OR WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF R> 4 OR OVER W, R16? ,/C, + ELSE OVER B/L? OVER R16? 2DUP AND + -ROT 1 AND SWAP NOT 2 AND OR 200 OP, + SWAP RLOW 300 OR R> OP, ,/C, + THEN THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF R> WMEM, + ELSE ( # ) DROP 2 PICK B/L? DUP NOT 2 AND 200 OR SIZE, + -ROT R> MEM, SIZE @ AND ,/C, SIZE ON + THEN THEN ; + + +\ *** Block No. 9, Hexblock 9 + +\ Instructions ks 19 mär 88 +: TEST ( source dest -- ) DUP REG? + IF OVER REG? + IF 204 OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF 204 WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF 250 OVER W, + ELSE 366 OVER W, DUP RLOW 300 OP, + THEN R16? ,/C, THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF 204 WMEM, + ELSE ( # ) DROP 366 SIZE, 0 MEM, SIZE @ ,/C, SIZE ON + THEN THEN ; + + + + + +\ *** Block No. 10, Hexblock a + +\ Instructions ks 19 mär 88 +HEX +: ESC ( source ext-opcode -- ) RLOW 0D8 OP, R/M, ; +: INT ( N -- ) 0CD C, C, ; +: SEG ( SEG -- ) RMID 26 OP, ; +: XCHG ( MR1 MR2 -- ) DUP REG? + IF DUP AX = + IF DROP RLOW 90 OP, ELSE OVER AX = + IF NIP RLOW 90 OP, ELSE 86 WR/SM, THEN THEN + ELSE ROT 86 WR/SM, THEN ; + +: CS: CS SEG ; +: DS: DS SEG ; +: ES: ES SEG ; +: SS: SS SEG ; + + +\ *** Block No. 11, Hexblock b + +\ Instructions ks 19 mär 88 +: MOV ( S D -- ) DUP SEG? + IF 8E C, R/M, ELSE DUP REG? + IF OVER #) = OVER RLOW 0= AND + IF A0 SWAP W, DROP , ELSE OVER SEG? + IF SWAP 8C C, RR, ELSE OVER # = + IF NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C, + ELSE 8A OVER W, R/M, THEN THEN THEN + ELSE ( MEM ) ROT DUP SEG? + IF 8C C, MEM, ELSE DUP # = + IF DROP C6 SIZE, 0 MEM, SIZE @ ,/C, + ELSE OVER #) = OVER RLOW 0= AND + IF A2 SWAP W, DROP , ELSE 88 OVER W, R/M, + THEN THEN THEN THEN THEN SIZE ON ; + + + +\ *** Block No. 12, Hexblock c + +\ Instructions 12Oct83map + 37 1MI AAA D5 2MI AAD D4 2MI AAM 3F 1MI AAS +0 10 13MI ADC 0 00 13MI ADD 2 20 13MI AND 10 E8 11MI CALL + 98 1MI CBW F8 1MI CLC FC 1MI CLD FA 1MI CLI + F5 1MI CMC 0 38 13MI CMP A6 5MI CMPS 99 1MI CWD + 27 1MI DAA 2F 1MI DAS 08 9MI DEC 30 7MI DIV + ( ESC ) F4 1MI HLT 38 7MI IDIV 28 7MI IMUL + E4 8MI IN 00 9MI INC ( INT ) 0CE 1MI INTO +0CF 1MI IRET 77 3MI JA 73 3MI JAE 72 3MI JB + 76 3MI JBE E3 3MI JCXZ 74 3MI JE 7F 3MI JG + 7D 3MI JGE 7C 3MI JL 7E 3MI JLE 20 E9 11MI JMP + 75 3MI JNE 71 3MI JNO 79 3MI JNS 70 3MI JO + 7A 3MI JPE 7B 3MI JPO 78 3MI JS 9F 1MI LAHF + C5 4MI LDS 8D 4MI LEA C4 4MI LES F0 1MI LOCK +0AC 6MI LODS E2 3MI LOOP E1 3MI LOOPE E0 3MI LOOPNE + + +\ *** Block No. 13, Hexblock d + +\ Instructions 12Apr84map + ( MOV ) 0A4 5MI MOVS 20 7MI MUL 18 7MI NEG + 90 1MI NOP 10 7MI NOT 2 08 13MI OR E6 8MI OUT + 8F 07 58 12MI POP 9D 1MI POPF + 0FF 36 50 12MI PUSH 9C 1MI PUSHF + 10 10MI RCL 18 10MI RCR + F2 1MI REP F2 1MI REPNZ F3 1MI REPZ + C3 14MI RET 00 10MI ROL 8 10MI ROR 9E 1MI SAHF + 38 10MI SAR 0 18 13MI SBB 0AE 5MI SCAS ( SEG ) + 20 10MI SHL 28 10MI SHR F9 1MI STC FD 1MI STD + FB 1MI STI 0AA 6MI STOS 0 28 13MI SUB ( TEST ) + 9B 1MI WAIT ( XCHG ) D7 1MI XLAT 2 30 13MI XOR + C2 14MI +RET + + + + +\ *** Block No. 14, Hexblock e + +\ Structured Conditionals ks 19 mär 88 +: A?>MARK ( -- f addr ) TRUE HERE 0 C, ; +: A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! true ?pairs ; +: A?MARK ASSEMBLER IS ?>MARK +' A?>RESOLVE ASSEMBLER IS ?>RESOLVE +' A? 79 CONSTANT 0< +78 CONSTANT 0>= 7D CONSTANT < 7C CONSTANT >= +7F CONSTANT <= 7E CONSTANT > 73 CONSTANT U< +72 CONSTANT U>= 77 CONSTANT U<= 76 CONSTANT U> +71 CONSTANT OV +DECIMAL + +\ *** Block No. 15, Hexblock f + +\ Structured Conditionals cas 10nov05 +HEX +: IF C, ?>MARK ; +: THEN ?>RESOLVE ; +: ELSE 0EB IF 2SWAP THEN ; +: BEGIN ? U +C; A synonym for END-CODE + +Deferring the definitions of the commas, marks, and resolves + allows the same assembler to serve for both the system and the + Meta-Compiler. + + + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ 8086 Assembler Register Definitions 12Oct83map + +On the 8086, register names are cleverly defined constants. + +The value returned by registers and by modes such as #) contains +both mode and register information. The instructions use the +mode information to decide how many arguments exist, and what to +assemble. + Like many CPUs, the 8086 uses many 3 bit fields in its opcodes +This makes octal ( base 8 ) natural for describing the registers + + +We redefine the Registers that FORTH uses to implement its +virtual machine. + + + +\ *** Block No. 19, Hexblock 13 + +\ Addressing Modes 16Oct83map +MD defines words which test for various modes. +R8? R16? MEM? SEG? #? test for mode equal to 0 thru 4. +REG? tests for any register mode ( 8 or 16 bit). +BIG? tests offsets size. True if won't fit in one byte. +RLOW mask off all but low register field. +RMID mask off all but middle register field. +SIZE true for 16 bit, false for 8 bit. +BYTE set size to 8 bit. +OP, for efficiency. OR two numbers and assemble. +W, assemble opcode with W field set for size of register. +SIZE, assemble opcode with W field set for size of data. +,/C, assemble either 8 or 16 bits. +RR, assemble register to register instruction. +LOGICAL true while assembling logical instructions. +B/L? see 13MI + +\ *** Block No. 20, Hexblock 14 + +\ Addressing 16Oct83map +These words perform most of the addressing mode encoding. +MEM, handles memory reference modes. It takes a displacement, + a mode/register, and a register, and encodes and assembles + them. + + +WMEM, uses MEM, after packing the register size into the opcode +R/M, assembles either a register to register or a register to + or from memory mode. +WR/SM, assembles either a register mode with size field, or a + memory mode with size from SIZE. Default is 16 bit. Use BYTE + for 8 bit size. +INTER true if inter-segment jump, call, or return. +FAR sets INTER true. Usage: FAR JMP, FAR CALL, FAR RET. +?FAR sets far bit, clears flag. + +\ *** Block No. 21, Hexblock 15 + +\ Defining Words to Generate Op Codes 12Oct83map +1MI define one byte constant instructions. +2MI define ascii adjust instructions. +3MI define branch instructions, with one byte offset. +4MI define LDS, LEA, LES instructions. +5MI define string instructions. +6MI define more string instructions. +7MI define multiply and divide instructions. +8MI define input and output instructions. + +9MI define increment/decrement instructions. + +10MI define shift/rotate instructions. +*NOTE* To allow both 'ax shl' and 'ax cl shl', if the register +on top of the stack is cl, shift second register by cl. If not, +shift top ( only) register by one. + +\ *** Block No. 22, Hexblock 16 + +\ Defining Words to Generate Op Codes 09Apr84map +11MI define calls and jumps. + notice that the first byte stored is E9 for jmp and E8 for call + so C@ 1 AND is zero for call, 1 for jmp. + syntax for direct intersegment: address segment #) FAR JMP + + + +12MI define pushes and pops. + + + + +14MI defines returns. + RET FAR RET n +RET n FAR +RET + + +\ *** Block No. 23, Hexblock 17 + +\ Defining Words to Generate Op Codes 16Oct83map +13MI define arithmetic and logical instructions. + + + + + + + + + + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ Instructions 16Oct83map +TEST bits in dest + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 + +\ Instructions 16Oct83map + +ESC +INT assemble interrupt instruction. +SEG assemble segment instruction. +XCHG assemble register swap instruction. + + + + + +CS: DS: ES: SS: assemble segment over-ride instructions. + + + + + +\ *** Block No. 26, Hexblock 1a + +\ Instructions 12Oct83map +MOV as usual, the move instruction is the most complicated. + It allows more addressing modes than any other, each of which + assembles something more or less unique. + + + + + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c + +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + +\ Structured Conditionals 16Oct83map +A?>MARK assembler version of forward mark. +A?>RESOLVE assembler version of forward resolve. +A? stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 06feb22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use cr file? probe-for-fb isfile@ freset IF 1 load close exit THEN incfile push isfile@ incfile ! incpos push incpos off incpos 2+ dup push off savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ \ phz 16jan22 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth new file mode 100644 index 0000000..0f5c3f4 --- /dev/null +++ b/8086/msdos/src/include.fth @@ -0,0 +1,152 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include for stream sources phz 06jan22 + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ load screen phz 06feb22 + + 1 6 +thru + + + + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ fib /fib #fib eolf? phz 06feb22 + + context @ dos also context ! + $50 constant /tib + variable tibeof tibeof off + + : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: eof: return line and flag eof + tibeof off + dup #lf = IF drop 0 exit THEN + -1 = IF tibeof on 1 ELSE -1 THEN ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ incfile incpos inc-fgetc phz 06feb22 + + variable incfile + variable incpos 2 allot + + : inc-fgetc ( -- c ) + incfile @ f.handle @ 0= IF + incpos 2@ incfile @ fseek THEN + incfile @ fgetc + incpos 2@ 1. d+ incpos 2! ; + + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ freadline probe-for-fb phz 06feb22 + + : freadline ( -- eof ) + tib /tib bounds DO + inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN + 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN + LOOP /tib #tib ! + ." warning: line exteeds max " /tib . cr + ." extra chars ignored" cr + BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; + +| : probe-for-fb ( -- flag ) + \ probes whether current file looks like a block file + /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN + LOOP true ; + + +\ *** Block No. 5, Hexblock 5 + +\ save/restoretib phz 16jan22 + + $50 constant /stash + create stash[ /stash allot here constant ]stash + variable stash> stash[ stash> ! + + : savetib ( -- n ) + #tib @ >in @ - dup stash> @ + ]stash u> + abort" tib stash overflow" >r + tib >in @ + stash> @ r@ cmove + r@ stash> +! r> ; + + : restoretib ( n -- ) + dup >r negate stash> +! stash> @ tib r@ cmove + r> #tib ! >in off ; + + +\ *** Block No. 6, Hexblock 6 + +\ interpret-via-tib include phz 06feb22 + + : interpret-via-tib + BEGIN freadline >r .status >in off interpret + r> UNTIL ; + + : include ( -- ) + pushfile use cr file? + probe-for-fb isfile@ freset IF 1 load close exit THEN + incfile push isfile@ incfile ! + incpos push incpos off incpos 2+ dup push off + savetib >r interpret-via-tib close r> restoretib ; + + : (stashquit stash[ stash> ! (quit ; + : stashrestore ['] (stashquit IS 'quit ; + ' stashrestore IS 'restart + +\ *** Block No. 7, Hexblock 7 + +\ \ phz 16jan22 + + : \ blk @ IF >in @ negate c/l mod >in +! + ELSE #tib @ >in ! THEN ; immediate + + + + + + + + + + + + diff --git a/8086/msdos/install.fb b/8086/msdos/src/install.fb similarity index 100% rename from 8086/msdos/install.fb rename to 8086/msdos/src/install.fb diff --git a/8086/msdos/src/install.fth b/8086/msdos/src/install.fth new file mode 100644 index 0000000..778d8b2 --- /dev/null +++ b/8086/msdos/src/install.fth @@ -0,0 +1,342 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Install Editor cas 10nov05 + +This file contains the Installer for the Forth Editor + +The Installer will query for keystrokes that should invoke +the Editor commands. + +This allows custom keybinding for the individual requirements + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ install Editor cas 10nov05 + +Onlyforth Editor also save warning on + +: tab &20 col &20 mod - spaces ; +: .key ( c -- ) + dup $7E > IF ." $" u. exit THEN + dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; + +: install \ install editor's keyboard + page ." Press keys requested (Spacebar to confirm)" + #keys 0 ?DO cr I 2* actiontable + @ >name .name + tab ." : " I 2* keytable + dup @ .key tab ." -> " + key dup bl = IF drop dup @ THEN dup .key swap ! + LOOP ; +--> + +\ *** Block No. 2, Hexblock 2 + +\ define action-names UH 11mai88 +: :a ( addr -- adr' ) dup @ Alias 2+ ; +actiontable +:a up :a left :a down :a right +:a push-line :a push-char :a pull-line :a pull-char +:a fix-word :a screen# :a copy-line :a copy-char +:a backspace :a backspace :a backspace :a delete-char +( :a insert-char ) :a delete-line :a insert-line +:a flipimode ( :a erase-line :a clear-to-right) +:a new-line :a +tab :a -tab +:a home :a to-end :a search :a undo +:a update-exit :a flushed-exit :a showload :a shadow-screen +:a next-Screen :a back-Screen :a alter-Screen :a mark-screen +drop + +warning off install empty + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + + + + + + + + + + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/kernel.fb b/8086/msdos/src/kernel.fb similarity index 100% rename from 8086/msdos/kernel.fb rename to 8086/msdos/src/kernel.fb diff --git a/8086/msdos/src/kernel.fth b/8086/msdos/src/kernel.fth new file mode 100644 index 0000000..a29411d --- /dev/null +++ b/8086/msdos/src/kernel.fth @@ -0,0 +1,3040 @@ + +\ *** Block No. 0, Hexblock 0 + +\^@ #### volksFORTH #### cas 18jul20 +VolksForth has been developed by + + K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck + Ulli Hoffmann, Philip Zembrod, Carsten Strotmann +6502 version by B.Pennemann and K.Schleisiek +Port to C64 "ultraFORTH" by G. Rehfeld +Port to 68000 and Atari ST by D.Weineck and B.Pennemann +Port to 8080 and CP/M by U.Hoffmann jul 86 +Port to C16 "ultraFORTH" by C.Vogt +Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS volksForth Load Screen ks cas 18jul20 + Onlyforth \needs Transient include meta.fb + + 2 loadfrom META.fb + + new FORTH.COM Onlyforth Target definitions + + 4 &111 thru \ Standard 8088-System + + flush \ close FORTH.COM + +cr .( new kernel as "FORTH.COM" written) cr bell + + + + + +\ *** Block No. 2, Hexblock 2 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt +Dabei ist die Zuordnung zu den Intel Namen folgendermassen: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A und C sind zur allgemeinen Benutzung frei + +D <=> DX D- <=> DL D+ <=> DH + das oberste Element des (Daten)-Stacks. + +R <=> BX R- <=> RL R+ <=> RH + der Return_stack_pointer + + + +\ *** Block No. 3, Hexblock 3 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + Alle Segmentregister werden beim booten auf den Wert des + Codesegments C: gesetzt und muessen, wenn sie "verstellt" + werden, wieder auf C: zurueckgesetzt werden. + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ FORTH Preamble and ID ks 11 mär 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 rev. 3.81.41" + + + + +\ *** Block No. 5, Hexblock 5 + +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next ist in-line code. Fuer den debugger werden daher alle +\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target + + +\ *** Block No. 6, Hexblock 6 + +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code + +\ *** Block No. 7, Hexblock 7 + +\ User variables ks 16 sep 88 + 8 uallot drop \ Platz fuer Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link cr .( Wieso ist UDP Uservariable? ) + User udp \ points to next free addr in User_area + +\ *** Block No. 8, Hexblock 8 + +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment + + + +\ *** Block No. 9, Hexblock 9 + +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict + + + + + +\ *** Block No. 10, Hexblock a + +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; + +\ *** Block No. 11, Hexblock b + +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; + + + + + + + + + +\ *** Block No. 12, Hexblock c + +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code + + + +\ *** Block No. 13, Hexblock d + +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; + + + + + + + +\ *** Block No. 14, Hexblock e + +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code + + + + + +\ *** Block No. 15, Hexblock f + +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; + +\ *** Block No. 17, Hexblock 11 + +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; + +\ *** Block No. 19, Hexblock 13 + +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; + +\ *** Block No. 20, Hexblock 14 + +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code + + + + +\ *** Block No. 21, Hexblock 15 + +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; + +\ *** Block No. 25, Hexblock 19 + +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; + + + +\ *** Block No. 27, Hexblock 1b + +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; + +\ *** Block No. 28, Hexblock 1c + +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; + + +\ *** Block No. 29, Hexblock 1d + +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; + + + + +\ *** Block No. 30, Hexblock 1e + +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; + +\ *** Block No. 31, Hexblock 1f + +\\ min max umax umin extend 10Mar8 + +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; + + + + + + +\ *** Block No. 32, Hexblock 20 + +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; + + +\ *** Block No. 33, Hexblock 21 + +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\\ + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + + : (do ( limit start -- ) over - dodo ; restrict + : (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict + + +\ *** Block No. 34, Hexblock 22 + +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict + +\ *** Block No. 38, Hexblock 26 + +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | + + + +\ *** Block No. 39, Hexblock 27 + +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; + + + +\ *** Block No. 40, Hexblock 28 + +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; + + +\ *** Block No. 41, Hexblock 29 + +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; + + + + +\ *** Block No. 42, Hexblock 2a + +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; + + + +\ *** Block No. 43, Hexblock 2b + +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code + + +\ *** Block No. 44, Hexblock 2c + +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; + + + +\ *** Block No. 45, Hexblock 2d + +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; + + + + + + + +\ *** Block No. 46, Hexblock 2e + +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict + + + +\ *** Block No. 47, Hexblock 2f + +\ input strings ks 23 dez 87 + + Variable #tib #tib off + Variable >tib here >tib ! $50 allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; + + + + + + +\ *** Block No. 48, Hexblock 30 + +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code + + +\ *** Block No. 49, Hexblock 31 + +\\ scan skip /string ks 29 jul 87 + + : skip ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : /string ( addr0 len0 +n -- addr1 len1 ) + over umin rot over + -rot - ; + + + +\ *** Block No. 50, Hexblock 32 + +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ ä + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ ö + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ ü + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code + + + + +\ *** Block No. 51, Hexblock 33 + +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\\ high level, ohne Umlaute + + : capital ( char -- char') + dup Ascii a [ Ascii z 1+ ] Literal + uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + + : upper ( addr len -- ) + bounds ?DO I c@ capital I c! LOOP ; + +\ *** Block No. 52, Hexblock 34 + +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code + + +\ *** Block No. 53, Hexblock 35 + +\\ (word ks 27 oct 86 + +| : (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string r@ skip + over swap r> scan >r rot over swap - r> 0<> - >in ! + over - here dup >r place bl r@ count + c! r> ; + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + +\ source word parse name ks 03 aug 87 + + Variable loadfile loadfile off + + : source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; + + + + +\ *** Block No. 55, Hexblock 37 + +\ state Ascii ," "lit (" " ks 16 sep 88 + Variable state state off + + : Ascii ( char -- n ) bl word 1+ c@ + state @ 0=exit [compile] Literal ; immediate + + : ," Ascii " parse here over 1+ allot place ; + + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + + : (" "lit ; restrict + + : " compile (" ," align ; immediate restrict + +\ *** Block No. 56, Hexblock 38 + +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( Ascii ) parse 2drop ; immediate + : .( Ascii ) parse type ; immediate + + : \ >in @ negate c/l mod >in +! ; immediate + : \\ b/blk >in ! ; immediate + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; + + +\ *** Block No. 57, Hexblock 39 + +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and + THEN Ascii 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + + + + + +\ *** Block No. 58, Hexblock 3a + +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : char ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii & case? IF &10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + +\ *** Block No. 59, Hexblock 3b + +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + +\ *** Block No. 60, Hexblock 3c + +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num char + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; + + +\ *** Block No. 61, Hexblock 3d + +\ hide reveal immediate restrict ks 18 mär 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; + +\ *** Block No. 62, Hexblock 3e + +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; + + + +\ *** Block No. 63, Hexblock 3f + +\ Does> ; ks 18 mär 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict + + + + +\ *** Block No. 64, Hexblock 40 + +\ ?head | alignments ks 19 mär 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate +\ machen nichts beim 8088. 8086 koennte etwas schneller werden + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; + + +\ *** Block No. 65, Hexblock 41 + +\ Create Variable ks 19 mär 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; + + + + +\ *** Block No. 66, Hexblock 42 + +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + +\\ + + : nfa? ( thread cfa -- nfa / false ) >r + BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; + + +\ *** Block No. 67, Hexblock 43 + +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; + +\ *** Block No. 68, Hexblock 44 + +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code + + + + +\ *** Block No. 69, Hexblock 45 + +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code + +\ *** Block No. 70, Hexblock 46 + +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; + +\ *** Block No. 71, Hexblock 47 + +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; + +\ *** Block No. 72, Hexblock 48 + +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] Ascii capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; + +\ *** Block No. 73, Hexblock 49 + +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code + +\ *** Block No. 74, Hexblock 4a + +\\ -text (find ks 02 okt 87 + + : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) + over bounds + DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + + : (find ( string thread -- str false / NFA +n ) + over c@ $1F and >r @ + BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = + IF dup 1+ r@ 4 pick 1+ -text + 0= IF rdrop -rot drop exit + THEN THEN drop + REPEAT rdrop ; + + + + +\ *** Block No. 75, Hexblock 4b + +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; + + +\ *** Block No. 76, Hexblock 4c + +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; + + + +\ *** Block No. 77, Hexblock 4d + +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; + +\ *** Block No. 78, Hexblock 4e + +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate + + + + + + + + +\ *** Block No. 79, Hexblock 4f + +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; + + + + +\ *** Block No. 80, Hexblock 50 + +\ .status push load ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + : (load ( blk offset -- ) isfile@ >r + loadfile @ >r fromfile @ >r blk @ >r >in @ >r + >in ! blk ! isfile@ loadfile ! .status interpret + r> >in ! r> blk ! r> fromfile ! r> loadfile ! + r> isfile ! ; + + : load ( blk -- ) ?dup 0=exit 0 (load ; + + +\ *** Block No. 81, Hexblock 51 + +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : +load ( offset -- ) blk @ + load ; + + : thru ( from to -- ) 1+ swap DO I load LOOP ; + + : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + + : --> 1 blk +! >in off .status ; immediate + + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + + + +\ *** Block No. 82, Hexblock 52 + +\ prompt quit ks 16 sep 88 + + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; + + +\ *** Block No. 83, Hexblock 53 + +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; + + + + + +\ *** Block No. 84, Hexblock 54 + +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict + + + +\ *** Block No. 85, Hexblock 55 + +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; + + + + + +\ *** Block No. 86, Hexblock 56 + +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; + +\ *** Block No. 87, Hexblock 57 + +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + + + + +\ *** Block No. 88, Hexblock 58 + +\ list c/l l/s ks 19 mär 88 + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + + : list ( scr -- ) dup capacity u< + IF scr ! ." Scr " scr @ . + ." Dr " drv . isfile@ .file + l/s 0 DO cr I 2 .r space scr @ block + I c/l * + c/l -trailing type + LOOP cr exit + THEN 9 ?diskerror ; + + + + + +\ *** Block No. 89, Hexblock 59 + +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT + +\ *** Block No. 90, Hexblock 5a + +\\ Struktur der Blockpuffer ks 04 jul 87 + + 0 : link zum naechsten Puffer + 2 : file 0 = direct access + -1 = leer, + sonst adresse eines file control blocks + 4 : blocknummer + 6 : statusflags Vorzeichenbit kennzeichnet update + 8 : Data ... 1 Kb ... + + + + + + + + +\ *** Block No. 91, Hexblock 5b + +\ buffer mechanism ks 04 okt 87 + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Variable prev prev off \ Listhead +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung + + + +\ *** Block No. 92, Hexblock 5c + +\ (core? ks 28 mai 87 + + Code (core? ( blk file -- dataaddr / blk file ) + A pop A push D D or 0= ?[ u' offset U D) A add ]? + prev #) W mov 2 W D) D cmp 0= + ?[ 4 W D) A cmp 0= + ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? + [[ [[ W ) C mov C C or 0= ?[ Next ]? + C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] + W ) A mov prev #) D mov D W ) mov W prev #) mov + 8 W D) D lea C W mov A W ) mov A pop + ' exit @ # jmp + end-code + + + + +\ *** Block No. 93, Hexblock 5d + +\\ (core? ks 31 oct 86 + +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + + .( (core?: offset is handled differently in code! ) + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; + +\ *** Block No. 94, Hexblock 5e + +\ backup emptybuf readblk ks 23 jul 87 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE 1 ?diskerror REPEAT + THEN 4+ dup @ $7FFF and over ! THEN + drop ; + + : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf >r + BEGIN 2dup 0= offset @ and + + over r@ 8 + -rot 1 r/w + WHILE 2 ?diskerror REPEAT r> ; + +\ *** Block No. 95, Hexblock 5f + +\ take mark updates? full? core? ks 04 jul 87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) 2+ >r + 2dup r@ ! over 0= offset @ and + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + + : core? ( blk file -- addr /false ) (core? 2drop false ; + + + +\ *** Block No. 96, Hexblock 60 + +\ block & buffer manipulation ks 01 okt 87 + + : (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + + : (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; + + +\ *** Block No. 97, Hexblock 61 + +\ block & buffer manipulation ks 02 okt 87 + + : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + + : save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; + + : empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; + + + + +\ *** Block No. 98, Hexblock 62 + +\ Allocating buffers ks 31 oct 86 + $10000 Constant limit Variable first + + : allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + + : freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + + : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : init-buffers prev off limit first ! all-buffers ; + +\ *** Block No. 99, Hexblock 63 + +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; + +\ *** Block No. 100, Hexblock 64 + +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; + +\ *** Block No. 101, Hexblock 65 + +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words remove-files + custom-remove heap swap - hallot dp ! last off ; + + + +\ *** Block No. 102, Hexblock 66 + +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; + + + + + +\ *** Block No. 103, Hexblock 67 + +\ save bye stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; + + + +\ *** Block No. 104, Hexblock 68 + +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + + +\ *** Block No. 105, Hexblock 69 + +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions + + + + +\ *** Block No. 106, Hexblock 6a + +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; + + +\ *** Block No. 107, Hexblock 6b + +\ (boot ks 11 mär 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code + + + +\ *** Block No. 108, Hexblock 6c + +\ restart ks 09 mär 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code + + + + + +\ *** Block No. 109, Hexblock 6d + +\ bye ks 11 mär 89 + + Variable return_code return_code off + +| Code (bye cli A A xor A E: mov #segs # call + C: D mov D R add R D: mov 0 # I mov I W mov + $200 # C mov rep movs sti \ restore interrupts + $4C # A+ mov C: seg return_code #) A- mov + $21 int warmboot # call + end-code + + : bye flush empty page (bye ; + + + + + +\ *** Block No. 110, Hexblock 6e + +\ cold ks 09 mär 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + #segs # call $41 # R add \ another k for the ints + $4A # A+ mov $21 int \ alloc memory + CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code + + + + + +\ *** Block No. 111, Hexblock 6f + +\ System patchup ks 16 sep 88 + + 1 &35 +thru \ MS-DOS interface + + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved + + +\ *** Block No. 112, Hexblock 70 + +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code + + + +\ *** Block No. 113, Hexblock 71 + +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code + + + + +\ *** Block No. 114, Hexblock 72 + +\ BDOS keyboard input ks 16 sep 88 +\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P + +| Variable newkey newkey off + + Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or + 0= ?[ $7 # A+ mov $21 int A- D- mov ]? + 0 # D+ mov D+ newkey 1+ #) mov Next + end-code + + Code (key? ( -- f ) D push newkey #) D mov D+ D+ or + 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= + ?[ 0 # D+ mov + ][ -1 # A+ mov A newkey #) mov -1 # D+ mov + ]? ]? D+ D- mov Next + end-code + +\ *** Block No. 115, Hexblock 73 + +\ empty-keys (key ks 16 sep 88 + + Code empty-keys $C00 # A mov $21 int + 0 # newkey 1+ #) byte mov Next end-code + + : (key ( -- 16b ) BEGIN pause (key? UNTIL + (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + +\\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + A- D- xchg 0 # D+ mov Next end-code + + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +\ mit diesen Keytreibern sind die Funktionstasten nicht +\ mehr durch ANSI.SYS Sequenzen vorbelegt. + + + +\ *** Block No. 117, Hexblock 75 + +\ (decode expect ks 16 sep 88 + + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr + + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop + +\ *** Block No. 118, Hexblock 76 + +\ MSDOS character output ks 29 jun 87 + + Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? + 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; + + + +\ *** Block No. 119, Hexblock 77 + +\ MSDOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + +\ MSDOS printer I/O Port access ks 09 aug 87 + + Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next + end-code + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code + + + + + +\ *** Block No. 121, Hexblock 79 + +\ zero terminated strings ks 09 aug 87 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + + + : asciz ( -- asciz ) name here >asciz ; + + + + + + +\ *** Block No. 122, Hexblock 7a + +\ Disk capacities ks 08 aug 88 + Vocabulary Dos Dos also definitions + + 6 Constant #drives + + Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , + +| Code ?capacity ( +n -- cap ) D shl capacities # W mov + D W add W ) D mov Next end-code + + + + + + + + +\ *** Block No. 123, Hexblock 7b + +\ MS-dos disk handlers direct access ks 31 jul 87 + +| Code block@ ( addr blk drv -- ff ) + D- A- mov D pop C pop R push U push + I push C R mov 2 # C mov D shl $25 int + Label end-r/w I pop I pop U pop R pop 0 # D mov + CS ?[ D+ A+ mov A error# #) mov D dec ]? Next + end-code + +| Code block! ( addr blk drv -- ff ) D- A- mov D pop + C pop R push U push I push C R mov 2 # C mov + D shl $26 int end-r/w # jmp + end-code + + + + +\ *** Block No. 124, Hexblock 7c + +\ MS-dos disk handlers direct access ks cas 18jul20 + +| : ?drive ( +n -- +n ) dup #drives u< ?exit + Error" beyond drive capacity" ; + + : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 + DO dup I ?capacity under u< IF drop LEAVE THEN + - swap 1+ swap LOOP swap ; + + : blk/drv ( -- capacity ) drv ?capacity ; + + Forth definitions + + : >drive ( blk1 +n -- blk2 ) ?drive + 0 swap drv 2dup u> dup >r 0= IF swap THEN + ?DO I ?capacity + LOOP r> IF negate THEN - ; + +\ *** Block No. 125, Hexblock 7d + +\ MS-DOS file access ks 18 mär 88 + Dos definitions + +| Variable fcb fcb off \ last fcb accessed +| Variable prevfile \ previous active file + + &30 Constant fnamelen \ default length in FCB + + Create filename &62 allot \ max 60 + count + null + + Variable attribut 7 attribut ! \ read-only, hidden, system + + + + + + +\ *** Block No. 126, Hexblock 7e + +\ MS-DOS disk errors ks cas 18jul20 + +| : .error# ." error # " base push decimal error# @ . ; + +| : .ferrors error# @ &18 case? IF 2 THEN + 1 case? Abort" file exists" + 2 case? Abort" file not found" + 3 case? Abort" path not found" + 4 case? Abort" too many open files" + 5 case? Abort" no access" + 9 case? Abort" beyond end of file" + &15 case? Abort" illegal drive" + &16 case? Abort" current directory" + &17 case? Abort" wrong drive" + drop ." Disk" .error# abort ; + + +\ *** Block No. 127, Hexblock 7f + +\ MS-DOS disk errors ks cas 18jul20 + + : (diskerror ( *f -- ) ?dup 0=exit + fcb @ IF error# ! .ferrors exit THEN + input push output push standardi/o 1- + IF ." read" ELSE ." write" THEN + .error# ." retry? (y/n)" + key cr capital Ascii Y = not Abort" aborted" ; + + ' (diskerror Is ?diskerror + + + + + + + +\ *** Block No. 128, Hexblock 80 + +\ ~open ~creat ~close ks 04 aug 87 + + Code ~open ( asciz mode -- handle ff / err# ) + A D xchg $3D # A+ mov + Label >open D pop $21 int A D xchg + CS not ?[ D push 0 # D mov ]? Next + end-code + + Code ~creat ( asciz attribut -- handle ff / err# ) + D C mov $3C # A+ mov >open ]] end-code + + Code ~close ( handle -- ) D R xchg + $3E # A+ mov $21 int R D xchg D pop Next + end-code + + + +\ *** Block No. 129, Hexblock 81 + +\ ~first ~unlink ~select ~disk? ks 04 aug 87 + + Code ~first ( asciz attr -- err# ) + D C mov D pop $4E # A+ mov + [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code + + Code ~select ( n -- ) + $E # A+ mov $21 int D pop Next end-code + + Code ~disk? ( -- n ) D push $19 # A+ mov + $21 int A- D- mov 0 # D+ mov Next + end-code + + +\ *** Block No. 130, Hexblock 82 + +\ ~next ~dir ks 04 aug 87 + + Code ~next ( -- err# ) D push $4F # A+ mov + $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~dir ( addr drive -- err# ) I W mov + I pop $47 # A+ mov $21 int W I mov + 0 # D mov CS ?[ A D xchg ]? Next + end-code + + + + + + + +\ *** Block No. 131, Hexblock 83 + +\ MS-DOS file control Block cas 19jun20 + +| : Fcbytes ( n1 len -- n2 ) Create over c, + + Does> ( fcbaddr -- fcbfield ) c@ + ; + +\ first field for file-link +2 1 Fcbytes f.no \ must be first field + 2 Fcbytes f.handle + 2 Fcbytes f.date + 2 Fcbytes f.time + 4 Fcbytes f.size + fnamelen Fcbytes f.name Constant b/fcb + +b/fcb Host ' tb/fcb >body ! + Target Forth also Dos also definitions + + +\ *** Block No. 132, Hexblock 84 + +\ (.file fname fname! ks 10 okt 87 + + : fname! ( string fcb -- ) f.name >r count + dup fnamelen < not Abort" file name too long" r> place ; + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + + : fclose ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup 0= IF drop exit THEN + over flushfile ~close f.handle off ; + + +\ *** Block No. 133, Hexblock 85 + +\ (.file fname fname! ks 18 mär 88 + +| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; + + : (fsearch ( string -- asciz *f ) + filename >asciz dup attribut @ ~first ; + + Defer fsearch ( string -- asciz *f ) + + ' (fsearch Is fsearch + +\ graceful behaviour if file does not exist +| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = + IF hide file-link @ @ file-link ! prevfile @ setfiles + last @ 4 - dp ! last off filename count here place + THEN ?diskerror ; + +\ *** Block No. 134, Hexblock 86 + +\ freset fseek ks 19 mär 88 + + : freset ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup IF ~close THEN dup >r + f.name fsearch ?notfound getsize r@ f.size 2! + [ $80 &22 + ] Literal @ r@ f.time ! + [ $80 &24 + ] Literal @ r@ f.date ! + 2 ~open ?diskerror r> f.handle ! ; + + + Code fseek ( dfaddr fcb -- ) + D W mov u' f.handle W D) W mov W W or 0= + ?[ ;c: dup freset fseek ; Assembler ]? R W xchg + C pop D pop $4200 # A mov $21 int W R mov + CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; + + +\ *** Block No. 135, Hexblock 87 + +\ lfgets fgetc file@ ks 07 jul 88 + +\ Code ~read ( seg:addr quan handle -- #read ) D W mov +Assembler [[ W R xchg C pop D pop + D: pop $3F # A+ mov $21 int C: C mov C D: mov + W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; + + Code lfgets ( seg:addr quan fcb -- #read ) + D W mov u' f.handle W D) W mov ]] end-code + + true Constant eof + + : fgetc ( fcb -- 8b / eof ) + >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; + + : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; + +\ *** Block No. 136, Hexblock 88 + +\ lfputs fputc file! ks 24 jul 87 + +| Code ~write ( seg:addr quan handle -- ) D W mov +[[ W R xchg C pop D pop + D: pop $40 # A+ mov $21 int W R mov A D xchg + C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? + C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; + + Code lfputs ( seg:addr quan fcb -- ) + D W mov u' f.handle W D) W mov ]] end-code + + : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; + + : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; + + + +\ *** Block No. 137, Hexblock 89 + +\ /block *block ks 02 okt 87 + + Code /block ( d -- rest blk ) A D xchg C pop + C D mov A shr D rcr A shr D rcr D+ D- mov + A- D+ xchg $3FF # C and C push Next + end-code +\ : /block ( d -- rest blk ) b/blk um/mod ; + + Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg + A+ sal D rcl A+ sal D rcl A push Next + end-code +\ : *block ( blk -- d ) b/blk um* ; + + + + + +\ *** Block No. 138, Hexblock 8a + +\ fblock@ fblock! ks 19 mär 88 + Dos definitions + +| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; + +| : fblock ( addr blk fcb -- seg:addr quan fcb ) + fcb ! ?beyond dup *block fcb @ fseek ds@ -rot + fcb @ f.size 2@ /block rot - ?beyond + IF drop b/blk THEN fcb @ ; + + : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; + + : fblock! ( addr blk fcb -- ) fblock lfputs ; + + + + +\ *** Block No. 139, Hexblock 8b + +\ (r/w flush ks 18 mär 88 + Forth definitions + + : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over + IF IF fblock@ false exit THEN fblock! false exit + THEN >r drop /drive ?drive + r> IF block@ exit THEN block! ; + + ' (r/w Is r/w + +| : setfiles ( fcb -- ) isfile@ prevfile ! + dup isfile ! fromfile ! ; + + : direct 0 setfiles ; + + + +\ *** Block No. 140, Hexblock 8c + +\ File >file ks 23 mär 88 + + : File Create file-link @ here file-link ! , + here [ b/fcb 2 - ] Literal dup allot erase + file-link @ dup @ f.no c@ 1+ over f.no c! + last @ count $1F and rot f.name place + Does> setfiles ; + + File kernel.scr ' kernel.scr @ Constant [fcb] + + Dos definitions + + : .file ( fcb -- ) + ?dup IF body> >name .name exit THEN ." direct" ; + + + +\ *** Block No. 141, Hexblock 8d + +\ .file pushfile close open ks 12 mai 88 + Forth definitions + + : file? isfile@ .file ; + + : pushfile r> isfile push fromfile push >r ; restrict + + : close isfile@ fclose ; + + : open isfile@ freset ; + + : assign isfile@ dup fclose name swap fname! open ; + + + + + +\ *** Block No. 142, Hexblock 8e + +\ use from loadfrom include ks 18 mär 88 + + : use >in @ name find + 0= IF swap >in ! File last' THEN nip + dup @ [fcb] = over ['] direct = or + 0= Abort" not a file" execute open ; + + : from isfile push use ; + + : loadfrom ( n -- ) pushfile use load close ; + + : include 1 loadfrom ; + + + + + +\ *** Block No. 143, Hexblock 8f + +\ drive drv capacity drivenames ks 18 mär 88 + + : drive ( n -- ) isfile@ IF ~select exit THEN + ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; + + : drv ( -- n ) + isfile@ IF ~disk? exit THEN offset @ /drive nip ; + + : capacity ( -- n ) isfile@ ?dup + IF dup f.handle @ 0= IF dup freset THEN + f.size 2@ /block swap 0<> - exit THEN blk/drv ; + +| : Drv: Create c, Does> c@ drive ; + + 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: + 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: + +\ *** Block No. 144, Hexblock 90 + +\ lfsave savefile savesystem ks 10 okt 87 + + : lfsave ( seg:addr quan string -- ) + filename >asciz 0 ~creat ?diskerror + dup >r ~write r> ~close ; + + : savefile ( addr len -- ) ds@ -rot + name nullstring? Abort" needs name" lfsave ; + + : savesystem save flush $100 here savefile ; + + + + + + + +\ *** Block No. 145, Hexblock 91 + +\ viewing ks 19 mär 88 + Dos definitions +| $400 Constant viewoffset + + : (makeview ( -- n ) + blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup + IF viewoffset * + $8000 or exit THEN 0= ; + ' (makeview Is makeview + + : @view ( acf -- blk fno ) >name 4 - @ dup 0< + IF $7FFF and viewoffset u/mod exit THEN + ?dup 0= Error" eingetippt" 0 ; + + : >file ( fno -- fcb ) dup 0=exit file-link + BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; + + +\ *** Block No. 146, Hexblock 92 + +\ forget FCB's ks 23 okt 88 + Forth definitions +| : 'file ( -- scr ) r> scr push isfile push >r + [ Dos ] ' @view >file isfile ! ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + +| : remove? ( dic symb addr -- dic symb addr f ) + 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb ) file-link + BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT + file-link remove + isfile@ remove? nip IF file-link @ isfile ! THEN + fromfile @ remove? nip 0=exit isfile@ fromfile ! ; + +\ *** Block No. 147, Hexblock 93 + +\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + 0 # D+ mov A- D- mov A- A- or + 0= ?[ A+ D- mov D+ com ]? Next end-code + + : test BEGIN (key@ #esc case? ?exit + cr dup emit 5 .r key 5 .r REPEAT ; +\\ + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + + +\ *** Block No. 148, Hexblock 94 + + + + + + + + + + + + + + + + + + +\ *** Block No. 149, Hexblock 95 + + + + + + + + + + + + + + + + + + +\ *** Block No. 150, Hexblock 96 + + + + + + + + + + + + + + + + + + +\ *** Block No. 151, Hexblock 97 + + + + + + + + + + + + + + + + + + +\ *** Block No. 152, Hexblock 98 + + + + + + + + + + + + + + + + + + +\ *** Block No. 153, Hexblock 99 + + + + + + + + + + + + + + + + + + +\ *** Block No. 154, Hexblock 9a + + + + + + + + + + + + + + + + + + +\ *** Block No. 155, Hexblock 9b + + + + + + + + + + + + + + + + + + +\ *** Block No. 156, Hexblock 9c + + + + + + + + + + + + + + + + + + +\ *** Block No. 157, Hexblock 9d + + + + + + + + + + + + + + + + + + +\ *** Block No. 158, Hexblock 9e + + + + + + + + + + + + + + + + + + +\ *** Block No. 159, Hexblock 9f + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/m130i.prn b/8086/msdos/src/m130i.prn similarity index 100% rename from 8086/msdos/m130i.prn rename to 8086/msdos/src/m130i.prn diff --git a/8086/msdos/meta.fb b/8086/msdos/src/meta.fb similarity index 99% rename from 8086/msdos/meta.fb rename to 8086/msdos/src/meta.fb index 18bf82f..0716ca9 100644 --- a/8086/msdos/meta.fb +++ b/8086/msdos/src/meta.fb @@ -1 +1 @@ - \ Target compiler loadscr ks cas 09jun20 Onlyforth \needs Assembler 2 loadfrom asm.fb : c+! ( 8b addr -- ) dup c@ rot + swap c! ; ' find $22 + @ Alias found : search ( string 'vocab -- acf n / string ff ) dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" >body (find IF found exit THEN false ; 3 &27 thru Onlyforth savesystem meta.com cr .( Metacompiler saved as META.COM ) \ Predefinitions loadscreen ks 30 apr 88 &28 load cr .( Predefinitions geladen ...) cr \ Target header pointers ks 29 jun 87 Variable tfile tfile off \ handle of target file Variable tdp tdp off \ target dp Variable displace displace off \ diplacement of code Variable ?thead ?thead off \ for headerless code Variable tlast tlast off \ last name in target Variable glast' glast' off \ acf of latest ghost Variable tdoes> tdoes> off \ code addr of last does Variable tdodo tdodo off \ location of dodo Variable >in: >in: off \ last :-def Variable tvoc tvoc off \ Variable tvoc-link tvoc-link off \ voc-link in target Variable tnext-link tnext-link off \ link for tracer \ Target header pointers ks 10 okt 87 : there ( -- taddr ) tdp @ ; : new pushfile makefile isfile@ tfile ! tvoc-link off tnext-link off $100 tdp ! $100 displace ! ; \ Ghost-creating ks 07 dez 87 0 | Constant 0 | Constant | Create gname $21 allot | : >heap ( from quan -- ) \ heap over - 1 and + \ align dup hallot heap swap cmove ; : symbolic ( string -- cfa.ghost ) count dup 1 $1F uwithin not Abort" invalid Gname" gname place BL gname append align here >r makeview , state @ IF context ELSE current THEN @ @ dup @ , gname count under here place 1+ allot align here r@ - , 0 , 0 , r@ here over - >heap heap 2+ rot ! r> dp ! heap + ; \ ghost words ks 07 dez 87 : gfind ( string -- cfa tf / string ff ) >r 1 r@ c+! r@ find -1 r> c+! ; : ghost ( -- cfa ) name gfind ?exit symbolic ; : gdoes> ( cfa.ghost -- cfa.does ) 4 + dup @ IF @ exit THEN here , 0 , dup 4 >heap dp ! heap swap ! heap ; \ ghost utilities ks 29 jun 87 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; : '. g' dup @ case? IF ." forw" ELSE - Abort" ??" ." res" THEN 2+ dup @ 5 u.r 2+ @ ?dup IF dup @ case? IF ." fdef" ELSE - Abort" ??" ." rdef" THEN 2+ @ 5 u.r THEN ; ' ' Alias h' \ .unresolved ks 29 jun 87 | : forward? ( cfa -- cfa / exit&true ) dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; | : unresolved? ( addr -- f ) 2+ dup count $1F and + 1- c@ bl = IF name> forward? 4+ @ dup IF forward? THEN THEN drop false ; | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation ks 29 jun 87 Vocabulary Ttools Vocabulary Defining : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; Vocabulary Transient tvoc off Root definitions : T Transient ; immediate : H Forth ; immediate : D Defining ; immediate Forth definitions \ Image and byteorder ks 02 jul 87 | Code >byte ( 16b -- 8b- 8b+ ) A A xor D- A- xchg D+ D- xchg A push Next end-code | Code byte> ( 8b- 8b+ -- 16b ) A pop D- D+ mov A- D- xchg Next end-code | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; Transient definitions : c@ ( addr -- 8b ) [ Dos ] >target file@ dup 0< Abort" nie abgespeichert" ; : c! ( 8b addr -- ) [ Dos ] >target file! ; \ Transient primitives ks 09 jul 87 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; : cmove ( from.mem to.target quan -- ) [ Dos ] >r >target fseek ds@ swap r> tfile @ lfputs ; \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; : here ( -- taddr ) H tdp @ ; : here! ( taddr -- ) H tdp ! ; : allot ( n -- ) H tdp +! ; : c, ( 8b -- ) T here c! 1 allot H ; : , ( 16b -- ) T here ! 2 allot H ; : align ( -- ) H ; immediate : even ( addr1 -- addr2 ) H ; immediate : halign H ; immediate \ Transient primitives ks 29 jun 87 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; : ," H here ," here over dp ! over - T here swap dup allot cmove H ; : fill ( addr quan 8b -- ) H -rot bounds ?DO dup I T c! H LOOP drop ; : erase ( addr quan -- ) H 0 T fill H ; : blank ( addr quan -- ) H bl T fill H ; : move-threads H tvoc @ tvoc-link @ BEGIN over ?dup WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT Error" some undef. Target-Vocs left" drop ; \ Resolving ks 29 jun 87 Forth definitions : resolve ( cfa.ghost cfa.target -- ) over dup @ = IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN >r >r 2+ @ ?dup IF BEGIN dup T @ H 2dup = Abort" resolve loop" r@ rot T ! H ?dup 0= UNTIL THEN r> r> over ! 2+ ! ; : resdoes> ( acf.ghost acf.target -- ) swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! here 2+ 0 ] Does> @ T , H ; ' >body ! \ compiling names into targ. ks 10 okt 87 | : tlatest ( -- addr ) current @ 6 + ; : (theader ?thead @ IF 1 ?thead +! exit THEN >in @ bl word swap >in ! dup count upper dup c@ 1 $20 uwithin not Abort" inval. Tname" blk @ $8400 or T align , H there tlatest @ T , H tlatest ! there tlast ! there over c@ 1+ dup T allot cmove align H ; : theader tlast off (theader ghost dup glast' ! there resolve ; \ prebuild defining words ks 29 jun 87 | : (prebuild >in @ Create >in ! r> dup 2+ >r @ here 2- ! ; | : tpfa, there , ; : prebuild ( addr check# -- check# ) 0 ?pairs dup IF compile (prebuild dup , THEN compile theader ghost gdoes> , IF compile tpfa, THEN 0 ; immediate : dummy 0 ; : DO> [compile] Does> here 3 - compile @ 0 ] ; \ Constructing defining words in Host kks 07 dez 87 | : defcomp ( string -- ) dup ['] Defining search ?dup IF 0> IF nip execute exit THEN drop dup THEN find ?dup IF 0< IF nip , exit THEN THEN drop ['] Forth search ?dup IF 0< IF , exit THEN execute exit THEN number? ?dup 0= Abort" ?" 0> IF swap [compile] Literal THEN [compile] Literal ; | : definter ( string -- ) dup ['] Defining search ?dup IF 0< IF nip execute exit THEN THEN drop find ?dup IF 1 and 0= Abort" compile only" execute exit THEN number? 0= Error" ?" ; \ Constructing defining words in Host ks 22 dez 87 | : (;tcode r> @ tlast @ T count + ! H ; Defining definitions : ] H ] ['] defcomp Is parser ; : [ H [compile] [ ['] definter Is parser ; immediate : ; H [compile] ; [compile] \\ ; immediate : Does> H compile (;tcode tdoes> @ , [compile] ; -2 allot [compile] \\ ; immediate D ' Does> Alias ;Code immediate H \ reinterpreting defining words ks 22 dez 87 Forth definitions : ?reinterpret ( f -- ) 0=exit state @ >r >in @ >r adr parser @ >r >in: @ >in ! : D ] H interpret r> Is parser r> >in ! r> state ! ; : undefined? ( -- f ) glast' @ 4+ @ 0= ; | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN dup T c@ rot or swap c! H ; | : nfa? ( acf alf -- anf / acf ff ) BEGIN dup WHILE 2dup 2+ T count $1F and + even H = IF 2+ nip exit THEN T @ H REPEAT ; \ the 8086 Assembler ks 29 jun 87 | Create relocate ] T c, , here ! c! H [ Transient definitions : Assembler H [ Assembler ] relocate >codes ! Assembler ; : >label ( 16b -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Constant ; : Label T here >label Assembler H ; : Code H theader T here 2+ , Assembler H ; ( Transient primitives ks 17 dec 83 ) ' exit Alias exit ' load Alias load ' / Alias / ' thru Alias thru ' swap Alias swap ' * Alias * ' dup Alias dup ' drop Alias drop ' /mod Alias /mod ' rot Alias rot ' -rot Alias -rot ' over Alias over ' 2* Alias 2* ' + Alias + ' - Alias - ' 1+ Alias 1+ ' 2+ Alias 2+ ' 1- Alias 1- ' 2- Alias 2- ' negate Alias negate ' 2swap Alias 2swap ' 2dup Alias 2dup \ Transient primitives kks 29 jun 87 ' also Alias also ' words Alias words ' definitions Alias definitions ' hex Alias hex ' decimal Alias decimal ' ( Alias ( immediate ' \ Alias \ immediate ' \\ Alias \\ immediate ' .( Alias .( immediate ' [ Alias [ immediate ' cr Alias cr ' end-code Alias end-code ' Transient Alias Transient ' +thru Alias +thru ' +load Alias +load ' .s Alias .s Tools ' trace Alias trace immediate \ immediate words and branch primitives ks 29 jun 87 : >mark ( -- addr ) T here 0 , H ; : >resolve ( addr -- ) T here over - swap ! H ; : name ks 29 jun 87 : ' ( -- acf ) H g' dup @ - IF Error" undefined" THEN 2+ @ ; : compile H ghost , ; immediate restrict : >name ( acf -- anf / ff ) H tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; \ >name Alias ks 29 jun 87 : >body ( acf -- apf ) H 2+ ; : Alias ( n -- ) H tlast off (theader ghost over resolve T , H $20 flag! ; : on ( addr -- ) H true swap T ! H ; : off ( addr -- ) H false swap T ! H ; \ Target tools ks 9 sep 86 Onlyforth | : .tfield ( taddr len quan -) >r under Pad swap bounds ?DO dup T c@ I H c! 1+ LOOP drop Pad over type r> swap - 0 max spaces ; ' view Alias hview Ttools also definitions | : ?: ( addr -- addr ) dup 4 u.r ." :" ; | : @? ( addr -- addr ) dup T @ H 6 u.r ; | : c? ( addr -- addr ) dup T c@ H 3 .r ; \ Ttools for decompiling ks 9 sep 86 : s ( addr -- addr+ ) ?: space c? 4 spaces T count 2dup + even -rot 18 .tfield ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H ?dup IF T count H ELSE 0 0 THEN $1F and $18 .tfield 2+ ; : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; : c ( addr -- addr+1 ) 1 d 15 spaces ; \ Tools for decompiling ks 29 jun 87 : b ( addr -- addr+2 ) ?: @? dup T @ H over + 6 u.r 2+ 14 spaces ; : dump ( addr n -- ) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; \ Predefinitions loadscreen ks 29 jun 87 Onlyforth : clear H true Abort" There are ghosts" ; 1 $B +thru \ Literal ['] ?" ." " ks 29 jun 87 Transient definitions Forth : Literal ( n -- ) H dup $FF00 and IF T compile lit , H exit THEN T compile clit c, H ; immediate : Ascii H bl word 1+ c@ state @ 0=exit T [compile] Literal H ; immediate : ['] T compile lit H ; immediate : ." T compile (." ," align H ; immediate : " T compile (" ," align H ; immediate \ Target compilation ] ks 07 dez 87 Forth definitions | : tcompile ( string -- ) dup find ?dup IF 0> IF nip execute exit THEN THEN drop gfind IF execute exit THEN number? ?dup IF 0> IF swap T [compile] Literal THEN [compile] Literal H exit THEN symbolic execute ; Transient definitions : ] H ] ['] tcompile Is parser ; \ Target conditionals ks 10 sep 86 : IF T compile ?branch >mark H 1 ; immediate restrict : THEN abs 1 ?pairs T >resolve H ; immediate restrict : ELSE 1 ?pairs T compile branch >mark swap >resolve H -1 ; immediate restrict : BEGIN T mark H -2 2swap ; immediate restrict | : (repeat 2 ?pairs T resolve H REPEAT ; : UNTIL T compile ?branch (repeat H ; immediate restrict : REPEAT T compile branch (repeat H ; immediate restrict \ Target conditionals Abort" etc. ks 09 feb 88 : DO T compile (do >mark H 3 ; immediate restrict : ?DO T compile (?do >mark H 3 ; immediate restrict : LOOP 3 ?pairs T compile (loop compile endloop >resolve H ; immediate restrict : +LOOP 3 ?pairs T compile (+loop compile endloop >resolve H ; immediate restrict : Abort" T compile (abort" ," align H ; immediate restrict : Error" T compile (error" ," align H ; immediate restrict \ Target does> ;code ks 29 jun 87 | : dodoes> T compile (;code H glast' @ there resdoes> there tdoes> ! ; : Does> H undefined? T dodoes> $E9 c, H tdodo @ there - 2- T , H ?reinterpret ; immediate restrict : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret T [compile] [ Assembler H ; immediate restrict \ User ks 09 jul 87 Forth definitions Variable torigin torigin off \ cold boot vector Variable tudp tudp off \ user variable counter : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; Transient definitions Forth : origin! ( taddr -- ) H torigin ! tudp off ; : uallot ( n -- offset ) H tudp @ swap tudp +! ; DO> >user ; : User T prebuild User 2 uallot c, H ; \ Variable Constant Create ks 01 okt 87 DO> ; : Variable T prebuild Create 2 allot H ; DO> T @ H ; : Constant T prebuild Constant , H ; DO> ; : Create T prebuild Create H ; : Create: T Create ] H end-code 0 ; \ Defer Is Vocabulary ks 29 jun 87 DO> ; : Defer T prebuild Defer 2 allot ; : Is T ' >body H state @ IF T compile (is , H exit THEN T ! H ; immediate dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , H there tvoc-link @ T , H tvoc-link ! ; \ File ks 19 m„r 88 Forth definitions Variable tfile-link tfile-link off Variable tfileno tfileno off &45 Constant tb/fcb Transient definitions Forth dummy : File T prebuild File here tb/fcb 0 fill here H tfile-link @ T , H tfile-link ! 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , here dup >r 1+ tb/fcb &13 - allot H tlast @ T count dup r> c! H bounds ?DO I T c@ over c! H 1+ LOOP drop ; \ : ; compile Host [compile] ks 29 jun 87 dummy : : H >in @ >in: ! T prebuild : ] H end-code 0 ; : ; 0 ?pairs T compile unnest [compile] [ H ; immediate restrict : compile T compile compile H ; immediate restrict : Host H Onlyforth ; : Compiler H Onlyforth Transient also definitions ; : [compile] H ghost execute ; immediate restrict \ Target ks 29 jun 87 Onlyforth : Target H vp off Transient also definitions ; Transient definitions ghost c, drop \ No newline at end of file + \ Target compiler loadscr ks cas 09jun20 Onlyforth \needs Assembler 2 loadfrom asm.fb : c+! ( 8b addr -- ) dup c@ rot + swap c! ; ' find $22 + @ Alias found : search ( string 'vocab -- acf n / string ff ) dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" >body (find IF found exit THEN false ; 3 &27 thru Onlyforth savesystem meta.com cr .( Metacompiler saved as META.COM ) \ Predefinitions loadscreen ks 30 apr 88 &28 load cr .( Predefinitions geladen ...) cr \ Target header pointers ks 29 jun 87 Variable tfile tfile off \ handle of target file Variable tdp tdp off \ target dp Variable displace displace off \ diplacement of code Variable ?thead ?thead off \ for headerless code Variable tlast tlast off \ last name in target Variable glast' glast' off \ acf of latest ghost Variable tdoes> tdoes> off \ code addr of last does Variable tdodo tdodo off \ location of dodo Variable >in: >in: off \ last :-def Variable tvoc tvoc off \ Variable tvoc-link tvoc-link off \ voc-link in target Variable tnext-link tnext-link off \ link for tracer \ Target header pointers ks 10 okt 87 : there ( -- taddr ) tdp @ ; : new pushfile makefile isfile@ tfile ! tvoc-link off tnext-link off $100 tdp ! $100 displace ! ; \ Ghost-creating ks 07 dez 87 0 | Constant 0 | Constant | Create gname $21 allot | : >heap ( from quan -- ) \ heap over - 1 and + \ align dup hallot heap swap cmove ; : symbolic ( string -- cfa.ghost ) count dup 1 $1F uwithin not Abort" invalid Gname" gname place BL gname append align here >r makeview , state @ IF context ELSE current THEN @ @ dup @ , gname count under here place 1+ allot align here r@ - , 0 , 0 , r@ here over - >heap heap 2+ rot ! r> dp ! heap + ; \ ghost words ks 07 dez 87 : gfind ( string -- cfa tf / string ff ) >r 1 r@ c+! r@ find -1 r> c+! ; : ghost ( -- cfa ) name gfind ?exit symbolic ; : gdoes> ( cfa.ghost -- cfa.does ) 4 + dup @ IF @ exit THEN here , 0 , dup 4 >heap dp ! heap swap ! heap ; \ ghost utilities ks 29 jun 87 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; : '. g' dup @ case? IF ." forw" ELSE - Abort" ??" ." res" THEN 2+ dup @ 5 u.r 2+ @ ?dup IF dup @ case? IF ." fdef" ELSE - Abort" ??" ." rdef" THEN 2+ @ 5 u.r THEN ; ' ' Alias h' \ .unresolved ks 29 jun 87 | : forward? ( cfa -- cfa / exit&true ) dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; | : unresolved? ( addr -- f ) 2+ dup count $1F and + 1- c@ bl = IF name> forward? 4+ @ dup IF forward? THEN THEN drop false ; | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation ks 29 jun 87 Vocabulary Ttools Vocabulary Defining : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; Vocabulary Transient tvoc off Root definitions : T Transient ; immediate : H Forth ; immediate : D Defining ; immediate Forth definitions \ Image and byteorder ks 02 jul 87 | Code >byte ( 16b -- 8b- 8b+ ) A A xor D- A- xchg D+ D- xchg A push Next end-code | Code byte> ( 8b- 8b+ -- 16b ) A pop D- D+ mov A- D- xchg Next end-code | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; Transient definitions : c@ ( addr -- 8b ) [ Dos ] >target file@ dup 0< Abort" nie abgespeichert" ; : c! ( 8b addr -- ) [ Dos ] >target file! ; \ Transient primitives ks 09 jul 87 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; : cmove ( from.mem to.target quan -- ) [ Dos ] >r >target fseek ds@ swap r> tfile @ lfputs ; \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; : here ( -- taddr ) H tdp @ ; : here! ( taddr -- ) H tdp ! ; : allot ( n -- ) H tdp +! ; : c, ( 8b -- ) T here c! 1 allot H ; : , ( 16b -- ) T here ! 2 allot H ; : align ( -- ) H ; immediate : even ( addr1 -- addr2 ) H ; immediate : halign H ; immediate \ Transient primitives ks 29 jun 87 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; : ," H here ," here over dp ! over - T here swap dup allot cmove H ; : fill ( addr quan 8b -- ) H -rot bounds ?DO dup I T c! H LOOP drop ; : erase ( addr quan -- ) H 0 T fill H ; : blank ( addr quan -- ) H bl T fill H ; : move-threads H tvoc @ tvoc-link @ BEGIN over ?dup WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT Error" some undef. Target-Vocs left" drop ; \ Resolving ks 29 jun 87 Forth definitions : resolve ( cfa.ghost cfa.target -- ) over dup @ = IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN >r >r 2+ @ ?dup IF BEGIN dup T @ H 2dup = Abort" resolve loop" r@ rot T ! H ?dup 0= UNTIL THEN r> r> over ! 2+ ! ; : resdoes> ( acf.ghost acf.target -- ) swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! here 2+ 0 ] Does> @ T , H ; ' >body ! \ compiling names into targ. ks 10 okt 87 | : tlatest ( -- addr ) current @ 6 + ; : (theader ?thead @ IF 1 ?thead +! exit THEN >in @ bl word swap >in ! dup count upper dup c@ 1 $20 uwithin not Abort" inval. Tname" blk @ $8400 or T align , H there tlatest @ T , H tlatest ! there tlast ! there over c@ 1+ dup T allot cmove align H ; : theader tlast off (theader ghost dup glast' ! there resolve ; \ prebuild defining words ks 29 jun 87 | : (prebuild >in @ Create >in ! r> dup 2+ >r @ here 2- ! ; | : tpfa, there , ; : prebuild ( addr check# -- check# ) 0 ?pairs dup IF compile (prebuild dup , THEN compile theader ghost gdoes> , IF compile tpfa, THEN 0 ; immediate : dummy 0 ; : DO> [compile] Does> here 3 - compile @ 0 ] ; \ Constructing defining words in Host kks 07 dez 87 | : defcomp ( string -- ) dup ['] Defining search ?dup IF 0> IF nip execute exit THEN drop dup THEN find ?dup IF 0< IF nip , exit THEN THEN drop ['] Forth search ?dup IF 0< IF , exit THEN execute exit THEN number? ?dup 0= Abort" ?" 0> IF swap [compile] Literal THEN [compile] Literal ; | : definter ( string -- ) dup ['] Defining search ?dup IF 0< IF nip execute exit THEN THEN drop find ?dup IF 1 and 0= Abort" compile only" execute exit THEN number? 0= Error" ?" ; \ Constructing defining words in Host ks 22 dez 87 | : (;tcode r> @ tlast @ T count + ! H ; Defining definitions : ] H ] ['] defcomp Is parser ; : [ H [compile] [ ['] definter Is parser ; immediate : ; H [compile] ; [compile] \\ ; immediate : Does> H compile (;tcode tdoes> @ , [compile] ; -2 allot [compile] \\ ; immediate D ' Does> Alias ;Code immediate H \ reinterpreting defining words ks 22 dez 87 Forth definitions : ?reinterpret ( f -- ) 0=exit state @ >r >in @ >r adr parser @ >r >in: @ >in ! : D ] H interpret r> Is parser r> >in ! r> state ! ; : undefined? ( -- f ) glast' @ 4+ @ 0= ; | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN dup T c@ rot or swap c! H ; | : nfa? ( acf alf -- anf / acf ff ) BEGIN dup WHILE 2dup 2+ T count $1F and + even H = IF 2+ nip exit THEN T @ H REPEAT ; \ the 8086 Assembler ks 29 jun 87 | Create relocate ] T c, , here ! c! H [ Transient definitions : Assembler H [ Assembler ] relocate >codes ! Assembler ; : >label ( 16b -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Constant ; : Label T here >label Assembler H ; : Code H theader T here 2+ , Assembler H ; \ Transient primitives ks 1phz 05m„r22 ' exit Alias exit ' load Alias load ' / Alias / ' thru Alias thru ' swap Alias swap ' * Alias * ' dup Alias dup ' drop Alias drop ' /mod Alias /mod ' rot Alias rot ' -rot Alias -rot ' over Alias over ' 2* Alias 2* ' + Alias + ' - Alias - ' 1+ Alias 1+ ' 2+ Alias 2+ ' 1- Alias 1- ' 2- Alias 2- ' negate Alias negate ' 2swap Alias 2swap ' 2dup Alias 2dup ' include Alias include \ Transient primitives kks 29 jun 87 ' also Alias also ' words Alias words ' definitions Alias definitions ' hex Alias hex ' decimal Alias decimal ' ( Alias ( immediate ' \ Alias \ immediate ' \\ Alias \\ immediate ' .( Alias .( immediate ' [ Alias [ immediate ' cr Alias cr ' end-code Alias end-code ' Transient Alias Transient ' +thru Alias +thru ' +load Alias +load ' .s Alias .s Tools ' trace Alias trace immediate \ immediate words and branch primitives ks 29 jun 87 : >mark ( -- addr ) T here 0 , H ; : >resolve ( addr -- ) T here over - swap ! H ; : name ks 29 jun 87 : ' ( -- acf ) H g' dup @ - IF Error" undefined" THEN 2+ @ ; : compile H ghost , ; immediate restrict : >name ( acf -- anf / ff ) H tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; \ >name Alias ks 29 jun 87 : >body ( acf -- apf ) H 2+ ; : Alias ( n -- ) H tlast off (theader ghost over resolve T , H $20 flag! ; : on ( addr -- ) H true swap T ! H ; : off ( addr -- ) H false swap T ! H ; \ Target tools ks 9 sep 86 Onlyforth | : .tfield ( taddr len quan -) >r under Pad swap bounds ?DO dup T c@ I H c! 1+ LOOP drop Pad over type r> swap - 0 max spaces ; ' view Alias hview Ttools also definitions | : ?: ( addr -- addr ) dup 4 u.r ." :" ; | : @? ( addr -- addr ) dup T @ H 6 u.r ; | : c? ( addr -- addr ) dup T c@ H 3 .r ; \ Ttools for decompiling ks 9 sep 86 : s ( addr -- addr+ ) ?: space c? 4 spaces T count 2dup + even -rot 18 .tfield ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H ?dup IF T count H ELSE 0 0 THEN $1F and $18 .tfield 2+ ; : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; : c ( addr -- addr+1 ) 1 d 15 spaces ; \ Tools for decompiling ks 29 jun 87 : b ( addr -- addr+2 ) ?: @? dup T @ H over + 6 u.r 2+ 14 spaces ; : dump ( addr n -- ) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; \ Predefinitions loadscreen ks 29 jun 87 Onlyforth : clear H true Abort" There are ghosts" ; 1 $B +thru \ Literal ['] ?" ." " ks 29 jun 87 Transient definitions Forth : Literal ( n -- ) H dup $FF00 and IF T compile lit , H exit THEN T compile clit c, H ; immediate : Ascii H bl word 1+ c@ state @ 0=exit T [compile] Literal H ; immediate : ['] T compile lit H ; immediate : ." T compile (." ," align H ; immediate : " T compile (" ," align H ; immediate \ Target compilation ] ks 07 dez 87 Forth definitions | : tcompile ( string -- ) dup find ?dup IF 0> IF nip execute exit THEN THEN drop gfind IF execute exit THEN number? ?dup IF 0> IF swap T [compile] Literal THEN [compile] Literal H exit THEN symbolic execute ; Transient definitions : ] H ] ['] tcompile Is parser ; \ Target conditionals ks 10 sep 86 : IF T compile ?branch >mark H 1 ; immediate restrict : THEN abs 1 ?pairs T >resolve H ; immediate restrict : ELSE 1 ?pairs T compile branch >mark swap >resolve H -1 ; immediate restrict : BEGIN T mark H -2 2swap ; immediate restrict | : (repeat 2 ?pairs T resolve H REPEAT ; : UNTIL T compile ?branch (repeat H ; immediate restrict : REPEAT T compile branch (repeat H ; immediate restrict \ Target conditionals Abort" etc. ks 09 feb 88 : DO T compile (do >mark H 3 ; immediate restrict : ?DO T compile (?do >mark H 3 ; immediate restrict : LOOP 3 ?pairs T compile (loop compile endloop >resolve H ; immediate restrict : +LOOP 3 ?pairs T compile (+loop compile endloop >resolve H ; immediate restrict : Abort" T compile (abort" ," align H ; immediate restrict : Error" T compile (error" ," align H ; immediate restrict \ Target does> ;code ks 29 jun 87 | : dodoes> T compile (;code H glast' @ there resdoes> there tdoes> ! ; : Does> H undefined? T dodoes> $E9 c, H tdodo @ there - 2- T , H ?reinterpret ; immediate restrict : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret T [compile] [ Assembler H ; immediate restrict \ User ks 09 jul 87 Forth definitions Variable torigin torigin off \ cold boot vector Variable tudp tudp off \ user variable counter : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; Transient definitions Forth : origin! ( taddr -- ) H torigin ! tudp off ; : uallot ( n -- offset ) H tudp @ swap tudp +! ; DO> >user ; : User T prebuild User 2 uallot c, H ; \ Variable Constant Create ks 01 okt 87 DO> ; : Variable T prebuild Create 2 allot H ; DO> T @ H ; : Constant T prebuild Constant , H ; DO> ; : Create T prebuild Create H ; : Create: T Create ] H end-code 0 ; \ Defer Is Vocabulary ks 29 jun 87 DO> ; : Defer T prebuild Defer 2 allot ; : Is T ' >body H state @ IF T compile (is , H exit THEN T ! H ; immediate dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , H there tvoc-link @ T , H tvoc-link ! ; \ File ks 19 m„r 88 Forth definitions Variable tfile-link tfile-link off Variable tfileno tfileno off &45 Constant tb/fcb Transient definitions Forth dummy : File T prebuild File here tb/fcb 0 fill here H tfile-link @ T , H tfile-link ! 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , here dup >r 1+ tb/fcb &13 - allot H tlast @ T count dup r> c! H bounds ?DO I T c@ over c! H 1+ LOOP drop ; \ : ; compile Host [compile] ks 29 jun 87 dummy : : H >in @ >in: ! T prebuild : ] H end-code 0 ; : ; 0 ?pairs T compile unnest [compile] [ H ; immediate restrict : compile T compile compile H ; immediate restrict : Host H Onlyforth ; : Compiler H Onlyforth Transient also definitions ; : [compile] H ghost execute ; immediate restrict \ Target ks 29 jun 87 Onlyforth : Target H vp off Transient also definitions ; Transient definitions ghost c, drop \ No newline at end of file diff --git a/8086/msdos/src/meta.fth b/8086/msdos/src/meta.fth new file mode 100644 index 0000000..305cf07 --- /dev/null +++ b/8086/msdos/src/meta.fth @@ -0,0 +1,1007 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Target compiler loadscr ks cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + 3 &27 thru Onlyforth savesystem meta.com + +cr .( Metacompiler saved as META.COM ) + + + +\ *** Block No. 2, Hexblock 2 + +\ Predefinitions loadscreen ks 30 apr 88 + + &28 load + +cr .( Predefinitions geladen ...) cr + + + + + + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ Target header pointers ks 29 jun 87 + + Variable tfile tfile off \ handle of target file + Variable tdp tdp off \ target dp + Variable displace displace off \ diplacement of code + Variable ?thead ?thead off \ for headerless code + Variable tlast tlast off \ last name in target + Variable glast' glast' off \ acf of latest ghost + Variable tdoes> tdoes> off \ code addr of last does + Variable tdodo tdodo off \ location of dodo + Variable >in: >in: off \ last :-def + Variable tvoc tvoc off \ + Variable tvoc-link tvoc-link off \ voc-link in target + Variable tnext-link tnext-link off \ link for tracer + + + +\ *** Block No. 4, Hexblock 4 + +\ Target header pointers ks 10 okt 87 + + : there ( -- taddr ) tdp @ ; + + : new pushfile makefile isfile@ tfile ! + tvoc-link off tnext-link off + $100 tdp ! $100 displace ! ; + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ Ghost-creating ks 07 dez 87 + +0 | Constant 0 | Constant + +| Create gname $21 allot + +| : >heap ( from quan -- ) \ heap over - 1 and + \ align + dup hallot heap swap cmove ; + + : symbolic ( string -- cfa.ghost ) + count dup 1 $1F uwithin not Abort" invalid Gname" + gname place BL gname append align here >r makeview , + state @ IF context ELSE current THEN @ @ dup @ , + gname count under here place 1+ allot align + here r@ - , 0 , 0 , r@ here over - >heap + heap 2+ rot ! r> dp ! heap + ; + +\ *** Block No. 6, Hexblock 6 + +\ ghost words ks 07 dez 87 + + : gfind ( string -- cfa tf / string ff ) + >r 1 r@ c+! r@ find -1 r> c+! ; + + : ghost ( -- cfa ) name gfind ?exit symbolic ; + + : gdoes> ( cfa.ghost -- cfa.does ) + 4 + dup @ IF @ exit THEN + here , 0 , dup 4 >heap + dp ! heap swap ! heap ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ ghost utilities ks 29 jun 87 + + : g' ( -- acf ) name gfind 0= Abort" ?T?" ; + + : '. g' dup @ case? + IF ." forw" ELSE - Abort" ??" ." res" THEN + 2+ dup @ 5 u.r 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - Abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + + ' ' Alias h' + + + + + +\ *** Block No. 8, Hexblock 8 + +\ .unresolved ks 29 jun 87 + +| : forward? ( cfa -- cfa / exit&true ) + dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; + +| : unresolved? ( addr -- f ) 2+ + dup count $1F and + 1- c@ bl = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words ( thread -- ) + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + + : .unresolved voc-link @ + BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; + +\ *** Block No. 9, Hexblock 9 + +\ Extending Vocabularys for Target-Compilation ks 29 jun 87 + + Vocabulary Ttools + Vocabulary Defining + + : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + + Vocabulary Transient tvoc off + + Root definitions + + : T Transient ; immediate + : H Forth ; immediate + : D Defining ; immediate + + Forth definitions + +\ *** Block No. 10, Hexblock a + +\ Image and byteorder ks 02 jul 87 + +| Code >byte ( 16b -- 8b- 8b+ ) A A xor + D- A- xchg D+ D- xchg A push Next end-code + +| Code byte> ( 8b- 8b+ -- 16b ) + A pop D- D+ mov A- D- xchg Next end-code + +| : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; + + Transient definitions + + : c@ ( addr -- 8b ) [ Dos ] + >target file@ dup 0< Abort" nie abgespeichert" ; + + : c! ( 8b addr -- ) [ Dos ] >target file! ; + +\ *** Block No. 11, Hexblock b + +\ Transient primitives ks 09 jul 87 + : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; + : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; + + : cmove ( from.mem to.target quan -- ) [ Dos ] + >r >target fseek ds@ swap r> tfile @ lfputs ; +\ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; + + : here ( -- taddr ) H tdp @ ; + : here! ( taddr -- ) H tdp ! ; + : allot ( n -- ) H tdp +! ; + : c, ( 8b -- ) T here c! 1 allot H ; + : , ( 16b -- ) T here ! 2 allot H ; + : align ( -- ) H ; immediate + : even ( addr1 -- addr2 ) H ; immediate + : halign H ; immediate + +\ *** Block No. 12, Hexblock c + +\ Transient primitives ks 29 jun 87 + + : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; + + : ," H here ," here over dp ! + over - T here swap dup allot cmove H ; + + : fill ( addr quan 8b -- ) H + -rot bounds ?DO dup I T c! H LOOP drop ; + : erase ( addr quan -- ) H 0 T fill H ; + : blank ( addr quan -- ) H bl T fill H ; + + : move-threads H tvoc @ tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + Error" some undef. Target-Vocs left" drop ; + +\ *** Block No. 13, Hexblock d + +\ Resolving ks 29 jun 87 + Forth definitions + + : resolve ( cfa.ghost cfa.target -- ) over dup @ = + IF space dup >name .name ." exists " ?cr + 2+ ! drop exit THEN >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = Abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + + : resdoes> ( acf.ghost acf.target -- ) swap gdoes> + dup @ = IF 2+ ! exit THEN swap resolve ; + +here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! +here 2+ 0 ] Does> @ T , H ; ' >body ! + + +\ *** Block No. 14, Hexblock e + +\ compiling names into targ. ks 10 okt 87 + +| : tlatest ( -- addr ) current @ 6 + ; + + : (theader ?thead @ IF 1 ?thead +! exit THEN + >in @ bl word swap >in ! dup count upper + dup c@ 1 $20 uwithin not Abort" inval. Tname" + blk @ $8400 or T align , H + there tlatest @ T , H tlatest ! there tlast ! + there over c@ 1+ dup T allot cmove align H ; + + : theader tlast off + (theader ghost dup glast' ! there resolve ; + + + + +\ *** Block No. 15, Hexblock f + +\ prebuild defining words ks 29 jun 87 + +| : (prebuild >in @ Create >in ! + r> dup 2+ >r @ here 2- ! ; + +| : tpfa, there , ; + + : prebuild ( addr check# -- check# ) 0 ?pairs + dup IF compile (prebuild dup , THEN + compile theader ghost gdoes> , + IF compile tpfa, THEN 0 ; immediate + + : dummy 0 ; + + : DO> [compile] Does> here 3 - compile @ 0 ] ; + + +\ *** Block No. 16, Hexblock 10 + +\ Constructing defining words in Host kks 07 dez 87 + +| : defcomp ( string -- ) dup ['] Defining search ?dup + IF 0> IF nip execute exit THEN drop dup THEN + find ?dup IF 0< IF nip , exit THEN THEN + drop ['] Forth search ?dup + IF 0< IF , exit THEN execute exit THEN + number? ?dup 0= Abort" ?" + 0> IF swap [compile] Literal THEN [compile] Literal ; + +| : definter ( string -- ) dup ['] Defining search ?dup + IF 0< IF nip execute exit THEN THEN drop + find ?dup IF 1 and 0= Abort" compile only" execute exit + THEN number? 0= Error" ?" ; + + + +\ *** Block No. 17, Hexblock 11 + +\ Constructing defining words in Host ks 22 dez 87 + +| : (;tcode r> @ tlast @ T count + ! H ; + +Defining definitions + + : ] H ] ['] defcomp Is parser ; + + : [ H [compile] [ ['] definter Is parser ; immediate + + : ; H [compile] ; [compile] \\ ; immediate + + : Does> H compile (;tcode tdoes> @ , + [compile] ; -2 allot [compile] \\ ; immediate +D ' Does> Alias ;Code immediate H + + +\ *** Block No. 18, Hexblock 12 + +\ reinterpreting defining words ks 22 dez 87 + Forth definitions + + : ?reinterpret ( f -- ) 0=exit + state @ >r >in @ >r adr parser @ >r + >in: @ >in ! : D ] H interpret + r> Is parser r> >in ! r> state ! ; + + : undefined? ( -- f ) glast' @ 4+ @ 0= ; + +| : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN + dup T c@ rot or swap c! H ; + +| : nfa? ( acf alf -- anf / acf ff ) + BEGIN dup WHILE 2dup 2+ T count $1F and + even H = + IF 2+ nip exit THEN T @ H REPEAT ; + +\ *** Block No. 19, Hexblock 13 + +\ the 8086 Assembler ks 29 jun 87 + +| Create relocate ] T c, , here ! c! H [ + +Transient definitions + + : Assembler H [ Assembler ] relocate >codes ! Assembler ; + + : >label ( 16b -- ) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; + + : Label T here >label Assembler H ; + + : Code H theader T here 2+ , Assembler H ; + + + +\ *** Block No. 20, Hexblock 14 + +\ Transient primitives ks 1phz 05mär22 + +' exit Alias exit ' load Alias load +' / Alias / ' thru Alias thru +' swap Alias swap ' * Alias * +' dup Alias dup ' drop Alias drop +' /mod Alias /mod ' rot Alias rot +' -rot Alias -rot ' over Alias over +' 2* Alias 2* ' + Alias + +' - Alias - ' 1+ Alias 1+ +' 2+ Alias 2+ ' 1- Alias 1- +' 2- Alias 2- ' negate Alias negate +' 2swap Alias 2swap ' 2dup Alias 2dup + +' include Alias include + + +\ *** Block No. 21, Hexblock 15 + +\ Transient primitives kks 29 jun 87 + + ' also Alias also ' words Alias words +' definitions Alias definitions ' hex Alias hex +' decimal Alias decimal ' ( Alias ( immediate + ' \ Alias \ immediate ' \\ Alias \\ immediate + ' .( Alias .( immediate ' [ Alias [ immediate + ' cr Alias cr +' end-code Alias end-code ' Transient Alias Transient + ' +thru Alias +thru ' +load Alias +load + ' .s Alias .s + +Tools ' trace Alias trace immediate + + + + +\ *** Block No. 22, Hexblock 16 + +\ immediate words and branch primitives ks 29 jun 87 + + : >mark ( -- addr ) T here 0 , H ; + : >resolve ( addr -- ) T here over - swap ! H ; + : name ks 29 jun 87 + + : ' ( -- acf ) H g' dup @ - + IF Error" undefined" THEN 2+ @ ; + + : compile H ghost , ; immediate restrict + + : >name ( acf -- anf / ff ) H tvoc + BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN + swap REPEAT nip ; + + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ >name Alias ks 29 jun 87 + + : >body ( acf -- apf ) H 2+ ; + + : Alias ( n -- ) H tlast off + (theader ghost over resolve T , H $20 flag! ; + + : on ( addr -- ) H true swap T ! H ; + : off ( addr -- ) H false swap T ! H ; + + + + + + + + +\ *** Block No. 25, Hexblock 19 + +\ Target tools ks 9 sep 86 + Onlyforth + +| : .tfield ( taddr len quan -) >r under Pad swap + bounds ?DO dup T c@ I H c! 1+ LOOP drop + Pad over type r> swap - 0 max spaces ; + + ' view Alias hview + + Ttools also definitions + +| : ?: ( addr -- addr ) dup 4 u.r ." :" ; +| : @? ( addr -- addr ) dup T @ H 6 u.r ; +| : c? ( addr -- addr ) dup T c@ H 3 .r ; + + + +\ *** Block No. 26, Hexblock 1a + +\ Ttools for decompiling ks 9 sep 86 + + : s ( addr -- addr+ ) ?: space c? 4 spaces + T count 2dup + even -rot 18 .tfield ; + + : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H + ?dup IF T count H ELSE 0 0 THEN + $1F and $18 .tfield 2+ ; + + : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; + + : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; + + : c ( addr -- addr+1 ) 1 d 15 spaces ; + + +\ *** Block No. 27, Hexblock 1b + +\ Tools for decompiling ks 29 jun 87 + + : b ( addr -- addr+2 ) ?: @? dup T @ H + over + 6 u.r 2+ 14 spaces ; + + : dump ( addr n -- ) + bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; + + : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; + + + + + + + + +\ *** Block No. 28, Hexblock 1c + +\ Predefinitions loadscreen ks 29 jun 87 + Onlyforth + + : clear H true Abort" There are ghosts" ; + + + 1 $B +thru + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + +\ Literal ['] ?" ." " ks 29 jun 87 + Transient definitions Forth + + : Literal ( n -- ) H dup $FF00 and + IF T compile lit , H exit THEN T compile clit c, H ; + immediate + + : Ascii H bl word 1+ c@ state @ 0=exit + T [compile] Literal H ; immediate + + : ['] T compile lit H ; immediate + : ." T compile (." ," align H ; immediate + : " T compile (" ," align H ; immediate + + + + +\ *** Block No. 30, Hexblock 1e + +\ Target compilation ] ks 07 dez 87 + Forth definitions + +| : tcompile ( string -- ) dup find ?dup + IF 0> IF nip execute exit THEN THEN + drop gfind IF execute exit THEN number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + symbolic execute ; + + Transient definitions + + : ] H ] ['] tcompile Is parser ; + + + + +\ *** Block No. 31, Hexblock 1f + +\ Target conditionals ks 10 sep 86 + + : IF T compile ?branch >mark H 1 ; immediate restrict + : THEN abs 1 ?pairs T >resolve H ; immediate restrict + : ELSE 1 ?pairs T compile branch >mark + swap >resolve H -1 ; immediate restrict + + : BEGIN T mark H -2 2swap ; + immediate restrict + +| : (repeat 2 ?pairs T resolve H REPEAT ; + + : UNTIL T compile ?branch (repeat H ; immediate restrict + : REPEAT T compile branch (repeat H ; immediate restrict + +\ *** Block No. 32, Hexblock 20 + +\ Target conditionals Abort" etc. ks 09 feb 88 + + : DO T compile (do >mark H 3 ; immediate restrict + : ?DO T compile (?do >mark H 3 ; immediate restrict + : LOOP 3 ?pairs T compile (loop + compile endloop >resolve H ; immediate restrict + : +LOOP 3 ?pairs T compile (+loop + compile endloop >resolve H ; immediate restrict + + : Abort" T compile (abort" ," align H ; immediate restrict + : Error" T compile (error" ," align H ; immediate restrict + + + + + + +\ *** Block No. 33, Hexblock 21 + +\ Target does> ;code ks 29 jun 87 + +| : dodoes> T compile (;code + H glast' @ there resdoes> there tdoes> ! ; + + : Does> H undefined? T dodoes> + $E9 c, H tdodo @ there - 2- T , + H ?reinterpret ; immediate restrict + + : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret + T [compile] [ Assembler H ; immediate restrict + + + + + + +\ *** Block No. 34, Hexblock 22 + +\ User ks 09 jul 87 + Forth definitions + + Variable torigin torigin off \ cold boot vector + Variable tudp tudp off \ user variable counter + : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; + + Transient definitions Forth + + : origin! ( taddr -- ) H torigin ! tudp off ; + : uallot ( n -- offset ) H tudp @ swap tudp +! ; + + DO> >user ; + : User T prebuild User 2 uallot c, H ; + + + +\ *** Block No. 35, Hexblock 23 + +\ Variable Constant Create ks 01 okt 87 + + DO> ; + : Variable T prebuild Create 2 allot H ; + + DO> T @ H ; + : Constant T prebuild Constant , H ; + + DO> ; + : Create T prebuild Create H ; + + : Create: T Create ] H end-code 0 ; + + + + + +\ *** Block No. 36, Hexblock 24 + +\ Defer Is Vocabulary ks 29 jun 87 + + DO> ; + : Defer T prebuild Defer 2 allot ; + : Is T ' >body H state @ + IF T compile (is , H exit THEN T ! H ; immediate + + dummy + : Vocabulary H >in @ Vocabulary >in ! + T prebuild Vocabulary 0 , 0 , + H there tvoc-link @ T , H tvoc-link ! ; + + + + + + +\ *** Block No. 37, Hexblock 25 + +\ File ks 19 mär 88 + Forth definitions + + Variable tfile-link tfile-link off + Variable tfileno tfileno off + &45 Constant tb/fcb + + Transient definitions Forth + + dummy + : File T prebuild File here tb/fcb 0 fill + here H tfile-link @ T , H tfile-link ! + 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , + here dup >r 1+ tb/fcb &13 - allot H tlast @ + T count dup r> c! + H bounds ?DO I T c@ over c! H 1+ LOOP drop ; + +\ *** Block No. 38, Hexblock 26 + +\ : ; compile Host [compile] ks 29 jun 87 + + dummy + : : H >in @ >in: ! T prebuild : ] H end-code 0 ; + + : ; 0 ?pairs T compile unnest + [compile] [ H ; immediate restrict + + : compile T compile compile H ; immediate restrict + + : Host H Onlyforth ; + + : Compiler H Onlyforth Transient also definitions ; + + : [compile] H ghost execute ; immediate restrict + + +\ *** Block No. 39, Hexblock 27 + +\ Target ks 29 jun 87 + + Onlyforth + + : Target H vp off Transient also definitions ; + + Transient definitions + + ghost c, drop + + + + + + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + + +\ *** Block No. 42, Hexblock 2a + + + + + + + + + + + + + + + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + + +\ *** Block No. 44, Hexblock 2c + + + + + + + + + + + + + + + + + + +\ *** Block No. 45, Hexblock 2d + + + + + + + + + + + + + + + + + + +\ *** Block No. 46, Hexblock 2e + + + + + + + + + + + + + + + + + + +\ *** Block No. 47, Hexblock 2f + + + + + + + + + + + + + + + + + + +\ *** Block No. 48, Hexblock 30 + + + + + + + + + + + + + + + + + + +\ *** Block No. 49, Hexblock 31 + + + + + + + + + + + + + + + + + + +\ *** Block No. 50, Hexblock 32 + + + + + + + + + + + + + + + + + + +\ *** Block No. 51, Hexblock 33 + + + + + + + + + + + + + + + + + + +\ *** Block No. 52, Hexblock 34 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/minimal.sys b/8086/msdos/src/minimal.sys similarity index 100% rename from 8086/msdos/minimal.sys rename to 8086/msdos/src/minimal.sys diff --git a/8086/msdos/miniterm.fb b/8086/msdos/src/miniterm.fb similarity index 100% rename from 8086/msdos/miniterm.fb rename to 8086/msdos/src/miniterm.fb diff --git a/8086/msdos/src/miniterm.fth b/8086/msdos/src/miniterm.fth new file mode 100644 index 0000000..aa3eedf --- /dev/null +++ b/8086/msdos/src/miniterm.fth @@ -0,0 +1,380 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Terminalprogramm mit Blockinterface ( 08.03.91/KK ) + + Autor: Klaus Kohl, 30.01.89 aus FG-FORTH des RTX entnommen + + Beschreibung: + + Kleines Beispiel zur Implementation eines Fileinterfaces über + die serielle Schnittstelle (Achtung: immer 8 Datenbits) + + Die Schnittstellenbefehle stammen aus dem PC-volksFORTH 3.81 + von Klaus Schleisiek. Sie wurden weitgehend unverändert über- + nommen, sind aber auf 4KByte-Puffer erweitert. + File: SERIAL.SCR + + Umstellung des Ports durch Ausmaskierung der entsprechenden + Zeilen in Screen 2 (momentan COM1 aktiviert). + +\ *** Block No. 1, Hexblock 1 + +\ LOADSCREEN cas 28jun20 + +Onlyforth \ Suchreihenfolge: FORTH FORTH ONLY +\needs Assembler 2 loadfrom asm.fb \ Assembler nachladen + + FROM source.img ( File for SAVESYSTEM ) + + $20 >label I_ctrl \ 8259-Register + $21 >label I_mask \ 8259-Mask + + &02 &11 THRU ( SIO-Terminalroutines ) + &12 &17 THRU ( extended command words ) + &18 LOAD ( Terminalprogram ) + + + + +\ *** Block No. 2, Hexblock 2 + +\ Addresses and Constants cas 28jun20 + +| $C 4 * Constant SINT@ \ SIO-Interuptvector COM 1/3 +\ $B 4 * Constant SINT@ \ SIO-Interuptvector COM 2/4 +| $10 Constant I_level \ 8259-Interuptlevel COM 1/3 +\ $08 Constant I_level \ 8259-Interuptlevel COM 2/4 +( Port address) +| $3F8 >label Portadr \ Portaddress COM1: +\ $2F8 >label Portadr \ Portaddress COM2: +\ $3E8 >label Portadr \ Portaddress COM3: +\ $2E8 >label Portadr \ Portaddress COM4: +( Selection of Baud rate ) +\ &96 >label baud .( 1200 Baud ) +\ &48 >label baud .( 2400 Baud ) +| &12 >label baud .( 9600 Baud ) +\ &02 >label baud .( 57600 Baud ) + +\ *** Block No. 3, Hexblock 3 + +\ Queue and required commands cas 28jun20 + +( Dataqueue with 128 bytes and two pointer for IRQ service ) +( Queue+0: Number of saved characters ) +( Queue+1: offset to next char to be send ) + Create Queue 0 , 0 , $1000 allot + +\ send byte to port address ( b adr -- ) +\needs pc! Code pc! A pop D byte out D pop Next + +\ Read Byte from port address ( adr -- b ) +\needs pc@ Code pc@ D byte in A- D- mov D+ D+ xor Next + + + + + +\ *** Block No. 4, Hexblock 4 + +\ tx? = Request status for sending char cas 28jun20 + +( test if a char cn be send ) + Code tx? ( -- f ) \ f=-1, ready to send + D push \ TOS to datastack (TOS=Top Of Stack) + Portadr 5 + # D mov \ move status address into D reg + D in \ get port into register A + D D xor \ set D register to 0 + $1020 # A and \ mask % 0001 0000 0010 0000 + $1020 # A cmp \ tes if these bits are set + 0= ?[ D dec ]? \ char output permitted ? + Next \ compiling "Next" wurg macro + end-code + + + + +\ *** Block No. 5, Hexblock 5 + +\ (tx tx = transmit cas 28jun20 + +( unconditional send byte directly to 8250-Port ) + Code (tx ( char -- ) + D- A- xchg \ load char into AL-register + Portadr # D mov \ load port address in D-register + D byte out \ transmit AL + D pop \ load next stack value into D-register + Next \ compiling "Next" + end-code + +( wait until last char has been send ) + : tx ( char -- ) + BEGIN tx? UNTIL \ wait until SIO ready + (tx ; \ now write to port + + +\ *** Block No. 6, Hexblock 6 + +\ -DTR +DTR = Data Terminal Ready on/off cas 28jun20 +( DTR-Line to +12 V = logical zero ) + Code -DTR ( -- ) + D push \ save TOS + Portadr 4 + # D mov \ get Address of Port Controllregister + D byte in \ move content to AL register + $1C # A- and \ DTR and RTS to 0 = +12 V + D byte out \ write AL back into port register + D pop \ restore TOS + Next \ next FORTH words + end-code +( set DTR and RTS back to 1 = -12 V ) + Code +DTR ( -- ) + D push Portadr 4 + # D mov + D byte in 3 # A- or D byte out + D pop Next end-code + +\ *** Block No. 7, Hexblock 7 + +\ receive queue and interrupt service routine ( 21.02.89/KK ) + +| Label S_INT + D push I push A push + Queue # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + Portadr # D mov D byte in C: seg A- 4 I D) mov + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ rx? = request status for reading from Queue cas 28jun20 +| Code rx? ( -- f ) D push + Queue #) D mov Queue 2+ #) D XOR + Next end-code + +\\ Query if a char can be read from the queue + Code rx? ( -- f ) ( f<>0, if char ready ) + D push \ TOS to datastack + D D xor \ D-register to 0 + Queue #) D- mov \ get number if DL and + D- D- or \ test for 0 + 0= ?[ [[ D push \ if queue empty + Portadr 4 + # D mov \ activate S8 again + D byte in $B # A- or D byte out \ without changing + D pop \ D register +swap ]? Next end-code + +\ *** Block No. 9, Hexblock 9 + +\ (rx rx = receive char from queue cas 28jun20 + +( get char from queue, adjust pointer ) + Code (rx ( -- char ) + D push I push + Queue 2+ # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + C: seg 2 I D) A- mov 0 # A+ mov A D mov + I pop Next end-code + +( get char, wait for char available ) + : rx ( -- char ) + BEGIN rx? UNTIL (rx ; + + + + +\ *** Block No. 10, Hexblock a + +\ S_init = initialize serial interface cas 28jun20 +| Code S_init ( -- ) + D push D: push \ save TOS and DS register + A A xor A D: mov C: A mov \ 0 -> DS ; CS -> A + SINT@ # W mov S_INT # W ) mov \ set IRQ vector + A 2 W D) mov D: pop \ and restore DS register + Portadr 3 + # D mov + $80 # A- mov D byte out \ enable Baud-rate register + 2 # D sub baud # A mov A- A+ xchg D byte out \ set the + D dec A- A+ xchg D byte out \ BAUD rate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ enable RX IRQ + I_mask #) byte in + I_level Forth not Assembler # A- and \ activate 8259 + I_mask #) byte out + D pop Next end-code + +\ *** Block No. 11, Hexblock b + +\ init -init = Initialization / Reset cas 28jun20 + +\needs init | : init ; + +( clear queue pointer and initialize port and interrupt ) + : init ( -- ) + init Queue off Queue 2+ off S_init ; + +( block IRQ, disable RTS and DTR ) + : -init ( -- ) + 0 [ Portadr 1+ ] Literal pc! \ disable 8259 IRQ + 0 [ Portadr 4 + ] Literal pc! \ -RTS/-rts/-out2 + I_mask pc@ I_level or I_mask pc! ; \ block 8259 + + + + +\ *** Block No. 12, Hexblock c + +\ rxto rxwto = receive char with timeout cas 28jun20 + +| &1000 Constant Timeout \ exit after 1000 iterations + +( get a char ) +| : rxto ( -- char 0 | f ) ( f=-1 signals error ) + Timeout \ number iterations + BEGIN rx? IF drop (rx 0 exit THEN \ char available? + 1- DUP 0= \ Timeout ? + UNTIL DROP -1 ; + +( get a word, Highbyte first ) +| : rxwto ( -- n 0 | f ) + rxto ?dup ?exit \ exit when Timeout in 1st byte + &256 * rxto \ move to highbyte, get lowbyte + if drop -1 else OR 0 then ; \ Timeout -> error flag + +\ *** Block No. 13, Hexblock d + +\ info. blk>sio sio>blk = Forth Block I/O cas 28jun20 +: info. ." Block: " dup . cr ; +: blk>sio ( b -- f ) ( Block to target machine ) + dup capacity u< + if cr ." HOST -> TA -" info. block 0 tx + &1024 0 DO dup c@ tx 1+ LOOP drop + else drop 9 tx + then 0 ; +: sio>blk ( b -- f ) ( Block from Target ) + dup capacity u< + if cr ." TA -> HOST -" info. flush block 0 tx + &1024 0 do rxto if drop &1234 leave + else over c! 1+ then loop &1234 = + if empty-buffers -1 else update flush 0 then + else drop 9 tx 0 then ; + + +\ *** Block No. 14, Hexblock e + +\ Extension for img>file cas 28jun20 + +VARIABLE TSEG TSEG OFF ( Segment-Address of Target-RAM ) + +: TINIT ( len -- ) + 0 B/SEG UM/MOD SWAP IF 1+ THEN ( number of blocks ) + LALLOCATE ABORT" No RAM" ( reserve ) + TSEG ! ; ( save address ) +: TFREE ( -- ) ( release memory ) + TSEG @ LFREE ABORT" RAM allocated" ; + +: TC! ( c addr -- ) ( write byte ) + TSEG @ SWAP LC! ; +: R >R TSEG @ SWAP DS@ R> R> LMOVE ; + + +\ *** Block No. 15, Hexblock f + +\ Terminal part for SAVESYSTEM cas 28jun20 + +: img>file ( len -- f ) ( save image file ) + DUP TINIT DUP 0 0 tx + ?DO rxto ABORT" Savesystem-Error" I TC! LOOP + PUSHFILE SOURCE.IMG + CAPACITY 1- 0 DO I BLOCK &1024 -1 FILL UPDATE LOOP + 0 $400 UM/MOD DUP 0 + ?DO I $400 * I BLOCK $400 sio exit then \ Transmit + 2 case? if rxwto ?dup ?exit sio>blk exit then \ Receive + 3 case? if rxwto ?dup ?exit img>file exit then \ ROM + 4 case? if rxwto ?dup ?exit drop page 0 exit then \ PAGE + 5 case? if rxto ?dup ?exit rxto ?dup if nip exit then + swap at 0 exit then \ AT + $1B case? if $1B tx 0 exit then \ ESCAPE + drop -1 ; \ error unknown command + + + + +\ *** Block No. 17, Hexblock 11 + +\ ?rx = char from terminal cas 28jun20 + +( receive and interpret char ) +| : ?rx ( -- ) + pause rx? 0=exit (rx \ return if no char wainting + dup $20 u< \ is control char? + if + $1B case? if tbu abort" Command-Error" exit THEN \ ESCAPE + #LF case? IF cr exit THEN \ CRLF + #CR case? IF Row 0 at exit THEN \ only CR + #BS case? IF del exit THEN \ Backspace + drop \ better ignore these + else + Col &78 u> if cr then \ next line? + emit \ directly emit char + then ; + +\ *** Block No. 18, Hexblock 12 + +\ T - Main Terminal command cas 28jun20 + +( send char if possible ) +| : ?tx ( c -- ) + BEGIN ?rx tx? UNTIL \ receive unil SIO is free + tx ; \ then transmit +( Terminal Interpreter Loop ) +| : (T ( -- ) + BEGIN BEGIN ?rx key? UNTIL \ receive until key pressed + key $1B case? IF -DTR exit THEN ?tx \ exit on ESC + REPEAT ; +( Main program, en-/disables interrupt ) + : T ( -- ) + CR ." TA-Terminal (Exit with ESC)" CR + INIT (T -INIT + CR ." VolksForth " ; + +\ *** Block No. 19, Hexblock 13 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/src/mk-meta.fth b/8086/msdos/src/mk-meta.fth new file mode 100644 index 0000000..c052275 --- /dev/null +++ b/8086/msdos/src/mk-meta.fth @@ -0,0 +1,24 @@ + + include log2file.fth + logopen output.log + + Onlyforth \ \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + use meta.fb + 3 &27 thru Onlyforth + + logclose + savesystem metafile.com + logreopen + + cr .( Metacompiler saved as metafile.com) cr + + logclose diff --git a/8086/msdos/multi.vid b/8086/msdos/src/multi.vid similarity index 99% rename from 8086/msdos/multi.vid rename to 8086/msdos/src/multi.vid index 00988ce..827af07 100644 --- a/8086/msdos/multi.vid +++ b/8086/msdos/src/multi.vid @@ -1 +1 @@ - This display interface uses BIOS call $10 functions for a fast display interface. A couple of state variables is contained in a vector that is task specific such that different tasks may use different windows. For simplicity windows always span the whole width of the screen. They can be defined by top and bottom line. This mechanism is used for a convenient status display line on the bottom of the screen. \ Multitsking display interface loadscreen ks cas 10nov05 Onlyforth \needs Assembler 2 loadfrom asm.scr User area area off \ points at active window Variable status \ to switch status on/off | Variable cursor \ points at area with active cursor 1 8 +thru .( Multitasking display driver loaded ) cr \ Multitsking display interface ks 6 sep 86 : Area: Create 0 , 0 , 7 c, Does> area ! ; \ | col | row | top | bot | att | Area: terminal terminal area @ cursor ! : (area Create dup c, 1+ Does> c@ area @ + ; 0 | (area ccol | (area crow | (area ctop | (area cbot (area catt drop : window ( topline botline -- ) cbot c! ctop c! ; : full 0 c/col 2- window ; full \ Multitask (type (emit ks 20 dez 87 Code (type ( addr len -- ) W pop I push R push u' area U D) I mov U push D U mov $F # A+ mov $10 int u' catt I D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int I ) D mov 1 # C mov U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int D- inc ' c/row >body #) D- cmp 0= not ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop R pop I pop D pop ' pause #) jmp end-code : (emit ( char -- ) sp@ 1 (type drop ; \ Multitask (at (at? ks 04 aug 87 Code (at ( row col -- ) A pop A- D+ mov u' area U D) W mov D W ) mov cursor #) W cmp 0= ?[ R push U push $F # A+ mov $10 int 2 # A+ mov $10 int U pop R pop ]? D pop Next end-code Code (at? ( -- row col ) D push u' area U D) W mov W ) D mov D+ A- mov 0 # A+ mov A+ D+ mov A push Next end-code Code curat? ( -- row col ) D push R push $F # A+ mov $10 int 3 # A+ mov $10 int R pop 0 # A mov D+ A- xchg A push Next end-code \ cur! curshape setpage ks 28 jun 87 : cur! \ set cursor into current task's window area @ cursor ! (at? (at ; cur! Code curshape ( top bot -- ) D C mov D pop D- C+ mov 1 # A+ mov $10 int D pop Next end-code Code setpage ( n -- ) $503 # A mov D- A- and $10 int D pop Next end-code \ Multitask normal invers blankline ks 01 nov 88 : normal 7 catt c! ; : invers $70 catt c! ; : underline 1 catt c! ; : bright $F catt c! ; Code blankline D push R push U push $F # A+ mov $10 int u' area U D) W mov u' catt W D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int W ) D mov 2 # A+ mov $10 int ' c/row >body #) C mov D- C- sub bl # A- mov 9 # A+ mov C- C- or 0= not ?[ $10 int ]? D pop 2 # A+ mov $10 int \ set cursor back C pop 1 # A+ mov $10 int \ cursor visible again U pop R pop D pop ' pause #) jmp end-code | : lineerase ( line# -- ) 0 (at blankline ; \ Multitask (del scroll (cr (page ks 04 okt 87 : (del (at? ?dup IF 1- 2dup (at bl (emit (at exit THEN drop ; Code scroll D push R push U push u' area U D) W mov u' catt W D) R+ mov u' ctop W D) D mov D- C+ mov 0 # C- mov ' c/row >body #) D- mov D- dec $601 # A mov $10 int U pop R pop D pop Next end-code : (cr (at? drop 1+ dup cbot c@ u> IF scroll drop cbot c@ THEN lineerase ; : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; \ Multitask status display ks 10 okt 87 ' (emit ' display 2 + ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! : .base base @ decimal dup 2 .r base ! ; : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; : (.drv ( n -- ) Ascii A + emit ." : " ; : .dr ." " drv (.drv ; : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN @ 5 .r ; : .space ." Dic" s0 @ here $100 + - 6 u.r ; \ statuszeile ks ks 04 aug 87 | : fstat ( n -- ) .base .sp .space .scr .dr file? 2 spaces order ; | Area: statusline statusline c/col 1- dup window page invers terminal : (.status output @ display area @ statusline status @ IF (at? drop 0 (at 2 fstat blankline ELSE normal page invers THEN area ! output ! ; ' (.status Is .status : bye status off .status bye ; \ No newline at end of file + This display interface uses BIOS call $10 functions for a fast display interface. A couple of state variables is contained in a vector that is task specific such that different tasks may use different windows. For simplicity windows always span the whole width of the screen. They can be defined by top and bottom line. This mechanism is used for a convenient status display line on the bottom of the screen. \ Multitsking display interface loadscreen ks phz 31jan22 Onlyforth \needs Assembler 2 loadfrom asm.fb User area area off \ points at active window Variable status \ to switch status on/off | Variable cursor \ points at area with active cursor 1 8 +thru .( Multitasking display driver loaded ) cr \ Multitsking display interface ks 6 sep 86 : Area: Create 0 , 0 , 7 c, Does> area ! ; \ | col | row | top | bot | att | Area: terminal terminal area @ cursor ! : (area Create dup c, 1+ Does> c@ area @ + ; 0 | (area ccol | (area crow | (area ctop | (area cbot (area catt drop : window ( topline botline -- ) cbot c! ctop c! ; : full 0 c/col 2- window ; full \ Multitask (type (emit ks 20 dez 87 Code (type ( addr len -- ) W pop I push R push u' area U D) I mov U push D U mov $F # A+ mov $10 int u' catt I D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int I ) D mov 1 # C mov U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int D- inc ' c/row >body #) D- cmp 0= not ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop R pop I pop D pop ' pause #) jmp end-code : (emit ( char -- ) sp@ 1 (type drop ; \ Multitask (at (at? ks 04 aug 87 Code (at ( row col -- ) A pop A- D+ mov u' area U D) W mov D W ) mov cursor #) W cmp 0= ?[ R push U push $F # A+ mov $10 int 2 # A+ mov $10 int U pop R pop ]? D pop Next end-code Code (at? ( -- row col ) D push u' area U D) W mov W ) D mov D+ A- mov 0 # A+ mov A+ D+ mov A push Next end-code Code curat? ( -- row col ) D push R push $F # A+ mov $10 int 3 # A+ mov $10 int R pop 0 # A mov D+ A- xchg A push Next end-code \ cur! curshape setpage ks 28 jun 87 : cur! \ set cursor into current task's window area @ cursor ! (at? (at ; cur! Code curshape ( top bot -- ) D C mov D pop D- C+ mov 1 # A+ mov $10 int D pop Next end-code Code setpage ( n -- ) $503 # A mov D- A- and $10 int D pop Next end-code \ Multitask normal invers blankline ks 01 nov 88 : normal 7 catt c! ; : invers $70 catt c! ; : underline 1 catt c! ; : bright $F catt c! ; Code blankline D push R push U push $F # A+ mov $10 int u' area U D) W mov u' catt W D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int W ) D mov 2 # A+ mov $10 int ' c/row >body #) C mov D- C- sub bl # A- mov 9 # A+ mov C- C- or 0= not ?[ $10 int ]? D pop 2 # A+ mov $10 int \ set cursor back C pop 1 # A+ mov $10 int \ cursor visible again U pop R pop D pop ' pause #) jmp end-code | : lineerase ( line# -- ) 0 (at blankline ; \ Multitask (del scroll (cr (page ks 04 okt 87 : (del (at? ?dup IF 1- 2dup (at bl (emit (at exit THEN drop ; Code scroll D push R push U push u' area U D) W mov u' catt W D) R+ mov u' ctop W D) D mov D- C+ mov 0 # C- mov ' c/row >body #) D- mov D- dec $601 # A mov $10 int U pop R pop D pop Next end-code : (cr (at? drop 1+ dup cbot c@ u> IF scroll drop cbot c@ THEN lineerase ; : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; \ Multitask status display ks 10 okt 87 ' (emit ' display 2 + ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! : .base base @ decimal dup 2 .r base ! ; : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; : (.drv ( n -- ) Ascii A + emit ." : " ; : .dr ." " drv (.drv ; : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN @ 5 .r ; : .space ." Dic" s0 @ here $100 + - 6 u.r ; \ statuszeile ks ks 04 aug 87 | : fstat ( n -- ) .base .sp .space .scr .dr file? 2 spaces order ; | Area: statusline statusline c/col 1- dup window page invers terminal : (.status output @ display area @ statusline status @ IF (at? drop 0 (at 2 fstat blankline ELSE normal page invers THEN area ! output ! ; ' (.status Is .status : bye status off .status bye ; \ No newline at end of file diff --git a/8086/msdos/src/multivid.fth b/8086/msdos/src/multivid.fth new file mode 100644 index 0000000..6915ccd --- /dev/null +++ b/8086/msdos/src/multivid.fth @@ -0,0 +1,192 @@ + +\ *** Block No. 0, Hexblock 0 + +\ This file is a pure .fth-version of multi.vid. + +\ This display interface uses BIOS call $10 functions for a fast +\ display interface. A couple of state variables is contained +\ in a vector that is task specific such that different tasks +\ may use different windows. For simplicity windows always +\ span the whole width of the screen. They can be defined by +\ top and bottom line. This mechanism is used for a convenient +\ status display line on the bottom of the screen. + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Multitsking display interface loadscreen ks phz 31jan22 + Onlyforth \needs Assembler include t86asm.fth + + User area area off \ points at active window + Variable status \ to switch status on/off +| Variable cursor \ points at area with active cursor + +\ 1 8 +thru .( Multitasking display driver loaded ) cr + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ Multitsking display interface ks 6 sep 86 + + : Area: Create 0 , 0 , 7 c, Does> area ! ; +\ | col | row | top | bot | att | + +Area: terminal terminal area @ cursor ! + + : (area Create dup c, 1+ Does> c@ area @ + ; + +0 | (area ccol | (area crow | (area ctop + | (area cbot (area catt drop + + : window ( topline botline -- ) cbot c! ctop c! ; + + : full 0 c/col 2- window ; full + + +\ *** Block No. 3, Hexblock 3 + +\ Multitask (type (emit ks 20 dez 87 + + Code (type ( addr len -- ) W pop I push R push + u' area U D) I mov U push D U mov + $F # A+ mov $10 int u' catt I D) R- mov + 3 # A+ mov $10 int C push D push $E0E # C mov + 1 # A+ mov $10 int I ) D mov 1 # C mov + U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int + D- inc ' c/row >body #) D- cmp 0= not + ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? + D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? + 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop + R pop I pop D pop ' pause #) jmp end-code + + : (emit ( char -- ) sp@ 1 (type drop ; + + +\ *** Block No. 4, Hexblock 4 + +\ Multitask (at (at? ks 04 aug 87 + Code (at ( row col -- ) A pop A- D+ mov + u' area U D) W mov D W ) mov cursor #) W cmp 0= + ?[ R push U push $F # A+ mov $10 int + 2 # A+ mov $10 int U pop R pop + ]? D pop Next end-code + + Code (at? ( -- row col ) + D push u' area U D) W mov W ) D mov + D+ A- mov 0 # A+ mov A+ D+ mov A push Next + end-code + + Code curat? ( -- row col ) D push R push + $F # A+ mov $10 int 3 # A+ mov $10 int + R pop 0 # A mov D+ A- xchg A push Next + end-code + +\ *** Block No. 5, Hexblock 5 + +\ cur! curshape setpage ks 28 jun 87 + + : cur! \ set cursor into current task's window + area @ cursor ! (at? (at ; cur! + + Code curshape ( top bot -- ) D C mov D pop + D- C+ mov 1 # A+ mov $10 int D pop Next + end-code + + Code setpage ( n -- ) + $503 # A mov D- A- and $10 int D pop Next + end-code + + + + + +\ *** Block No. 6, Hexblock 6 + +\ Multitask normal invers blankline ks 01 nov 88 + : normal 7 catt c! ; : invers $70 catt c! ; + : underline 1 catt c! ; : bright $F catt c! ; + + Code blankline D push R push U push $F # A+ mov + $10 int u' area U D) W mov u' catt W D) R- mov + 3 # A+ mov $10 int C push D push + $E0E # C mov 1 # A+ mov $10 int W ) D mov + 2 # A+ mov $10 int ' c/row >body #) C mov + D- C- sub bl # A- mov 9 # A+ mov + C- C- or 0= not ?[ $10 int ]? + D pop 2 # A+ mov $10 int \ set cursor back + C pop 1 # A+ mov $10 int \ cursor visible again + U pop R pop D pop ' pause #) jmp end-code + +| : lineerase ( line# -- ) 0 (at blankline ; + +\ *** Block No. 7, Hexblock 7 + +\ Multitask (del scroll (cr (page ks 04 okt 87 + + : (del (at? ?dup + IF 1- 2dup (at bl (emit (at exit THEN drop ; + + Code scroll D push R push U push + u' area U D) W mov u' catt W D) R+ mov + u' ctop W D) D mov D- C+ mov 0 # C- mov + ' c/row >body #) D- mov D- dec $601 # A mov + $10 int U pop R pop D pop Next + end-code + + : (cr (at? drop 1+ dup cbot c@ u> + IF scroll drop cbot c@ THEN lineerase ; + + : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; + +\ *** Block No. 8, Hexblock 8 + +\ Multitask status display ks 10 okt 87 + + ' (emit ' display 2 + ! ' (cr ' display 4 + ! + ' (type ' display 6 + ! ' (del ' display 8 + ! + ' (page ' display &10 + ! + ' (at ' display &12 + ! ' (at? ' display &14 + ! + + : .base base @ decimal dup 2 .r base ! ; + : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; + : (.drv ( n -- ) Ascii A + emit ." : " ; + : .dr ." " drv (.drv ; + : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN + @ 5 .r ; + : .space ." Dic" s0 @ here $100 + - 6 u.r ; + + + +\ *** Block No. 9, Hexblock 9 + +\ statuszeile ks ks 04 aug 87 + +| : fstat ( n -- ) .base .sp + .space .scr .dr file? 2 spaces order ; + +| Area: statusline + statusline c/col 1- dup window page invers terminal + + : (.status output @ display area @ statusline + status @ IF (at? drop 0 (at 2 fstat blankline + ELSE normal page invers + THEN area ! output ! ; + ' (.status Is .status + + : bye status off .status bye ; + +.( Multitasking display driver loaded ) cr diff --git a/8086/msdos/nec8023.prn b/8086/msdos/src/nec8023.prn similarity index 100% rename from 8086/msdos/nec8023.prn rename to 8086/msdos/src/nec8023.prn diff --git a/8086/msdos/primed.fb b/8086/msdos/src/primed.fb similarity index 100% rename from 8086/msdos/primed.fb rename to 8086/msdos/src/primed.fb diff --git a/8086/msdos/src/primed.fth b/8086/msdos/src/primed.fth new file mode 100644 index 0000000..b800170 --- /dev/null +++ b/8086/msdos/src/primed.fth @@ -0,0 +1,133 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Simple Editor for Installation cas 10nov05 + +If the Full-Screen Editor cannot be used during installation +(incompatible display hardware), the screens must be altered +with this Simple Editor "PRIMED", which contains only one word +definition:: + +Usage: Select Screen nn with command "nn LIST", + and edit a screen with "ll NEW". It is only possible to + rewrite whole lines. ll is the first line where the editing + should start. The editing can be terminated by entering an + empty line (just RETURN). Each RETURN will store the editied + line and the whole screen will be reprinted. + + + + +\ *** Block No. 1, Hexblock 1 + +\ primitivst Editor PRIMED cas 10nov05 + Vocabulary Editor + +| : !line ( adr count line# -- ) + scr @ block swap c/l * + dup c/l bl fill + swap cmove update ; + +: new ( n -- ) + l/s 1+ swap + ?DO cr I . + pad c/l expect span @ 0= IF leave THEN + pad span @ I !line cr scr @ list LOOP ; + + ' scr | Alias scr' + + .( Simple Editor loaded ) cr + +\ *** Block No. 2, Hexblock 2 + +\ PRIMED Demo-Screen cas 10nov05 + + + +This text was created by: "2 LIST 4 NEW" and then entering +this text +The headerline (Line 0) was added later after leaving "NEW" +with an empty line (just RETURN) and a new editing command +"0 NEW". + Ulrich Hoffmann + + + + + + + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/see.fb b/8086/msdos/src/see.fb similarity index 100% rename from 8086/msdos/see.fb rename to 8086/msdos/src/see.fb diff --git a/8086/msdos/src/see.fth b/8086/msdos/src/see.fth new file mode 100644 index 0000000..1b03b68 --- /dev/null +++ b/8086/msdos/src/see.fth @@ -0,0 +1,2318 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Extended-Decompiler for VolksForth cas 10nov05 + +This file contains the volksFORTH decompiler. The decompiler +will convert FORTH code back to Sourcecode. +Conditional words like IF THEN ELSE, BEGIN WHILE REPEAT UNTIL +and DO LOOP +LOOP are identified and converted. + +The Decompiler cannot re-create comments, so please use +comments in screens and view. + + +Because: There is always one more bug! +And to correct bug, nothing beats good commented sourcecode. + + +Usage: SEE + +\ *** Block No. 1, Hexblock 1 + +\ Extended-Decompiler for VolksForth LOAD-SCREEN ks 22 dez 87 +Onlyforth Tools also definitions + +| : internal 1 ?head ! ; +| : external ?head off ; + +1 &18 +thru + +\\ +Produces compilable Forth source from normal compiled Forth. + + These source blocks are based on the works of + + Henry Laxen, Mike Perry and Wil Baden + + volksFORTH version: U. Hoffmann + +\ *** Block No. 2, Hexblock 2 + +\ detecting does> ks 22 dez 87 + +internal + +' Forth @ 1+ dup @ + 2+ Constant (dodoes> + +: does? ( IP - f ) + dup c@ $E9 ( jmp ) = + swap 1+ dup @ + 2+ (dodoes> = and ; + + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ indentation. 04Jul86 +Variable #spaces #spaces off + +: +in ( -- ) 3 #spaces +! ; + +: -in ( -- ) -3 #spaces +! ; + +: ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; + +: ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; + + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ case defining words 01Jul86 + +: Case: ( -- ) + Create: Does> swap 2* + perform ; + +: Associative: ( n -- ) + Constant Does> ( n - index ) + dup @ -rot dup @ 0 + DO 2+ 2dup @ = + IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ branching 04Jul86 + +Variable #branches Variable #branch + +: branch-type ( n -- a ) 6 * pad + ; +: branch-from ( n -- a ) branch-type 2+ ; +: branch-to ( n -- a ) branch-type 4+ ; + +: branched ( adr type -- ) \ Make entry in branch-table. + #branches @ branch-type ! dup #branches @ branch-from ! + 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; + +\\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } + + + + +\ *** Block No. 6, Hexblock 6 + +\ branching 01Jul86 + +: branch-back ( adr type -- ) + \ : make entry in branch-table & reclassify branch-type.) + over swap branched + 2+ dup dup @ + swap 2+ ( loop-start,-end.) + 0 #branches @ 1- + ?DO + over I branch-from @ u> IF LEAVE THEN + dup I branch-to @ = IF ['] while I branch-type ! THEN + -1 +LOOP 2drop ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ branching 01Jul86 +: forward? ( ip -- f ) 2+ @ 0> ; + +: ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] if branched exit THEN ['] until branch-back ; + +: branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] else branched exit THEN ['] repeat branch-back ; + +: (loop)+ ( ip -- ip' ) + dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; + +: string+ ( ip -- ip' ) 2+ count + even ; + +: (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; + + +\ *** Block No. 8, Hexblock 8 + +\ classify each word 25Aug86 +Forth + +&15 Associative: execution-class + ] clit lit ?branch branch + (do (." (abort" (;code + (" (?do (loop + (+loop unnest (is compile [ + +Case: execution-class+ + 3+ 4+ ?branch+ branch+ + 2+ string+ string+ (;code+ + string+ 2+ 4+ + 4+ 0= 4+ 4+ 2+ ; + +Tools + +\ *** Block No. 9, Hexblock 9 + +\ first pass ks 22 dez 87 + +: pass1 ( cfa -- ) #branches off >body + BEGIN dup @ execution-class execution-class+ + dup 0= stop? or + UNTIL drop ; + +: thru.branchtable ( -- limit start ) #branches @ 0 ; + + + + + + + + + +\ *** Block No. 10, Hexblock a + +\ identify branch destinations. ks 22 dez 87 +: ?.then ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< + IF I branch-type @ dup ['] else = swap ['] if = or + IF -in ." THEN " ind-cr LEAVE THEN THEN THEN + LOOP ; + +: ?.begin ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< not + IF I branch-type @ dup + ['] repeat = swap ['] until = or + IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN + LOOP ; +( put "BEGIN" and "THEN" where used.) + +\ *** Block No. 11, Hexblock b + +\ decompile each type of word 01Jul86 + +: .word ( ip -- ip' ) dup @ >name .name 2+ ; + +: .(word ( ip -- ip' ) dup @ >name + ?dup 0= IF ." ??? " ELSE + count $1f and swap 1+ swap 1- type space THEN 2+ ; +: .inline ( val16b -- ) + dup >name ?dup IF ." ['] " .name drop exit THEN . ; + +: .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; +: .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; +: .string ( ip -- ip' ) + .(word count 2dup type Ascii " emit space + even ?.then ; + +: .unnest ( ip -- 0 ) ." ; " 0= ; + +\ *** Block No. 12, Hexblock c + +\ decompile each type of word 01Jul86 + +: .default ( ip -- ip' ) dup @ >name ?dup IF + c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; + +: .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; + +: .compile ( ip -- ip' ) .word .word ?.then ; + + + + + + + + + +\ *** Block No. 13, Hexblock d + +\ decompiling conditionals 04Jul86 + +: .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; +: .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; +: .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; +: .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; +: .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; + +5 Associative: branch-class + ' if , ' while , ' else , ' repeat , ' until , +Case: .branch-class + .if .else .else .repeat .repeat ; + +: .branch ( ip -- ip' ) + #branch @ branch-type @ 1 #branch +! + dup >name swap branch-class .branch-class ; + +\ *** Block No. 14, Hexblock e + +\ decompile Does> ;code 04Jul86 + +: .(;code ( IP - IP' f) + 2+ dup does? + IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + +\ classify word's output 01Jul86 + +Case: .execution-class + .clit .lit .branch .branch + .do .string .string .(;code + .string .do .loop + .loop .unnest .['] .compile + .default ; + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ decompile colon-definitions 04Jul86 + +: pass2 ( cfa -- ) #branch off >body + BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class + dup 0= stop? or + UNTIL drop ; + +: .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; + +: .immediate ( cfa - ) >name c@ dup + ?ind-cr 40 and IF ." IMMEDIATE " THEN + ?ind-cr 80 and IF ." RESTRICT" THEN ; + +: .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; + + + +\ *** Block No. 17, Hexblock 11 + +\ display category of word 01Jul86 +external Defer (see internal + +: .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; + +: .user-variable ( cfa - ) ." USER " dup >name dup .name + 3 spaces swap execute @ u. .name ." ! " ; + +: .defer ( cfa - ) + ." deferred " dup >name .name ." Is " >body @ (see ; + +: .other ( cfa - ) dup >name .name + dup @ over >body = IF drop ." is Code " exit THEN + dup @ does? IF .does> exit THEN + drop ." is unknown " ; + + +\ *** Block No. 18, Hexblock 12 + +\ decompiling variables and constants ks 22 dez 87 + +: .constant ( cfa - ) + dup >body @ u. ." CONSTANT " >name .name ; + +: .variable ( cfa - ) ." VARIABLE " + dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; + +5 Associative: definition-class + ' quit @ , ' 0 @ , ' scr @ , ' base @ , + ' 'cold @ , + +Case: .definition-class + .: .constant .variable .user-variable + .defer .other ; + + +\ *** Block No. 19, Hexblock 13 + +\ Top level of Decompiler ks 20dez87 + +external + +: ((see ( cfa -) + #spaces off cr + dup dup @ + definition-class .definition-class .immediate ; + +' ((see Is (see + +Forth definitions + : see ' (see ; + + + + +\ *** Block No. 20, Hexblock 14 + + + + + + + + + + + + + + + + + + +\ *** Block No. 21, Hexblock 15 + + + + + + + + + + + + + + + + + + +\ *** Block No. 22, Hexblock 16 + + + + + + + + + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + + + + + + + + + + + + + + + + + + +\ *** Block No. 24, Hexblock 18 + + + + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 + + + + + + + + + + + + + + + + + + +\ *** Block No. 26, Hexblock 1a + + + + + + + + + + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + + + + + + + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c + + + + + + + + + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + + + + + + + + + + + + + + + + + + +\ *** Block No. 30, Hexblock 1e + + + + + + + + + + + + + + + + + + +\ *** Block No. 31, Hexblock 1f + + + + + + + + + + + + + + + + + + +\ *** Block No. 32, Hexblock 20 + + + + + + + + + + + + + + + + + + +\ *** Block No. 33, Hexblock 21 + + + + + + + + + + + + + + + + + + +\ *** Block No. 34, Hexblock 22 + + + + + + + + + + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + + + + + + + + + + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + + + + + + + + + + + + + + + + + + +\ *** Block No. 37, Hexblock 25 + + + + + + + + + + + + + + + + + + +\ *** Block No. 38, Hexblock 26 + + + + + + + + + + + + + + + + + + +\ *** Block No. 39, Hexblock 27 + + + + + + + + + + + + + + + + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + + +\ *** Block No. 42, Hexblock 2a + + + + + + + + + + + + + + + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + + +\ *** Block No. 44, Hexblock 2c + + + + + + + + + + + + + + + + + + +\ *** Block No. 45, Hexblock 2d + + + + + + + + + + + + + + + + + + +\ *** Block No. 46, Hexblock 2e + + + + + + + + + + + + + + + + + + +\ *** Block No. 47, Hexblock 2f + + + + + + + + + + + + + + + + + + +\ *** Block No. 48, Hexblock 30 + + + + + + + + + + + + + + + + + + +\ *** Block No. 49, Hexblock 31 + + + + + + + + + + + + + + + + + + +\ *** Block No. 50, Hexblock 32 + + + + + + + + + + + + + + + + + + +\ *** Block No. 51, Hexblock 33 + + + + + + + + + + + + + + + + + + +\ *** Block No. 52, Hexblock 34 + + + + + + + + + + + + + + + + + + +\ *** Block No. 53, Hexblock 35 + + + + + + + + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + + + + + + + + + + + + + + + + + + +\ *** Block No. 55, Hexblock 37 + + + + + + + + + + + + + + + + + + +\ *** Block No. 56, Hexblock 38 + + + + + + + + + + + + + + + + + + +\ *** Block No. 57, Hexblock 39 + + + + + + + + + + + + + + + + + + +\ *** Block No. 58, Hexblock 3a + + + + + + + + + + + + + + + + + + +\ *** Block No. 59, Hexblock 3b + + + + + + + + + + + + + + + + + + +\ *** Block No. 60, Hexblock 3c + + + + + + + + + + + + + + + + + + +\ *** Block No. 61, Hexblock 3d + + + + + + + + + + + + + + + + + + +\ *** Block No. 62, Hexblock 3e + + + + + + + + + + + + + + + + + + +\ *** Block No. 63, Hexblock 3f + + + + + + + + + + + + + + + + + + +\ *** Block No. 64, Hexblock 40 + + + + + + + + + + + + + + + + + + +\ *** Block No. 65, Hexblock 41 + + + + + + + + + + + + + + + + + + +\ *** Block No. 66, Hexblock 42 + + + + + + + + + + + + + + + + + + +\ *** Block No. 67, Hexblock 43 + + + + + + + + + + + + + + + + + + +\ *** Block No. 68, Hexblock 44 + + + + + + + + + + + + + + + + + + +\ *** Block No. 69, Hexblock 45 + + + + + + + + + + + + + + + + + + +\ *** Block No. 70, Hexblock 46 + + + + + + + + + + + + + + + + + + +\ *** Block No. 71, Hexblock 47 + + + + + + + + + + + + + + + + + + +\ *** Block No. 72, Hexblock 48 + + + + + + + + + + + + + + + + + + +\ *** Block No. 73, Hexblock 49 + + + + + + + + + + + + + + + + + + +\ *** Block No. 74, Hexblock 4a + + + + + + + + + + + + + + + + + + +\ *** Block No. 75, Hexblock 4b + + + + + + + + + + + + + + + + + + +\ *** Block No. 76, Hexblock 4c + + + + + + + + + + + + + + + + + + +\ *** Block No. 77, Hexblock 4d + + + + + + + + + + + + + + + + + + +\ *** Block No. 78, Hexblock 4e + + + + + + + + + + + + + + + + + + +\ *** Block No. 79, Hexblock 4f + + + + + + + + + + + + + + + + + + +\ *** Block No. 80, Hexblock 50 + + + + + + + + + + + + + + + + + + +\ *** Block No. 81, Hexblock 51 + + + + + + + + + + + + + + + + + + +\ *** Block No. 82, Hexblock 52 + + + + + + + + + + + + + + + + + + +\ *** Block No. 83, Hexblock 53 + + + + + + + + + + + + + + + + + + +\ *** Block No. 84, Hexblock 54 + + + + + + + + + + + + + + + + + + +\ *** Block No. 85, Hexblock 55 + + + + + + + + + + + + + + + + + + +\ *** Block No. 86, Hexblock 56 + + + + + + + + + + + + + + + + + + +\ *** Block No. 87, Hexblock 57 + + + + + + + + + + + + + + + + + + +\ *** Block No. 88, Hexblock 58 + + + + + + + + + + + + + + + + + + +\ *** Block No. 89, Hexblock 59 + + + + + + + + + + + + + + + + + + +\ *** Block No. 90, Hexblock 5a + + + + + + + + + + + + + + + + + + +\ *** Block No. 91, Hexblock 5b + + + + + + + + + + + + + + + + + + +\ *** Block No. 92, Hexblock 5c + + + + + + + + + + + + + + + + + + +\ *** Block No. 93, Hexblock 5d + + + + + + + + + + + + + + + + + + +\ *** Block No. 94, Hexblock 5e + + + + + + + + + + + + + + + + + + +\ *** Block No. 95, Hexblock 5f + + + + + + + + + + + + + + + + + + +\ *** Block No. 96, Hexblock 60 + + + + + + + + + + + + + + + + + + +\ *** Block No. 97, Hexblock 61 + + + + + + + + + + + + + + + + + + +\ *** Block No. 98, Hexblock 62 + + + + + + + + + + + + + + + + + + +\ *** Block No. 99, Hexblock 63 + + + + + + + + + + + + + + + + + + +\ *** Block No. 100, Hexblock 64 + + + + + + + + + + + + + + + + + + +\ *** Block No. 101, Hexblock 65 + + + + + + + + + + + + + + + + + + +\ *** Block No. 102, Hexblock 66 + + + + + + + + + + + + + + + + + + +\ *** Block No. 103, Hexblock 67 + + + + + + + + + + + + + + + + + + +\ *** Block No. 104, Hexblock 68 + + + + + + + + + + + + + + + + + + +\ *** Block No. 105, Hexblock 69 + + + + + + + + + + + + + + + + + + +\ *** Block No. 106, Hexblock 6a + + + + + + + + + + + + + + + + + + +\ *** Block No. 107, Hexblock 6b + + + + + + + + + + + + + + + + + + +\ *** Block No. 108, Hexblock 6c + + + + + + + + + + + + + + + + + + +\ *** Block No. 109, Hexblock 6d + + + + + + + + + + + + + + + + + + +\ *** Block No. 110, Hexblock 6e + + + + + + + + + + + + + + + + + + +\ *** Block No. 111, Hexblock 6f + + + + + + + + + + + + + + + + + + +\ *** Block No. 112, Hexblock 70 + + + + + + + + + + + + + + + + + + +\ *** Block No. 113, Hexblock 71 + + + + + + + + + + + + + + + + + + +\ *** Block No. 114, Hexblock 72 + + + + + + + + + + + + + + + + + + +\ *** Block No. 115, Hexblock 73 + + + + + + + + + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + + + + + + + + + + + + + + + + + + +\ *** Block No. 117, Hexblock 75 + + + + + + + + + + + + + + + + + + +\ *** Block No. 118, Hexblock 76 + + + + + + + + + + + + + + + + + + +\ *** Block No. 119, Hexblock 77 + + + + + + + + + + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + + + + + + + + + + + + + + + + + + +\ *** Block No. 121, Hexblock 79 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/serial.fb b/8086/msdos/src/serial.fb similarity index 100% rename from 8086/msdos/serial.fb rename to 8086/msdos/src/serial.fb diff --git a/8086/msdos/src/serial.fth b/8086/msdos/src/serial.fth new file mode 100644 index 0000000..0eabc3b --- /dev/null +++ b/8086/msdos/src/serial.fth @@ -0,0 +1,418 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Serial interface for IBM-PC using 8250 chip cas 11nov05 + + INCLUDE SERIAL.FB will load code for COM1, + 2 LOADFROM SERIAL.FB for COM2 + +Bytes recieved will be buffered in a 128 Byte deep Queue +by an interrupt Routine. + +The DTR Line will be used to signal that new bytes can be +recieved. +The Sender will recognize CTS, a full Handshake is implemented + +Xon/Xoff Protocoll using ^S/^Q is _not_ implemented. + +Sender: TX? ( -- f ) TX ( -- char ) +Empfänger: RX? ( -- f ) RX ( char -- ) + +\ *** Block No. 1, Hexblock 1 + +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM1: ) + +| $C 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $3F8 >label Portadr + +| $10 Constant I_level \ 8259 priority + + 2 7 +thru + + + + + +\ *** Block No. 2, Hexblock 2 + +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM2: ) + +| $B 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $2F8 >label Portadr + +| 8 Constant I_level \ 8259 priority + + 1 6 +thru + + + + + +\ *** Block No. 3, Hexblock 3 + +\ Driver for IBM-PC Serial card using 8250 ks 11 mai 88 +\ 3 .( 38.4 kbaud ) +\ &6 .( 19.2 kbaud ) + &12 .( 9.6 kbaud ) +\ &24 .( 4.8 kbaud ) +\ &96 .( 1200 baud ) + >label baud + + $20 >label I_ctrl $21 >label I_mask \ 8259 addresses + + Create Queue 0 , $80 allot +\ 0 1 2 130 byte address +\ | len | out |<-- 128 byte Queue -->| +\ len ::= number of characters queued +\ out ::= relativ address of next output character +\ (len+out)mod(128) ::= relative address of first empty byte + +\ *** Block No. 4, Hexblock 4 + +\ transmit to 8250 ks 11 dez 87 + + Code tx? ( -- f ) D push Portadr 5 + # D mov + D in D D xor $1020 # A and $1020 # A cmp + 0= ?[ D dec ]? Next end-code + + Code tx ( c -- ) D- A- xchg Portadr # D mov + D byte out D pop Next end-code + + Code -dtr D push Portadr 4 + # D mov + D byte in $1E # A- and D byte out D pop Next + end-code + + Code +dtr D push Portadr 4 + # D mov + D byte in 1 # A- or D byte out D pop Next + end-code + +\ *** Block No. 5, Hexblock 5 + +\ receive queue and interrupt service routine ks 11 dez 87 + + Label S_INT D push I push A push + Portadr # D mov D byte in A- D+ mov + Queue # I mov C: seg I ) A mov A- D- mov D- inc + C: seg D- I ) mov A+ A- add $7F # A and A I add + C: seg D+ 2 I D) mov $68 # D- cmp CS not + ?[ Portadr 4 + # D mov + D byte in $1E # A- and D byte out ]? \ -DTR + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + + +\ *** Block No. 6, Hexblock 6 + +\ rx? rx ks 30 dez 87 + + Code rx? ( -- f ) D push D D xor + Queue #) D- mov D- D- or 0= + ?[ [[ D push Portadr 4 + # D mov \ +DTR + D byte in 9 # A- or D byte out D pop +swap ]? Next end-code + + Code rx ( -- 8b ) I W mov Queue # I mov + D push D D xor cli lods A- A- or 0= not + ?[ A+ C- mov A- dec A+ inc $7F # A+ and + A -2 I D) mov D- C+ mov C I add I ) D- mov + ]? sti W I mov $18 # A- cmp CS not ?] Next + end-code + + + +\ *** Block No. 7, Hexblock 7 + +\ Serial initialization ks 25 apr 86 + +| Code S_init D push D: push A A xor A D: mov C: A mov + SINT@ # W mov S_INT # W ) mov A 2 W D) mov D: pop + Portadr 3 + # D mov $80 # A- mov D byte out \ DLAB = 1 + 2 # D sub baud # A mov A- A+ xchg D byte out + D dec A- A+ xchg D byte out \ baudrate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ +rxINT + I_mask #) byte in I_level Forth not Assembler # A- and + I_mask #) byte out D pop Next + end-code + + + + + +\ *** Block No. 8, Hexblock 8 + +\ init bye ks 11 dez 87 + \needs init : init ; + + : init init Queue off S_init ; init + + : bye 0 [ Portadr 1+ ] Literal pc! \ -rxINT + 0 [ Portadr 4 + ] Literal pc! \ -dtr/-rts/-out2 + I_mask pc@ I_level or I_mask pc! bye ; + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + +\ dumb terminal via 8250 ks 11 dez 87 + + Variable Fkeys Fkeys on + +| : ?rx ( -- ) pause rx? 0=exit rx + Fkeys @ 0= IF emit ?cr exit THEN + #LF case? IF cr exit THEN + #CR case? IF Row 0 at exit THEN + #BS case? IF del exit THEN emit ; + +| : ?tx ( c -- ) BEGIN ?rx tx? UNTIL tx ; + + : dumb BEGIN BEGIN ?rx key? UNTIL key + $1B case? IF -dtr exit THEN ?tx REPEAT ; + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + + + + + + + + + + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + + +\ *** Block No. 18, Hexblock 12 + + + + + + + + + + + + + + + + + + +\ *** Block No. 19, Hexblock 13 + + + + + + + + + + + + + + + + + + +\ *** Block No. 20, Hexblock 14 + + + + + + + + + + + + + + + + + + +\ *** Block No. 21, Hexblock 15 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/stream.fb b/8086/msdos/src/stream.fb similarity index 100% rename from 8086/msdos/stream.fb rename to 8086/msdos/src/stream.fb diff --git a/8086/msdos/src/stream.fth b/8086/msdos/src/stream.fth new file mode 100644 index 0000000..9b5e660 --- /dev/null +++ b/8086/msdos/src/stream.fth @@ -0,0 +1,209 @@ + +\ *** Block No. 0, Hexblock 0 + +\ cas 11nov05 +The word STREAM>BLK convert a sequiential file with CR lineend +into a screenfile with 64 Chars per line. + +Example: +FORTH.TXT is a Forth-Sourceode in a sequiential file + +MAKEFILE FORTH.FB will create an empty screenfile +FROM FORTH.TXT will define the inputfile +STREAM>BLK will convert FORTH.TXT into FORTH.FB + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ ks 06 jul 88 + Onlyforth Dos also + +| : in ( -- fcb ) fromfile @ ; +| : out ( -- fcb ) isfile @ ; + +| : padd ( cnt -- ) dup IF c/l mod ?dup 0=exit THEN + c/l swap ?DO BL out fputc LOOP ; + +| : skipctrl ( -- char ) + BEGIN in fgetc dup #cr = ?exit + dup 0 BL uwithin 0=exit drop REPEAT ; + + 2 3 thru + + Onlyforth + +\ *** Block No. 2, Hexblock 2 + +\ ks 06 jul 88 + +| : lastline? ( -- f ) false 0 skipctrl + BEGIN -1 case? IF ?dup IF padd THEN 0= exit THEN + #cr case? 0= WHILE out fputc 1+ in fgetc REPEAT + padd ; + + : stream>blk open out freset + out f.size 2@ out fseek \ append to end of file + BEGIN lastline? stop? or UNTIL close out fclose ; + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ absolute blocks in file eintragen ks 11 aug 87 + +| : >stream ( blk -- ) + fromfile @ (block b/blk bounds + DO ds@ I C/L -trailing out lfputs + #cr out fputc #lf out fputc C/L +LOOP ; + + : blk>stream ( from.blk to.blk -- ) emptyfile + 1+ swap DO I >stream LOOP close ; + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/system.cfg b/8086/msdos/src/system.cfg similarity index 100% rename from 8086/msdos/system.cfg rename to 8086/msdos/src/system.cfg diff --git a/8086/msdos/src/t86asm.fth b/8086/msdos/src/t86asm.fth new file mode 100644 index 0000000..f58411e --- /dev/null +++ b/8086/msdos/src/t86asm.fth @@ -0,0 +1,14 @@ + +\ *** Block No. 2, Hexblock 2 + +\ conditional Assembler compiler cas 10nov05 + here + + : maybe-include-tmp-asm ( addr -- ) hide last off dp ! + " ASSEMBLER" find nip ?exit here $1800 + sp@ u> + IF display cr ." Assembler won't fit" abort THEN + here sp@ $1800 - dp ! + include + dp ! ; + + maybe-include-tmp-asm 86asm.fth diff --git a/8086/msdos/tasker.fb b/8086/msdos/src/tasker.fb similarity index 100% rename from 8086/msdos/tasker.fb rename to 8086/msdos/src/tasker.fb diff --git a/8086/msdos/src/tasker.fth b/8086/msdos/src/tasker.fth new file mode 100644 index 0000000..1552944 --- /dev/null +++ b/8086/msdos/src/tasker.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 +The multitasker is a simple yet powerful round robin scheme +with explicit task switching. This has the major advantage +that the system switches tasks only in known states. +Hence the difficulties in synchronizing tasks and locking +critical portions of code are greatly minimized or simply +do not exist at all. + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Multitasker loadscreen ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + Code stop $E990 # U ) mov ' pause @ # jmp end-code + + : singletask [ ' noop @ ] Literal ['] pause ! ; + : multitask [ ' pause @ ] Literal ['] pause ! ; + + 1 3 +thru .( Multitasker geladen) cr + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ pass activate ks 1 jun 87 + + : pass ( n0 ... nr-1 Taddr r -- ) +BEGIN [ rot ] + swap $E9CD over ! \ awake Task + r> -rot \ Stack: IP r addr + 8 + >r \ s0 of Task + r@ 2+ @ swap \ Stack: IP r0 r + 2+ 2* \ bytes on Taskstack incl. r0 & IP + r@ @ over - \ new SP + dup r> 2- ! \ into Ssave + swap bounds ?DO I ! 2 +LOOP ; restrict + + : activate ( Taddr -- ) 0 \ [ ' pass >body ] Literal >r ; +[ -rot ] REPEAT ; restrict + + +\ *** Block No. 3, Hexblock 3 + +( Building a Task ks 8 may 84 ) + +| : taskerror ( string -- ) standardi/o singletask + ." Task error: " count type multitask stop ; + + : sleep ( addr -- ) $90 swap c! ; + + : wake ( addr -- ) $CD swap c! ; + + : rendezvous ( semaphoraddr -- ) + dup unlock pause lock ; + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ Task ks 1 jun 87 + + : Task ( rlen slen -- ) clear + 0 Constant here 2- >r \ addr of task constant + here -rot \ here for Task dp + even allot even \ allot dictionary area + here r> ! \ set task constant addr + up@ here $100 cmove \ init user area + here $E990 , \ JMP opcode + up@ 2+ dup dup @ + here - , + 2dup - 2- swap ! \ link task + 0 , dup 2- dup , , \ ssave and s0 + 2dup + , \ here + rlen = r0 + rot , \ dp + under + dp ! 0 , \ allot rstack + ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; diff --git a/8086/msdos/timer.fb b/8086/msdos/src/timer.fb similarity index 100% rename from 8086/msdos/timer.fb rename to 8086/msdos/src/timer.fb diff --git a/8086/msdos/src/timer.fth b/8086/msdos/src/timer.fth new file mode 100644 index 0000000..aa37c45 --- /dev/null +++ b/8086/msdos/src/timer.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 + +The timer utilizes the memory cell at $46C that is incremented +by an interrupt. A couple of words allow this timer to be +used for time delays. + +time-of-day and date are accessed via MS-DOS calls. + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ BIMomat BIOS Timer ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + $46C >label Counter + +\ 1193180 / 65536 = 18,206 Hz + + 1 2 +thru .( Timer geladen) cr + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ BIMomat BIOS Timer ks 22 dez 87 + + Code ticks ( -- n ) D push D: C mov A A xor + A D: mov Counter #) D mov C D: mov Next end-code + + : timeout? ( ticks -- ticks f ) pause dup ticks - 0< ; + + : till ( n -- ) BEGIN timeout? UNTIL drop ; + + : time ( n -- time ) ticks + ; + + : wait ( n -- ) time till ; + + : seconds ( sec -- ticks ) &18206 &1000 */ ; + + : minutes ( min -- ticks ) &1092 * ; + +\ *** Block No. 3, Hexblock 3 + +\ MS-DOS time and date ks 22 dez 87 + + Code date@ ( -- dd mm yy ) + D push $2A # A+ mov $21 int A A xor D+ A- xchg + D push A push C D mov &1900 # D sub Next + end-code + + Code time@ ( -- ss mm hh ) + D push $2C # A+ mov $21 int D+ D- mov 0 # D+ mov + D push D+ D- mov C+ D- xchg C push Next + end-code + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/tools.fb b/8086/msdos/src/tools.fb similarity index 100% rename from 8086/msdos/tools.fb rename to 8086/msdos/src/tools.fb diff --git a/8086/msdos/src/tools.fth b/8086/msdos/src/tools.fth new file mode 100644 index 0000000..668f89d --- /dev/null +++ b/8086/msdos/src/tools.fth @@ -0,0 +1,247 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 + +Some simple tools for debugging. +A state-of-the-art, interactive single step tracer +and a couple of tools for decompiling and dumping + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Programming-Tools word set cas 19july2020 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + Vocabulary Tools Tools also definitions + + 1 11 +thru Onlyforth .( Tools loaded ) cr + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ trace - next ks 11 jun 87 + +| Variable nest? nest? off + + Label tracenext 0 # nest? #) byte cmp 0= + ?[ $5555 # I cmp here 2- >label (ip >= + ?[ [[ swap lods A W xchg W ) jmp ]? + $5555 # I cmp here 2- >label ip) CS ?] + ][ 0 # nest? #) byte mov + ]? $5555 # W mov here 2- >label >tracing W ) jmp + end-code + +| (ip Constant + +| : (debug ( addr -- ) dup ! ; + +\ *** Block No. 3, Hexblock 3 + +\ install Tracer ks 11 jun 87 + + Label (do-trace next-link # W mov D push + $E9 # A- mov tracenext 1+ # C mov + [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C D mov W D sub + D -3 W D) mov ]]? D pop ret end-code + + Code do-trace (do-trace # call Next end-code + + ' end-trace Alias end-trace + +| Code (step (do-trace # call + R ) I mov R inc R inc lods A W xchg W ) jmp + +| Create: nextstep (step ; + +\ *** Block No. 4, Hexblock 4 + +\ tracer display ks 20 sep 88 + +| Variable nest# nest# off + +| Variable 'ip 'ip off + +| Create: -nest r> ip> ! r> r0 ! r> dup #tib ! + rp@ over tib swap cmove rp@ + rp! + r> Is parser r> adr 'quit ! r> >in ! + r> blk ! r> state ! r> output ! r> input ! ; + + +\ *** Block No. 5, Hexblock 5 + +\ tracer display ks 16 sep 88 + +| : tracing end-trace nest? @ + IF r> r ip> @ >r -nest >r >r + 1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip ! + nextstep >r input @ >r output @ >r state @ >r + blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r + tib #tib @ rp@ over - under rp! cmove #tib @ >r + r0 @ >r rp@ r0 ! standardi/o + cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r + 2 spaces >name .name &30 nest# @ + tab .s + $20 allot ['] oneline Is 'quit quit ; + ' tracing >tracing ! + + + + +\ *** Block No. 6, Hexblock 6 + +\ test traceability ks 07 dez 87 + +| : traceable ( cfa -- cfa' ) recursive dup @ + [ ' : @ ] Literal case? ?exit + [ ' key @ ] Literal case? IF >body c@ Input @ + + @ traceable exit THEN + [ ' type @ ] Literal case? IF >body c@ Output @ + + @ traceable exit THEN + [ ' r/w @ ] Literal case? IF >body @ traceable exit THEN + c@ $E9 = IF @ 1+ exit THEN \ Does> word + >name .name ." can't be DEBUGged" quit ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ user words for tracing ks 16 sep 88 +| : do_debug ( addr -- ) + traceable (debug nest? off nest# off do-trace ; + + : nest \ trace next high-level word executed + 'ip @ @ traceable drop nest? on ; + + : unnest \ ends tracing of actual word + off ; unnest \ clears trap range + + : endloop \ stop tracing loop + 'ip @ r do_debug r> execute end-trace unnest ; + +\ *** Block No. 8, Hexblock 8 + +\ tools for decompiling, interactive use ks 04 jul 87 + +| : ?: ( addr -- addr ) dup 5 u.r ." :" ; +| : @? ( addr -- addr ) dup @ 6 u.r ; +| : c? ( addr -- addr ) dup c@ 3 .r ; +| : end $28 tab ; + + : s ( addr1 -- addr2 ) + ?: 3 spaces c? 2 spaces count 2dup type + even end ; + : n ( addr1 -- addr2 ) + ?: @? 2 spaces dup @ >name .name 2+ end ; + : d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 2 spaces -rot type end ; + : l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ; + : c ( addr1 -- addr2 ) 1 d end ; + : b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ; + +\ *** Block No. 9, Hexblock 9 + +\ often times ks 29 jun 87 + Onlyforth + + : often stop? ?exit >in off ; + +| Variable #times #times off + + : times ( n -- ) ?dup + IF #times @ 2+ u< stop? or + IF #times off exit THEN 1 #times +! + ELSE stop? ?exit + THEN >in off ; + + + + + +\ *** Block No. 10, Hexblock a + +\ dump ks 04 jul 87 + + : dump ( addr n -- ) base push hex + bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop + stop? IF LEAVE THEN $10 +LOOP ; + +| : ld ( seg:addr -- ) + over 4 u.r ." :" dup 0 <# # # # # #> type + 3 spaces ds@ pad $10 lmove pad $10 bounds + DO I c@ 3 u.r LOOP 2 spaces pad $10 type ; + + : ldump ( seg:addr quan -- ) base push hex + 0 DO cr 2dup ld $10 + stop? IF LEAVE THEN + $10 +LOOP 2drop ; + + + +\ *** Block No. 11, Hexblock b + +\ N>R NR> cr + +: N>R ( i * n +n -- ) ( R: -- j * x +n ) +\ Transfer N items and count to the return stack. + DUP BEGIN DUP WHILE + ROT R> SWAP >R >R + 1- + REPEAT DROP R> SWAP >R >R ; + +: NR> ( -- i * x +n ) ( R: j * x +n -- ) +\ Pull N items and count off the return stack. + R> R> SWAP >R DUP + BEGIN DUP WHILE + R> R> SWAP >R -ROT + 1- + REPEAT DROP ; + +\ *** Block No. 12, Hexblock c + +\ ? +: ? ( a-addr -- ) +\ Display the value stored at a-addr. + @ . ; + + + + + + + + + + + + diff --git a/8086/msdos/src/v4th.fth b/8086/msdos/src/v4th.fth new file mode 100644 index 0000000..6f56c3c --- /dev/null +++ b/8086/msdos/src/v4th.fth @@ -0,0 +1,32 @@ + +\ with build log: +' noop alias \log +\ without build log: +\ ' \ alias \log + +\log logopen output.log + + \ : .blk|tib + \ blk @ ?dup IF ." Blk " u. ?cr exit THEN + \ incfile @ IF tib #tib @ cr type THEN ; + + \ ' .blk|tib Is .status + + Onlyforth + + 2 loadfrom META.fb + + new v4th.com Onlyforth Target definitions + + include vf86core.fth + include vf86dos.fth + include vf86file.fth + include vf86end.fth + +\log logclose + flush +\log logreopen + + cr .( new kernel written as v4th.com) cr + +\log logclose diff --git a/8086/msdos/src/v4thblk.fth b/8086/msdos/src/v4thblk.fth new file mode 100644 index 0000000..e0aa7a1 --- /dev/null +++ b/8086/msdos/src/v4thblk.fth @@ -0,0 +1,33 @@ + +\ with build log: +' noop alias \log +\ without build log: +\ ' \ alias \log + +\log logopen output.log + + \ : .blk|tib + \ blk @ ?dup IF ." Blk " u. ?cr exit THEN + \ incfile @ IF tib #tib @ cr type THEN ; + + \ ' .blk|tib Is .status + + Onlyforth + + 2 loadfrom META.fb + + new v4thblk.com Onlyforth Target definitions + + include vf86core.fth + include vf86dos.fth + include vf86file.fth + include vf86bufs.fth + include vf86end.fth + +\log logclose + flush +\log logreopen + + cr .( new kernel written as v4thblk.com) cr + +\log logclose diff --git a/8086/msdos/source.img b/8086/msdos/src/v4thfile.fb similarity index 90% rename from 8086/msdos/source.img rename to 8086/msdos/src/v4thfile.fb index 2a09adf..a5a81fc 100644 --- a/8086/msdos/source.img +++ b/8086/msdos/src/v4thfile.fb @@ -1 +1 @@ - \ No newline at end of file + \ loadscreen for creating v4thfile.com phz 10jan22 include include.fb savesystem v4thfile.com \ No newline at end of file diff --git a/8086/msdos/src/v4thfile.fth b/8086/msdos/src/v4thfile.fth new file mode 100644 index 0000000..6b578c4 --- /dev/null +++ b/8086/msdos/src/v4thfile.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for creating v4thfile.com phz 10jan22 + + include include.fb + + savesystem v4thfile.com + + + + + + + + + + + diff --git a/8086/msdos/src/vf86bufs.fth b/8086/msdos/src/vf86bufs.fth new file mode 100644 index 0000000..878e9aa --- /dev/null +++ b/8086/msdos/src/vf86bufs.fth @@ -0,0 +1,348 @@ + +\ *** Block No. 90, Hexblock 5a + +\ Struktur der Blockpuffer ks 04 jul 87 + +\ 0 : link zum naechsten Puffer +\ 2 : file 0 = direct access +\ -1 = leer, +\ sonst adresse eines file control blocks +\ 4 : blocknummer +\ 6 : statusflags Vorzeichenbit kennzeichnet update +\ 8 : Data ... 1 Kb ... + + + Forth definitions + + + + + + +\ *** Block No. 91, Hexblock 5b + +\ buffer mechanism ks 04 okt 87 + + Variable prev prev off \ Listhead of the buffers' list +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + + +\ *** Block No. 92, Hexblock 5c + +\ (core? ks 28 mai 87 + + Code (core? ( blk file -- dataaddr / blk file ) + A pop A push D D or 0= ?[ u' offset U D) A add ]? + prev #) W mov 2 W D) D cmp 0= + ?[ 4 W D) A cmp 0= + ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? + [[ [[ W ) C mov C C or 0= ?[ Next ]? + C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] + W ) A mov prev #) D mov D W ) mov W prev #) mov + 8 W D) D lea C W mov A W ) mov A pop + ' exit @ # jmp + end-code + + + + +\ *** Block No. 93, Hexblock 5d + +\ (core? ks 31 oct 86 + +\ | : this? ( blk file bufadr -- flag ) +\ dup 4+ @ swap 2+ @ d= ; + +\ .( (core?: offset is handled differently in code! ) + +\ | : (core? ( blk file -- dataaddr / blk file ) +\ BEGIN over offset @ + over prev @ this? +\ IF rdrop 2drop prev @ 8 + exit THEN +\ 2dup >r offset @ + >r prev @ +\ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN +\ dup r> r> 2dup >r >r rot this? 0= +\ WHILE nip REPEAT +\ dup @ rot ! prev @ over ! prev ! rdrop rdrop +\ REPEAT ; + +\ *** Block No. 94, Hexblock 5e + +\ backup emptybuf readblk ks 23 jul 87 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE 1 ?diskerror REPEAT + THEN 4+ dup @ $7FFF and over ! THEN + drop ; + + : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf >r + BEGIN 2dup 0= offset @ and + + over r@ 8 + -rot 1 r/w + WHILE 2 ?diskerror REPEAT r> ; + +\ *** Block No. 95, Hexblock 5f + +\ take mark updates? full? core? ks 04 jul 87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) 2+ >r + 2dup r@ ! over 0= offset @ and + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + + : core? ( blk file -- addr /false ) (core? 2drop false ; + + + +\ *** Block No. 96, Hexblock 60 + +\ block & buffer manipulation ks 01 okt 87 + + : (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + + : (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; + + : (blk-source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ ; + + ' (blk-source IS source + + +\ *** Block No. 97, Hexblock 61 + +\ block & buffer manipulation ks 02 okt 87 + + : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + + : (save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; + +' (save-buffers IS save-buffers + + : (empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + +' (empty-buffers IS empty-buffers + + + Dos definitions + +\ *** Block No. 137, Hexblock 89 + +\ /block *block ks 02 okt 87 + + Code /block ( d -- rest blk ) A D xchg C pop + C D mov A shr D rcr A shr D rcr D+ D- mov + A- D+ xchg $3FF # C and C push Next + end-code +\ : /block ( d -- rest blk ) b/blk um/mod ; + + Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg + A+ sal D rcl A+ sal D rcl A push Next + end-code +\ : *block ( blk -- d ) b/blk um* ; + + + + + +\ *** Block No. 138, Hexblock 8a + +\ fblock@ fblock! ks 19 mär 88 + Dos definitions + +| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; + +| : fblock ( addr blk fcb -- seg:addr quan fcb ) + fcb ! ?beyond dup *block fcb @ fseek ds@ -rot + fcb @ f.size 2@ /block rot - ?beyond + IF drop b/blk THEN fcb @ ; + + : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; + + : fblock! ( addr blk fcb -- ) fblock lfputs ; + + + + +\ *** Block No. 139, Hexblock 8b + +\ (r/w flush ks 18 mär 88 + Forth definitions + + : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over + IF IF fblock@ false exit THEN fblock! false exit + THEN >r drop /drive ?drive + r> IF block@ exit THEN block! ; + + ' (r/w Is r/w + + + Dos definitions + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +: (flush-file-buffers ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + +' (flush-file-buffers IS flush-file-buffers + + +\ *** Block No. 81, Hexblock 51 + + Forth definitions + +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : (load ( blk offset -- ) isfile@ >r + loadfile @ >r fromfile @ >r blk @ >r >in @ >r + >in ! blk ! isfile@ loadfile ! .status interpret + r> >in ! r> blk ! r> fromfile ! r> loadfile ! + r> isfile ! ; + + : load ( blk -- ) ?dup 0=exit 0 (load ; + ' load IS include-load + + : +load ( offset -- ) blk @ + load ; + + : thru ( from to -- ) 1+ swap DO I load LOOP ; + + : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + + : --> 1 blk +! >in off .status ; immediate + + : loadfrom ( n -- ) pushfile use load close ; + + : \\ b/blk >in ! ; immediate + + : list ( scr -- ) dup capacity u< + IF scr ! ." Scr " scr @ . + ." Dr " drv . isfile@ .file + l/s 0 DO cr I 2 .r space scr @ block + I c/l * + c/l -trailing type + LOOP cr exit + THEN 9 ?diskerror ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + + + + +\ *** Block No. 122, Hexblock 7a + +\ Disk capacities ks 08 aug 88 + Dos definitions + + 6 Constant #drives + + Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , + +| Code ?capacity ( +n -- cap ) D shl capacities # W mov + D W add W ) D mov Next end-code + + + + + + + + +\ *** Block No. 123, Hexblock 7b + +\ MS-dos disk handlers direct access ks 31 jul 87 + +| Code block@ ( addr blk drv -- ff ) + D- A- mov D pop C pop R push U push + I push C R mov 2 # C mov D shl $25 int + Label end-r/w I pop I pop U pop R pop 0 # D mov + CS ?[ D+ A+ mov A error# #) mov D dec ]? Next + end-code + +| Code block! ( addr blk drv -- ff ) D- A- mov D pop + C pop R push U push I push C R mov 2 # C mov + D shl $26 int end-r/w # jmp + end-code + + + + +\ *** Block No. 124, Hexblock 7c + +\ MS-dos disk handlers direct access ks cas 18jul20 + +| : ?drive ( +n -- +n ) dup #drives u< ?exit + Error" beyond drive capacity" ; + + : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 + DO dup I ?capacity under u< IF drop LEAVE THEN + - swap 1+ swap LOOP swap ; + + : blk/drv ( -- capacity ) drv ?capacity ; + + Forth definitions + + : >drive ( blk1 +n -- blk2 ) ?drive + 0 swap drv 2dup u> dup >r 0= IF swap THEN + ?DO I ?capacity + LOOP r> IF negate THEN - ; + +\ *** Block No. 143, Hexblock 8f + +\ drive drv capacity drivenames ks 18 mär 88 + + : drive ( n -- ) isfile@ IF ~select exit THEN + ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; + + : drv ( -- n ) + isfile@ IF ~disk? exit THEN offset @ /drive nip ; + + : capacity ( -- n ) isfile@ ?dup + IF dup f.handle @ 0= IF dup freset THEN + f.size 2@ /block swap 0<> - exit THEN blk/drv ; + +| : Drv: Create c, Does> c@ drive ; + + 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: + 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: + +\ *** Block No. 98, Hexblock 62 + +\ Allocating buffers ks 31 oct 86 + + : allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + + : freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + + : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : (init-buffers prev off limit first ! all-buffers ; + +' (init-buffers IS init-buffers diff --git a/8086/msdos/src/vf86core.fth b/8086/msdos/src/vf86core.fth new file mode 100644 index 0000000..2c4fa43 --- /dev/null +++ b/8086/msdos/src/vf86core.fth @@ -0,0 +1,1837 @@ +\ *** Block No. 4, Hexblock 4 + +\ FORTH Preamble and ID ks 11 mär 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 rev. 3.9.1-MSDOS" + + + + +\ *** Block No. 5, Hexblock 5 + +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next ist in-line code. Fuer den debugger werden daher alle +\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target + + +\ *** Block No. 6, Hexblock 6 + +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code + +\ *** Block No. 7, Hexblock 7 + +\ User variables ks 16 sep 88 + 8 uallot drop \ Platz fuer Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link cr .( Wieso ist UDP Uservariable? ) + User udp \ points to next free addr in User_area + +\ *** Block No. 8, Hexblock 8 + +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment + + + +\ *** Block No. 9, Hexblock 9 + +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict + + + + + +\ *** Block No. 10, Hexblock a + +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; + +\ *** Block No. 11, Hexblock b + +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; + + + + + + + + + +\ *** Block No. 12, Hexblock c + +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code + + + +\ *** Block No. 13, Hexblock d + +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; + + + + + + + +\ *** Block No. 14, Hexblock e + +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code + + + + + +\ *** Block No. 15, Hexblock f + +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; + +\ *** Block No. 17, Hexblock 11 + +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; + +\ *** Block No. 19, Hexblock 13 + +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; + +\ *** Block No. 20, Hexblock 14 + +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code + + + + +\ *** Block No. 21, Hexblock 15 + +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; + +\ *** Block No. 25, Hexblock 19 + +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; + + + +\ *** Block No. 27, Hexblock 1b + +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; + +\ *** Block No. 28, Hexblock 1c + +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; + + +\ *** Block No. 29, Hexblock 1d + +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; + + + + +\ *** Block No. 30, Hexblock 1e + +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; + +\ *** Block No. 31, Hexblock 1f + +\ min max umax umin extend 10Mar8 + +\ | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +\ : min ( n1 n2 -- n3 ) 2dup > minimax ; +\ : max ( n1 n2 -- n3 ) 2dup < minimax ; +\ : umax ( u1 u2 -- u3 ) 2dup u< minimax ; +\ : umin ( u1 u2 -- u3 ) 2dup u> minimax ; +\ : extend ( n -- d ) dup 0< ; +\ : dabs ( d -- ud ) extend IF dnegate THEN ; +\ : abs ( n -- u) extend IF negate THEN ; + + + + + + +\ *** Block No. 32, Hexblock 20 + +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; + + +\ *** Block No. 33, Hexblock 21 + +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\ + +\ | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + +\ : (do ( limit start -- ) over - dodo ; restrict +\ : (?do ( limit start -- ) over - ?dup IF dodo THEN +\ r> dup @ + >r drop ; restrict + + +\ *** Block No. 34, Hexblock 22 + +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict + +\ *** Block No. 38, Hexblock 26 + +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | + + + +\ *** Block No. 39, Hexblock 27 + +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; + + + +\ *** Block No. 40, Hexblock 28 + +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; + + +\ *** Block No. 41, Hexblock 29 + +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; + + + + +\ *** Block No. 42, Hexblock 2a + +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; + + + +\ *** Block No. 43, Hexblock 2b + +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code + + +\ *** Block No. 44, Hexblock 2c + +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; + + + +\ *** Block No. 45, Hexblock 2d + +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; + + + + + + + +\ *** Block No. 46, Hexblock 2e + +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict + + + +\ *** Block No. 47, Hexblock 2f + +\ input strings ks 23 dez 87 + + $84 Constant /tib + Variable #tib #tib off + Variable >tib here >tib ! /tib allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; + + + + + + +\ *** Block No. 48, Hexblock 30 + +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code + + +\ *** Block No. 49, Hexblock 31 + +\ scan skip /string ks 29 jul 87 + +\ : skip ( addr0 len0 char -- addr1 len1 ) >r +\ BEGIN dup +\ WHILE over c@ r@ = WHILE 1- swap 1+ swap +\ REPEAT rdrop ; + +\ : scan ( addr0 len0 char -- addr1 len1 ) >r +\ BEGIN dup +\ WHILE over c@ r@ - WHILE 1- swap 1+ swap +\ REPEAT rdrop ; + +\ : /string ( addr0 len0 +n -- addr1 len1 ) +\ over umin rot over + -rot - ; + + + +\ *** Block No. 50, Hexblock 32 + +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ ä + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ ö + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ ü + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code + + + + +\ *** Block No. 51, Hexblock 33 + +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\ high level, ohne Umlaute + +\ : capital ( char -- char') +\ dup Ascii a [ Ascii z 1+ ] Literal +\ uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + +\ : upper ( addr len -- ) +\ bounds ?DO I c@ capital I c! LOOP ; + +\ *** Block No. 52, Hexblock 34 + +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code + + +\ *** Block No. 53, Hexblock 35 + +\ (word ks 27 oct 86 + +\ | : (word ( char adr0 len0 -- addr ) +\ rot >r over swap >in @ /string r@ skip +\ over swap r> scan >r rot over swap - r> 0<> - >in ! +\ over - here dup >r place bl r@ count + c! r> ; + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + +\ source word parse name ks 03 aug 87 + + Variable loadfile loadfile off + + defer source + + : (source ( -- addr len ) tib #tib @ ; + + ' (source IS source + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; + + + + +\ *** Block No. 55, Hexblock 37 + +\ state Ascii ," "lit (" " ks 16 sep 88 + Variable state state off + + : Ascii ( char -- n ) bl word 1+ c@ + state @ 0=exit [compile] Literal ; immediate + + : ," Ascii " parse here over 1+ allot place ; + + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + + : (" "lit ; restrict + + : " compile (" ," align ; immediate restrict + +\ *** Block No. 56, Hexblock 38 + +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( Ascii ) parse 2drop ; immediate + : .( Ascii ) parse type ; immediate + + : \ blk @ IF >in @ negate c/l mod >in +! + ELSE #tib @ >in ! THEN ; immediate + + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; + + +\ *** Block No. 57, Hexblock 39 + +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and + THEN Ascii 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + + + + + +\ *** Block No. 58, Hexblock 3a + +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : char ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii & case? IF &10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + +\ *** Block No. 59, Hexblock 3b + +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + +\ *** Block No. 60, Hexblock 3c + +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num char + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; + + +\ *** Block No. 61, Hexblock 3d + +\ hide reveal immediate restrict ks 18 mär 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; + +\ *** Block No. 62, Hexblock 3e + +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; + + + +\ *** Block No. 63, Hexblock 3f + +\ Does> ; ks 18 mär 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict + + + + +\ *** Block No. 64, Hexblock 40 + +\ ?head | alignments ks 19 mär 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate +\ machen nichts beim 8088. 8086 koennte etwas schneller werden + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; + + +\ *** Block No. 65, Hexblock 41 + +\ Create Variable ks 19 mär 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; + + + + +\ *** Block No. 66, Hexblock 42 + +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + + +\ : nfa? ( thread cfa -- nfa / false ) >r +\ BEGIN @ dup 0= IF rdrop exit THEN +\ dup 2+ name> r@ = UNTIL 2+ rdrop ; + + +\ *** Block No. 67, Hexblock 43 + +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; + +\ *** Block No. 68, Hexblock 44 + +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code + + + + +\ *** Block No. 69, Hexblock 45 + +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code + +\ *** Block No. 70, Hexblock 46 + +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; + +\ *** Block No. 71, Hexblock 47 + +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary + Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; + +\ *** Block No. 72, Hexblock 48 + +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] Ascii capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; + +\ *** Block No. 73, Hexblock 49 + +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code + +\ *** Block No. 74, Hexblock 4a + +\ -text (find ks 02 okt 87 + +\ : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) +\ over bounds +\ DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + +\ : (find ( string thread -- str false / NFA +n ) +\ over c@ $1F and >r @ +\ BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = +\ IF dup 1+ r@ 4 pick 1+ -text +\ 0= IF rdrop -rot drop exit +\ THEN THEN drop +\ REPEAT rdrop ; + + + + +\ *** Block No. 75, Hexblock 4b + +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; + + +\ *** Block No. 76, Hexblock 4c + +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; + + + +\ *** Block No. 77, Hexblock 4d + +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; + +\ *** Block No. 78, Hexblock 4e + +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate + + + + + + + + +\ *** Block No. 79, Hexblock 4f + +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; + + + + +\ *** Block No. 80, Hexblock 50 + +\ .status push load ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + + + +\ *** Block No. 82, Hexblock 52 + +\ prompt quit ks 16 sep 88 + + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; + + +\ *** Block No. 83, Hexblock 53 + +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; + + + + + +\ *** Block No. 84, Hexblock 54 + +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict + + + +\ *** Block No. 85, Hexblock 55 + +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; + + + + + +\ *** Block No. 86, Hexblock 56 + +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; + +\ *** Block No. 87, Hexblock 57 + +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + + + + +\ *** Block No. 88, Hexblock 58 + +\ list c/l l/s ks 19 mär 88 + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + + + + + +\ *** Block No. 89, Hexblock 59 + +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT + + + $10000 Constant limit Variable first + + +\ *** Block No. 99, Hexblock 63 + +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; + +\ *** Block No. 100, Hexblock 64 + +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; + +\ *** Block No. 101, Hexblock 65 + +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words remove-files + custom-remove heap swap - hallot dp ! last off ; + + + +\ *** Block No. 102, Hexblock 66 + +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; + + + + + +\ *** Block No. 103, Hexblock 67 + +\ save bye stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; + + + +\ *** Block No. 104, Hexblock 68 + +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + + +\ *** Block No. 105, Hexblock 69 + +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions + + + + +\ *** Block No. 106, Hexblock 6a + +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; + + +\ *** Block No. 107, Hexblock 6b + +\ (boot ks 11 mär 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code + + + +\ *** Block No. 108, Hexblock 6c + +\ restart ks 09 mär 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code + + + + + +\ *** Block No. 109, Hexblock 6d + +\ bye ks 11 mär 89 + + Variable return_code return_code off + +| Code (bye cli A A xor A E: mov #segs # call + C: D mov D R add R D: mov 0 # I mov I W mov + $200 # C mov rep movs sti \ restore interrupts + $4C # A+ mov C: seg return_code #) A- mov + $21 int warmboot # call + end-code + + : bye flush empty page (bye ; + + + + + +\ *** Block No. 110, Hexblock 6e + +\ cold ks 09 mär 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + #segs # call $41 # R add \ another k for the ints + $4A # A+ mov $21 int \ alloc memory + CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code diff --git a/8086/msdos/src/vf86dos.fth b/8086/msdos/src/vf86dos.fth new file mode 100644 index 0000000..0bf9aa8 --- /dev/null +++ b/8086/msdos/src/vf86dos.fth @@ -0,0 +1,553 @@ + + Forth definitions + + Defer save-buffers ' noop IS save-buffers + Defer init-buffers ' noop IS init-buffers + Defer empty-buffers ' noop IS empty-buffers + + Defer flush-file-buffers ( fcb -- ) + ' drop IS flush-file-buffers + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung + + +\ *** Block No. 112, Hexblock 70 + +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code + + + +\ *** Block No. 113, Hexblock 71 + +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code + + + + +\ *** Block No. 114, Hexblock 72 + +\ BDOS keyboard input ks 16 sep 88 +\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P + +| Variable newkey newkey off + + Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or + 0= ?[ $7 # A+ mov $21 int A- D- mov ]? + 0 # D+ mov D+ newkey 1+ #) mov Next + end-code + + Code (key? ( -- f ) D push newkey #) D mov D+ D+ or + 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= + ?[ 0 # D+ mov + ][ -1 # A+ mov A newkey #) mov -1 # D+ mov + ]? ]? D+ D- mov Next + end-code + +\ *** Block No. 115, Hexblock 73 + +\ empty-keys (key ks 16 sep 88 + + Code empty-keys $C00 # A mov $21 int + 0 # newkey 1+ #) byte mov Next end-code + + : (key ( -- 16b ) BEGIN pause (key? UNTIL + (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + +\ BIOS keyboard input ks 16 sep 88 + +\ Code (key@ ( -- 8b ) D push A+ A+ xor $16 int +\ A- D- xchg 0 # D+ mov Next end-code + +\ Code (key? ( -- f ) D push 1 # A+ mov D D xor +\ $16 int 0= not ?[ D dec ]? Next end-code + +\ Code empty-keys $C00 # A mov $21 int Next end-code + +\ : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +\ mit diesen Keytreibern sind die Funktionstasten nicht +\ mehr durch ANSI.SYS Sequenzen vorbelegt. + + + +\ *** Block No. 117, Hexblock 75 + +\ (decode expect ks 16 sep 88 + + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr + + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop + +\ *** Block No. 118, Hexblock 76 + +\ MSDOS character output ks 29 jun 87 + + Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? + 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; + + + +\ *** Block No. 119, Hexblock 77 + +\ MSDOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + +\ MSDOS printer I/O Port access ks 09 aug 87 + + Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next + end-code + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code + + + + + +\ *** Block No. 121, Hexblock 79 + +\ zero terminated strings ks 09 aug 87 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + + + : asciz ( -- asciz ) name here >asciz ; + + + + + + +\ *** Block No. 125, Hexblock 7d + +\ MS-DOS file access ks 18 mär 88 + Vocabulary Dos Dos also definitions + +| Variable fcb fcb off \ last fcb accessed +| Variable prevfile \ previous active file + + &30 Constant fnamelen \ default length in FCB + + Create filename &62 allot \ max 60 + count + null + + Variable attribut 7 attribut ! \ read-only, hidden, system + + + + + + +\ *** Block No. 126, Hexblock 7e + +\ MS-DOS disk errors ks cas 18jul20 + +| : .error# ." error # " base push decimal error# @ . ; + +| : .ferrors error# @ &18 case? IF 2 THEN + 1 case? Abort" file exists" + 2 case? Abort" file not found" + 3 case? Abort" path not found" + 4 case? Abort" too many open files" + 5 case? Abort" no access" + 9 case? Abort" beyond end of file" + &15 case? Abort" illegal drive" + &16 case? Abort" current directory" + &17 case? Abort" wrong drive" + drop ." Disk" .error# abort ; + + +\ *** Block No. 127, Hexblock 7f + +\ MS-DOS disk errors ks cas 18jul20 + + : (diskerror ( *f -- ) ?dup 0=exit + fcb @ IF error# ! .ferrors exit THEN + input push output push standardi/o 1- + IF ." read" ELSE ." write" THEN + .error# ." retry? (y/n)" + key cr capital Ascii Y = not Abort" aborted" ; + + ' (diskerror Is ?diskerror + + + + + + + +\ *** Block No. 128, Hexblock 80 + +\ ~open ~creat ~close ks 04 aug 87 + + Code ~open ( asciz mode -- handle ff / err# ) + A D xchg $3D # A+ mov + Label >open D pop $21 int A D xchg + CS not ?[ D push 0 # D mov ]? Next + end-code + + Code ~creat ( asciz attribut -- handle ff / err# ) + D C mov $3C # A+ mov >open ]] end-code + + Code ~close ( handle -- ) D R xchg + $3E # A+ mov $21 int R D xchg D pop Next + end-code + + + +\ *** Block No. 129, Hexblock 81 + +\ ~first ~unlink ~select ~disk? ks 04 aug 87 + + Code ~first ( asciz attr -- err# ) + D C mov D pop $4E # A+ mov + [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code + + Code ~select ( n -- ) + $E # A+ mov $21 int D pop Next end-code + + Code ~disk? ( -- n ) D push $19 # A+ mov + $21 int A- D- mov 0 # D+ mov Next + end-code + + +\ *** Block No. 130, Hexblock 82 + +\ ~next ~dir ks 04 aug 87 + + Code ~next ( -- err# ) D push $4F # A+ mov + $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~dir ( addr drive -- err# ) I W mov + I pop $47 # A+ mov $21 int W I mov + 0 # D mov CS ?[ A D xchg ]? Next + end-code + + + + + + + +\ *** Block No. 131, Hexblock 83 + +\ MS-DOS file control Block cas 19jun20 + +\ | : Fcbytes ( n1 len -- n2 ) Create over c, + +\ Does> ( fcbaddr -- fcbfield ) c@ + ; +| : Fcbytes Create over c, + Does> c@ + ; + +\ first field for file-link +2 1 Fcbytes f.no \ must be first field + 2 Fcbytes f.handle + 2 Fcbytes f.date + 2 Fcbytes f.time + 4 Fcbytes f.size + fnamelen Fcbytes f.name Constant b/fcb + +b/fcb Host ' tb/fcb >body ! + Target Forth also Dos also definitions + + +\ *** Block No. 132, Hexblock 84 + +\ (.file fname fname! ks 10 okt 87 + + : fname! ( string fcb -- ) f.name >r count + dup fnamelen < not Abort" file name too long" r> place ; + + : fclose ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup 0= IF drop exit THEN + over flush-file-buffers ~close f.handle off ; + + +\ *** Block No. 133, Hexblock 85 + +\ (.file fname fname! ks 18 mär 88 + +| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; + + : (fsearch ( string -- asciz *f ) + filename >asciz dup attribut @ ~first ; + + Defer fsearch ( string -- asciz *f ) + + ' (fsearch Is fsearch + +\ graceful behaviour if file does not exist +| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = + IF hide file-link @ @ file-link ! prevfile @ setfiles + last @ 4 - dp ! last off filename count here place + THEN ?diskerror ; + +\ *** Block No. 134, Hexblock 86 + +\ freset fseek ks 19 mär 88 + + : freset ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup IF ~close THEN dup >r + f.name fsearch ?notfound getsize r@ f.size 2! + [ $80 &22 + ] Literal @ r@ f.time ! + [ $80 &24 + ] Literal @ r@ f.date ! + 2 ~open ?diskerror r> f.handle ! ; + + + Code fseek ( dfaddr fcb -- ) + D W mov u' f.handle W D) W mov W W or 0= + ?[ ;c: dup freset fseek ; Assembler ]? R W xchg + C pop D pop $4200 # A mov $21 int W R mov + CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; + + +\ *** Block No. 135, Hexblock 87 + +\ lfgets fgetc file@ ks 07 jul 88 + +\ Code ~read ( seg:addr quan handle -- #read ) D W mov +Assembler [[ W R xchg C pop D pop + D: pop $3F # A+ mov $21 int C: C mov C D: mov + W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; + + Code lfgets ( seg:addr quan fcb -- #read ) + D W mov u' f.handle W D) W mov ]] end-code + + true Constant eof + + : fgetc ( fcb -- 8b / eof ) + >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; + + : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; + +\ *** Block No. 136, Hexblock 88 + +\ lfputs fputc file! ks 24 jul 87 + +| Code ~write ( seg:addr quan handle -- ) D W mov +[[ W R xchg C pop D pop + D: pop $40 # A+ mov $21 int W R mov A D xchg + C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? + C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; + + Code lfputs ( seg:addr quan fcb -- ) + D W mov u' f.handle W D) W mov ]] end-code + + : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; + + : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; + + + Forth definitions + +| : setfiles ( fcb -- ) isfile@ prevfile ! + dup isfile ! fromfile ! ; + + : direct 0 setfiles ; + + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; + + +\ *** Block No. 140, Hexblock 8c + +\ File >file ks 23 mär 88 + + : File Create file-link @ here file-link ! , + here [ b/fcb 2 - ] Literal dup allot erase + file-link @ dup @ f.no c@ 1+ over f.no c! + last @ count $1F and rot f.name place + Does> setfiles ; + + File kernel.scr ' kernel.scr @ Constant [fcb] + + Dos definitions + + : .file ( fcb -- ) + ?dup IF body> >name .name exit THEN ." direct" ; + + + +\ *** Block No. 141, Hexblock 8d + +\ .file pushfile close open ks 12 mai 88 + Forth definitions + + : file? isfile@ .file ; + + : pushfile r> isfile push fromfile push >r ; restrict + + : close isfile@ fclose ; + + : open isfile@ freset ; + + : assign isfile@ dup fclose name swap fname! open ; + + + + + +\ *** Block No. 142, Hexblock 8e + +\ use from loadfrom include ks 18 mär 88 + + : use >in @ name find + 0= IF swap >in ! File last' THEN nip + dup @ [fcb] = over ['] direct = or + 0= Abort" not a file" execute open ; + + : from isfile push use ; + +\ Old pure-block-file include: +\ : include 1 loadfrom ; + + + + + +\ *** Block No. 144, Hexblock 90 + +\ lfsave savefile savesystem ks 10 okt 87 + + : lfsave ( seg:addr quan string -- ) + filename >asciz 0 ~creat ?diskerror + dup >r ~write r> ~close ; + + : savefile ( addr len -- ) ds@ -rot + name nullstring? Abort" needs name" lfsave ; + + : savesystem save flush $100 here savefile ; + + + + + + + +\ *** Block No. 145, Hexblock 91 + +\ viewing ks 19 mär 88 + Dos definitions +| $400 Constant viewoffset + + : (makeview ( -- n ) + blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup + IF viewoffset * + $8000 or exit THEN 0= ; + ' (makeview Is makeview + + : @view ( acf -- blk fno ) >name 4 - @ dup 0< + IF $7FFF and viewoffset u/mod exit THEN + ?dup 0= Error" eingetippt" 0 ; + + : >file ( fno -- fcb ) dup 0=exit file-link + BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; + + +\ *** Block No. 146, Hexblock 92 + +\ forget FCB's ks 23 okt 88 + Forth definitions +| : 'file ( -- scr ) r> scr push isfile push >r + [ Dos ] ' @view >file isfile ! ; + +| : remove? ( dic symb addr -- dic symb addr f ) + 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb ) file-link + BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT + file-link remove + isfile@ remove? nip IF file-link @ isfile ! THEN + fromfile @ remove? nip 0=exit isfile@ fromfile ! ; diff --git a/8086/msdos/src/vf86end.fth b/8086/msdos/src/vf86end.fth new file mode 100644 index 0000000..e249ea2 --- /dev/null +++ b/8086/msdos/src/vf86end.fth @@ -0,0 +1,12 @@ + + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved diff --git a/8086/msdos/src/vf86file.fth b/8086/msdos/src/vf86file.fth new file mode 100644 index 0000000..e7fa7a0 --- /dev/null +++ b/8086/msdos/src/vf86file.fth @@ -0,0 +1,93 @@ + + variable tibeof tibeof off + + : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: eof: return line and flag eof + tibeof off + dup #lf = IF drop 0 exit THEN + -1 = IF tibeof on 1 ELSE -1 THEN ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ incfile incpos inc-fgetc phz 06feb22 + + variable incfile + variable incpos 2 allot + + : inc-fgetc ( -- c ) + incfile @ f.handle @ 0= IF + incpos 2@ incfile @ fseek THEN + incfile @ fgetc + incpos 2@ 1. d+ incpos 2! ; + + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ freadline probe-for-fb phz 06feb22 + + : freadline ( -- eof ) + tib /tib bounds DO + inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN + 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN + LOOP /tib #tib ! + ." warning: line exteeds max " /tib . cr + ." extra chars ignored" cr + BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; + +| : probe-for-fb ( -- flag ) + \ probes whether current file looks like a block file + /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN + LOOP true ; + + +\ *** Block No. 5, Hexblock 5 + +\ save/restoretib phz 16jan22 + + $50 constant /stash + create stash[ /stash allot here constant ]stash + variable stash> stash[ stash> ! + + : savetib ( -- n ) + #tib @ >in @ - dup stash> @ + ]stash u> + abort" tib stash overflow" >r + tib >in @ + stash> @ r@ cmove + r@ stash> +! r> ; + + : restoretib ( n -- ) + dup >r negate stash> +! stash> @ tib r@ cmove + r> #tib ! >in off ; + + +\ *** Block No. 6, Hexblock 6 + +\ interpret-via-tib include phz 06feb22 + + : interpret-via-tib + BEGIN freadline >r .status >in off interpret + r> UNTIL ; + + Defer include-load +| : block-not-implemented 1 abort" block file access not implemented" ; + ' block-not-implemented IS include-load + + : include ( -- ) + pushfile use cr file? + probe-for-fb isfile@ freset IF 1 include-load close exit THEN + incfile push isfile@ incfile ! + incpos push incpos off incpos 2+ dup push off + savetib >r interpret-via-tib close r> restoretib ; + + : (stashquit stash[ stash> ! (quit ; + : stashrestore ['] (stashquit IS 'quit ; + ' stashrestore IS 'restart diff --git a/8086/msdos/src/vf86info.txt b/8086/msdos/src/vf86info.txt new file mode 100644 index 0000000..efb70e8 --- /dev/null +++ b/8086/msdos/src/vf86info.txt @@ -0,0 +1,58 @@ + +\ *** Block No. 0, Hexblock 0 + +\^@ #### volksFORTH #### cas 18jul20 +VolksForth has been developed by + + K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck + Ulli Hoffmann, Philip Zembrod, Carsten Strotmann +6502 version by B.Pennemann and K.Schleisiek +Port to C64 "ultraFORTH" by G. Rehfeld +Port to 68000 and Atari ST by D.Weineck and B.Pennemann +Port to 8080 and CP/M by U.Hoffmann jul 86 +Port to C16 "ultraFORTH" by C.Vogt +Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 + + + + + + +\ *** Block No. 2, Hexblock 2 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt +Dabei ist die Zuordnung zu den Intel Namen folgendermassen: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A und C sind zur allgemeinen Benutzung frei + +D <=> DX D- <=> DL D+ <=> DH + das oberste Element des (Daten)-Stacks. + +R <=> BX R- <=> RL R+ <=> RH + der Return_stack_pointer + + + +\ *** Block No. 3, Hexblock 3 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + Alle Segmentregister werden beim booten auf den Wert des + Codesegments C: gesetzt und muessen, wenn sie "verstellt" + werden, wieder auf C: zurueckgesetzt werden. + + + + + + diff --git a/8086/msdos/volks4th.sys b/8086/msdos/src/volks4th.sys similarity index 100% rename from 8086/msdos/volks4th.sys rename to 8086/msdos/src/volks4th.sys diff --git a/8086/msdos/tests/ans-shim.fth b/8086/msdos/tests/ans-shim.fth new file mode 100644 index 0000000..2c9c976 --- /dev/null +++ b/8086/msdos/tests/ans-shim.fth @@ -0,0 +1,101 @@ + +: cells 2* ; + +: s" [compile] " compile count ; immediate restrict +: c" [compile] " ; immediate restrict + +: [char] [compile] ascii ; immediate +: char [compile] ascii ; + +: invert not ; + +: lshift 0 ?DO 2* LOOP ; + +: rshift 0 ?DO 2/ 32767 and LOOP ; + +\ : 2over 3 pick 3 pick ; + +: s>d extend ; + +: fm/mod m/mod ; + +: sm/rem dup >r 2dup xor >r m/mod + over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN + ELSE rdrop rdrop THEN ; + +: postpone ' dup >name c@ $40 and + IF , ELSE [compile] compile compile , THEN ; immediate + +\ : align ; +: aligned ; +: cell+ 2+ ; +: char+ 1+ ; +: chars ; + +\ : 2@ dup 2+ @ swap @ ; +\ : 2! under ! 2+ ! ; + +: recurse last @ name> , ; immediate + +' endloop alias unloop + +: >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) + BEGIN dup 0= IF exit THEN + >r count digit? WHILE accumulate r> 1- REPEAT 1- r> ; + +: accept expect span @ ; + +: tuck under ; + +: :noname here ['] tuck @ , 0 ] ; + +: <> = not ; + +: 2>r r> -rot swap >r >r >r ; +: 2r> r> r> r> swap rot >r ; +: 2r@ r> r> r> 2dup >r >r swap rot >r ; + +: WITHIN ( test low high -- flag ) OVER - >R - R> U< ; + +: unused sp@ here - ; +: again [compile] repeat ; immediate restrict + +: BUFFER: CREATE ALLOT ; + +: compile, , ; + +: defer! >body ! ; +: defer@ >body @ ; +: action-of + STATE @ IF + POSTPONE ['] POSTPONE DEFER@ + ELSE + ' DEFER@ + THEN ; IMMEDIATE + + : HOLDS ( addr u -- ) + BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ; + +: 2Variable ( --) Create 4 allot ; + ( -- adr) + +: 2Constant ( d --) Create , , + Does> ( -- d) 2@ ; + +: 2literal swap [compile] literal [compile] literal ; +immediate restrict + +: d- dnegate d+ ; +: d0< 0. d< ; +: d2* 2dup d+ ; +: d2/ dup 1 and -rot 2/ >r + 1 rshift swap IF $8000 or THEN r> ; + +: dmax 2over 2over d< IF 2swap THEN 2drop ; +: dmin 2over 2over 2swap d< IF 2swap THEN 2drop ; + +: d>s drop ; + +: m+ extend d+ ; + +: 2rot 5 roll 5 roll ; diff --git a/8086/msdos/tests/block.fth b/8086/msdos/tests/block.fth new file mode 100644 index 0000000..cb1b450 --- /dev/null +++ b/8086/msdos/tests/block.fth @@ -0,0 +1,679 @@ +\ To test the ANS Forth Block word set and extension words + +\ This program was written by Steve Palmer in 2015, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.1 23 October 2015 First Version +\ Version 0.2 15 November 2015 Updated after feedback from Gerry Jackson + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ Words tested in this file are: +\ BLK BLOCK BUFFER EVALUATE FLUSH LOAD SAVE-BUFFERS UPDATE +\ EMPTY-BUFFERS LIST SCR THRU REFILL SAVE-INPUT RESTORE-INPUT \ +\ +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - errorreport.fth has been loaded prior to this file +\ - utilities.fth has been loaded prioir to this file +\ ------------------------------------------------------------------------------ + +use empty.fb + +TESTING Block word set + +DECIMAL + +\ Define these constants from the system documentation provided. +\ WARNING: The contents of the test blocks will be destroyed by this test. +\ The blocks tested will be in the range +\ FIRST-TEST-BLOCK <= u < LIMIT-TEST-BLOCK +\ The tests need at least 2 test blocks in the range to complete. +20 CONSTANT FIRST-TEST-BLOCK +30 CONSTANT LIMIT-TEST-BLOCK \ one beyond the last + +FIRST-TEST-BLOCK LIMIT-TEST-BLOCK U< 0= [?IF] +\? .( Error: Test Block range not identified ) CR ABORT +[?THEN] + +LIMIT-TEST-BLOCK FIRST-TEST-BLOCK - CONSTANT TEST-BLOCK-COUNT +TEST-BLOCK-COUNT 2 U< [?IF] +\? .( Error: At least 2 Test Blocks are required to run the tests ) CR ABORT +[?THEN] + +\ ------------------------------------------------------------------------------ +TESTING Random Number Utilities + +\ The block tests make extensive use of random numbers to select blocks to test +\ and to set the contents of the block. It also makes use of a Hash code to +\ ensure the integrity of the blocks against unexpected changes. + +\ == Memory Walk tools == + +: @++ ( a-addr -- a-addr+4 a-addr@ ) + DUP CELL+ SWAP @ ; + +: !++ ( x a-addr -- a-addr+4 ) + TUCK ! CELL+ ; + +: C@++ ( c-addr -- c-addr;char+ c-addr@ ) + DUP CHAR+ SWAP C@ ; + +: C!++ ( char c-addr -- c-addr+1 ) + TUCK ! CHAR+ ; + +\ == Random Numbers == +\ Based on "Xorshift" PRNG wikipedia page +\ reporting on results by George Marsaglia +\ https://en.wikipedia.org/wiki/Xorshift +\ Note: THIS IS NOT CRYPTOGRAPHIC QUALITY + +: PRNG + CREATE ( "name" -- ) + 4 CELLS ALLOT + DOES> ( -- prng ) +; + +: PRNG-ERROR-CODE ( prng -- errcode | 0 ) + 0 4 0 DO \ prng acc + >R @++ R> OR \ prng acc' + LOOP \ prng xORyORzORw + NIP 0= ; \ xORyORzORw=0 + +: PRNG-COPY ( src-prng dst-prng -- ) + 4 CELLS MOVE ; + +: PRNG-SET-SEED ( prng w z y x -- ) + 4 PICK \ prng w z y x prng + 4 0 DO !++ LOOP DROP \ prng + DUP PRNG-ERROR-CODE IF \ prng + 1 OVER +! \ prng + THEN \ prng + DROP ; \ + +BITS/CELL 64 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ +\? DUP 21 LSHIFT XOR +\? DUP 35 RSHIFT XOR +\? DUP 4 LSHIFT XOR +\? TUCK SWAP ! ; +[?THEN] + +BITS/CELL 32 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 11 LSHIFT XOR \ prng t=x^(x<<11) +\? DUP 8 RSHIFT XOR \ prng t'=t^(t>>8) +\? OVER DUP CELL+ SWAP 3 CELLS MOVE \ prng t' +\? OVER 3 CELLS + @ \ prng t' w +\? DUP 19 RSHIFT XOR \ prng t' w'=w^(w>>19) +\? XOR \ prng rnd=w'^t' +\? TUCK SWAP 3 CELLS + ! ; \ rnd +[?THEN] + +BITS/CELL 16 = [?IF] +\? .( === NOT TESTED === ) +\? \ From http://b2d-f9r.blogspot.co.uk/2010/08/16-bit-xorshift-rng-now-with-more.html +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 5 LSHIFT XOR \ prng t=x^(x<<5) +\? DUP 3 RSHIFT XOR \ prng t'=t^(t>>3) +\? OVER DUP CELL+ @ TUCK SWAP ! \ prng t' y +\? DUP 1 RSHIFT XOR \ prng t' y'=y^(y>>1) +\? XOR \ prng rnd=y'^t' +\? TUCK SWAP CELL+ ! ; \ rnd +[?THEN] + +[?DEF] PRNG-RND +\? .( You need to add a Psuedo Random Number Generator for your cell size: ) +\? BITS/CELL U. CR +\? ABORT +[?THEN] + +: PRNG-RANDOM ( lower upper prng -- rnd ) + >R OVER - R> PRNG-RND UM* NIP + ; +\ PostCondition: T{ lower upper 2DUP 2>R prng PRNG-RANDOM 2R> WITHIN -> TRUE }T + +PRNG BLOCK-PRNG +\ Generated by Random.org +BLOCK-PRNG -1865266521 188896058 -2021545234 -1456609962 PRNG-SET-SEED +: BLOCK-RND ( -- rnd ) BLOCK-PRNG PRNG-RND ; +: BLOCK-RANDOM ( lower upper -- rnd ) BLOCK-PRNG PRNG-RANDOM ; + +: RND-TEST-BLOCK ( -- blk ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK BLOCK-RANDOM ; +\ PostCondition: T{ RND-TEST-BLOCK FIRST-TEST-BLOCK LIMIT-TEST-BLOCK WITHIN -> TRUE }T + +\ Two distinct random test blocks +: 2RND-TEST-BLOCKS ( -- blk1 blk2 ) + RND-TEST-BLOCK BEGIN \ blk1 + RND-TEST-BLOCK \ blk1 blk2 + 2DUP = \ blk1 blk2 blk1==blk2 + WHILE \ blk1 blk1 + DROP \ blk1 + REPEAT ; \ blk1 blk2 +\ PostCondition: T{ 2RND-TEST-BLOCKS = -> FALSE }T + +\ first random test block in a sequence of length u +: RND-TEST-BLOCK-SEQ ( u -- blks ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK ROT 1- - BLOCK-RANDOM ; + +\ I'm not sure if this algorithm is correct if " 1 CHARS 1 <> ". +: ELF-HASH-ACCUMULATE ( hash c-addr u -- hash ) + >R SWAP R> 0 DO \ c-addr h + 4 LSHIFT \ c-addr h<<=4 + SWAP C@++ ROT + \ c-addr' h+=*s + DUP [ HEX ] F0000000 [ DECIMAL ] AND \ c-addr' h high=h&0xF0000000 + DUP IF \ c-addr' h high + DUP >R 24 RSHIFT XOR R> \ c-addr' h^=high>>24 high + THEN \ c-addr' h high + INVERT AND \ c-addr' h&=~high + LOOP NIP ; + +: ELF-HASH ( c-addr u -- hash ) + 0 ROT ROT ELF-HASH-ACCUMULATE ; + +\ ------------------------------------------------------------------------------ +TESTING BLOCK ( read-only mode ) + +\ BLOCK signature +T{ RND-TEST-BLOCK BLOCK DUP ALIGNED = -> TRUE }T + +\ BLOCK accepts all blocks in the test range +: BLOCK-ALL ( blk2 blk1 -- ) + DO + I BLOCK DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BLOCK-ALL -> }T + +\ BLOCK twice on same block returns the same value +T{ RND-TEST-BLOCK DUP BLOCK SWAP BLOCK = -> TRUE }T + +\ BLOCK twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ ------------------------------------------------------------------------------ +TESTING BUFFER ( read-only mode ) + +\ Although it is not in the spirit of the specification, +\ a compliant definition of BUFFER would be +\ : BUFFER BLOCK ; +\ So we can only repeat the tests for BLOCK ... + +\ BUFFER signature +T{ RND-TEST-BLOCK BUFFER DUP ALIGNED = -> TRUE }T + +\ BUFFER accepts all blocks in the test range +: BUFFER-ALL ( blk2 blk1 -- ) + DO + I BUFFER DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BUFFER-ALL -> }T + +\ BUFFER twice on the same block returns the same value +T{ RND-TEST-BLOCK DUP BUFFER SWAP BUFFER = -> TRUE }T + +\ BUFFER twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ Combinations with BUFFER +T{ RND-TEST-BLOCK DUP BLOCK SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BUFFER SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING Read and Write access with UPDATE and FLUSH + +\ Ideally, we'd like to be able to test the persistence across power cycles +\ of the writes, but we can't do that in a simple test. +\ The tests below could be fooled by a large buffers store and a tricky FLUSH +\ but what else are you going to do? + +\ Signatures +T{ RND-TEST-BLOCK BLOCK DROP UPDATE -> }T +T{ FLUSH -> }T + +: BLANK-BUFFER ( blk -- blk-addr ) + BUFFER DUP 1024 BL FILL ; + +\ Test R/W of a Simple Blank Random Block +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify first character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify last character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER 1023 CHARS + C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: First and Last (and all other) blocks in the test range +1024 8 * BITS/CELL / CONSTANT CELLS/BLOCK + +: PREPARE-RND-BLOCK ( hash blk -- hash' ) + BUFFER DUP \ hash blk-addr blk-addr + CELLS/BLOCK 0 DO \ hash blk-addr blk-addr[i] + BLOCK-RND OVER ! CELL+ \ hash blk-addr blk-addr[i+1] + LOOP DROP \ hash blk-addr + 1024 ELF-HASH-ACCUMULATE ; \ hash' + +: WRITE-RND-BLOCKS-WITH-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash + I PREPARE-RND-BLOCK UPDATE \ hash' + LOOP ; \ hash' + +: READ-BLOCKS-AND-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash(i) + I BLOCK 1024 ELF-HASH-ACCUMULATE \ hash(i+1) + LOOP ; \ hash + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH FLUSH + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +: TUF1 ( xt blk -- hash ) + DUP BLANK-BUFFER \ xt blk blk-addr1 + 1024 ELF-HASH \ xt blk hash + ROT EXECUTE \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = ; \ TRUE + +\ Double UPDATE make no difference +: TUF1-1 ( -- ) UPDATE UPDATE FLUSH ; +T{ ' TUF1-1 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ Double FLUSH make no difference +: TUF1-2 ( -- ) UPDATE FLUSH FLUSH ; +T{ ' TUF1-2 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ FLUSH only saves UPDATEd buffers +T{ RND-TEST-BLOCK \ blk + 0 OVER PREPARE-RND-BLOCK \ blk hash + UPDATE FLUSH \ blk hash + OVER 0 SWAP PREPARE-RND-BLOCK DROP \ blk hash + FLUSH ( with no preliminary UPDATE) \ blk hash + SWAP BLOCK 1024 ELF-HASH = -> TRUE }T + +\ UPDATE only marks the current block buffer +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TUF2 ( xt blk1 blk2 -- hash1'' hash2'' hash1' hash2' hash1 hash2 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 hash2 + 2>R \ xt blk1 blk2 + FLUSH \ xt blk1 blk2 + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' hash2' + 2>R \ xt blk1 blk2 + ROT EXECUTE \ blk1 blk2 + FLUSH \ blk1 blk2 + SWAP BLOCK 1024 ELF-HASH \ blk2 hash1'' + SWAP BLOCK 1024 ELF-HASH \ hash1'' hash2'' + 2R> 2R> \ hash1'' hash2'' hash1' hash2' hash1 hash2 + THEN ; + +: 2= ( x1 x2 x3 x4 -- flag ) + ROT = ROT ROT = AND ; + +: TUF2-0 ( blk1 blk2 -- blk1 blk2 ) ; \ no updates +T{ ' TUF2-0 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2SWAP 2DROP 2= -> TRUE }T \ compare expected and actual + +: TUF2-1 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 only + OVER BLOCK DROP UPDATE ; +T{ ' TUF2-1 2RND-TEST-BLOCKS TUF2 \ run test procedure + SWAP DROP SWAP DROP 2= -> TRUE }T + +: TUF2-2 ( blk1 blk2 -- blk1 blk2 ) \ update blk2 only + DUP BUFFER DROP UPDATE ; +T{ ' TUF2-2 2RND-TEST-BLOCKS TUF2 \ run test procedure + DROP ROT DROP SWAP 2= -> TRUE }T + +: TUF2-3 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 and blk2 + TUF2-1 TUF2-2 ; +T{ ' TUF2-3 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2DROP 2= -> TRUE }T + +\ FLUSH and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING SAVE-BUFFERS + +\ In principle, all the tests above can be repeated with SAVE-BUFFERS instead of +\ FLUSH. However, only the full random test is repeated... + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH SAVE-BUFFERS + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +\ FLUSH and then SAVE-BUFFERS is harmless but undetectable +\ SAVE-BUFFERS and then FLUSH is undetectable + +\ Unlike FLUSH, SAVE-BUFFERS then BUFFER/BLOCK +\ returns the original buffer address +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BLOCK = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING BLK + +\ Signature +T{ BLK DUP ALIGNED = -> TRUE }T + +\ None of the words considered so far effect BLK +T{ BLK @ RND-TEST-BLOCK BUFFER DROP BLK @ = -> TRUE }T +T{ BLK @ RND-TEST-BLOCK BLOCK DROP BLK @ = -> TRUE }T +T{ BLK @ UPDATE BLK @ = -> TRUE }T + +T{ BLK @ FLUSH BLK @ = -> TRUE }T +T{ BLK @ SAVE-BUFFERS BLK @ = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING LOAD and EVALUATE + +\ Signature: n LOAD --> blank screen +T{ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD -> }T + +T{ BLK @ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD BLK @ = -> TRUE }T + +: WRITE-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER SWAP CHARS MOVE UPDATE FLUSH ; + +\ blk: u; blk LOAD +: TL1 ( u blk -- ) + SWAP 0 <# #S #> WRITE-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +T{ BLOCK-RND FIRST-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: LIMIT-TEST-BLOCK-1 +T{ BLOCK-RND LIMIT-TEST-BLOCK 1- 2DUP TL1 LOAD = -> TRUE }T + +: WRITE-AT-END-OF-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER + OVER 1024 SWAP - CHARS + + SWAP CHARS MOVE UPDATE FLUSH ; + +\ Boundary Test: End of Buffer +: TL2 ( u blk -- ) + SWAP 0 <# #S #> WRITE-AT-END-OF-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL2 LOAD = -> TRUE }T + +\ LOAD updates BLK +\ u: "BLK @"; u LOAD +: TL3 ( blk -- ) + S" BLK @" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TL3 DUP LOAD = -> TRUE }T + +\ EVALUATE resets BLK +\ u: "EVALUATE-BLK@"; u LOAD +\vf : EVALUATE-BLK@ ( -- BLK@ ) +\vf S" BLK @" EVALUATE ; +\vf : TL4 ( blk -- ) +\vf S" EVALUATE-BLK@" WRITE-BLOCK ; +\vf T{ RND-TEST-BLOCK DUP TL4 LOAD -> 0 }T + +\ EVALUTE can nest with LOAD +\ u: "BLK @"; S" u LOAD" EVALUATE +\vf : TL5 ( blk -- c-addr u ) +\vf 0 <# \ blk 0 +\vf [CHAR] D HOLD +\vf [CHAR] A HOLD +\vf [CHAR] O HOLD +\vf [CHAR] L HOLD +\vf BL HOLD +\vf #S #> ; \ c-addr u +\vf T{ RND-TEST-BLOCK DUP TL3 DUP TL5 EVALUATE = -> TRUE }T + +\ Nested LOADs +\ u2: "BLK @"; u1: "LOAD u2"; u1 LOAD +\vf : TL6 ( blk1 blk2 -- ) +\vf DUP TL3 \ blk1 blk2 +\vf TL5 WRITE-BLOCK ; +\vf T{ 2RND-TEST-BLOCKS 2DUP TL6 SWAP LOAD = -> TRUE }T + +\ LOAD changes the currect block that is effected by UPDATE +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TL7 ( blk1 blk2 -- u1 u2 rnd2 blk2-addr rnd1' rnd1 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER BLOCK-RND DUP ROT TL1 >R \ blk1 blk2 + DUP S" SOURCE DROP" WRITE-BLOCK \ blk1 blk2 + \ change blk1 to a new rnd, but don't UPDATE + OVER BLANK-BUFFER \ blk1 blk2 blk1-addr + BLOCK-RND DUP >R \ blk1 blk2 blk1-addr rnd1' + 0 <# #S #> \ blk1 blk2 blk1-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ Now LOAD blk2 + DUP LOAD DUP >R \ blk1 blk2 blk2-addr + \ Write a new blk2 + DUP 1024 BL FILL \ blk1 blk2 blk2-addr + BLOCK-RND DUP >R \ blk1 blk2 blk2-addr rnd2 + 0 <# #S #> \ blk1 blk2 blk2-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ The following UPDATE should refer to the LOADed blk2, not blk1 + UPDATE FLUSH \ blk1 blk2 + \ Finally, load both blocks then collect all results + LOAD SWAP LOAD \ u2 u1 + R> R> R> R> \ u2 u1 rnd2 blk2-addr rnd1' rnd1 + THEN ; +T{ 2RND-TEST-BLOCKS TL7 \ run test procedure + SWAP DROP SWAP DROP \ u2 u1 rnd2 rnd1 + 2= -> TRUE }T + +\ I would expect LOAD to work on the contents of the buffer cache +\ and not the block device, but the specification doesn't say. +\ Similarly, I would not expect LOAD to FLUSH the buffer cache, +\ but the specification doesn't say so. + +\ ------------------------------------------------------------------------------ +TESTING LIST and SCR + +\ Signatures +T{ SCR DUP ALIGNED = -> TRUE }T +\ LIST signature is test implicitly in the following tests... + +: TLS1 ( blk -- ) + S" Should show a (mostly) blank screen" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS1 DUP LIST SCR @ = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +: TLS2 ( blk -- ) + S" List of the First test block" WRITE-BLOCK ; +T{ FIRST-TEST-BLOCK DUP TLS2 LIST -> }T + +\ Boundary Test: LIMIT-TEST-BLOCK +: TLS3 ( blk -- ) + S" List of the Last test block" WRITE-BLOCK ; +T{ LIMIT-TEST-BLOCK 1- DUP TLS3 LIST -> }T + +\ Boundary Test: End of Screen +: TLS4 ( blk -- ) + S" End of Screen" WRITE-AT-END-OF-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS4 LIST -> }T + +\ BLOCK, BUFFER, UPDATE et al don't change SCR +: TLS5 ( blk -- ) + S" Should show another (mostly) blank screen" WRITE-BLOCK ; +\ the first test below sets the scenario for the subsequent tests +\ BLK is unchanged by LIST +T{ BLK @ RND-TEST-BLOCK DUP TLS5 LIST BLK @ = -> TRUE }T +\ SCR is unchanged by Earlier words +T{ SCR @ FLUSH SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BUFFER DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SAVE-BUFFERS SCR @ = -> TRUE }T +: TLS6 ( blk -- ) + S" SCR @" WRITE-BLOCK ; +T{ SCR @ RND-TEST-BLOCK DUP TLS6 LOAD SCR @ OVER 2= -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING EMPTY-BUFFERS + +T{ EMPTY-BUFFERS -> }T +T{ BLK @ EMPTY-BUFFERS BLK @ = -> TRUE }T +T{ SCR @ EMPTY-BUFFERS SCR @ = -> TRUE }T + +\ Test R/W, but discarded changes with EMPTY-BUFFERS +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + OVER BLOCK CHAR \ SWAP C! \ blk hash + UPDATE EMPTY-BUFFERS FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ EMPTY-BUFFERS discards all buffers +: TUF2-EB ( blk1 blk2 -- blk1 blk2 ) + TUF2-1 TUF2-2 EMPTY-BUFFERS ; \ c.f. TUF2-3 +T{ ' TUF2-EB 2RND-TEST-BLOCKS TUF2 + 2SWAP 2DROP 2= -> TRUE }T + +\ FLUSH and then EMPTY-BUFFERS is acceptable but untestable +\ EMPTY-BUFFERS and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING >IN manipulation from a block source + +: TIN ( blk -- ) + S" 1 8 >IN +! 2 3" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TIN LOAD -> 1 3 }T + +\ ------------------------------------------------------------------------------ +TESTING \, SAVE-INPUT, RESTORE-INPUT and REFILL from a block source + +\ Try to determine the number of charaters per line +\ Assumes an even number of characters per line +: | ( u -- u-2 ) 2 - ; +: C/L-CALC ( blk -- c/l ) + DUP BLANK-BUFFER \ blk blk-addr + [CHAR] \ OVER C! \ blk blk-addr blk:"\" + 511 0 DO \ blk c-addr[i] + CHAR+ CHAR+ [CHAR] | OVER C! \ blk c-addr[i+1] + LOOP DROP \ blk blk:"\ | | | | ... |" + UPDATE SAVE-BUFFERS FLUSH \ blk + 1024 SWAP LOAD ; \ c/l +[?DEF] C/L +[?ELSE] +\? .( Given Characters per Line: ) C/L U. CR +[?ELSE] +\? RND-TEST-BLOCK C/L-CALC CONSTANT C/L +\? C/L 1024 U< [?IF] +\? .( Calculated Characters per Line: ) C/L U. CR +[?THEN] + +: WRITE-BLOCK-LINE ( lin-addr[i] c-addr u -- lin-addr[i+1] ) + 2>R DUP C/L CHARS + SWAP 2R> ROT SWAP MOVE ; + +\ Discards to the end of the line +: TCSIRIR1 ( blk -- ) + BLANK-BUFFER + C/L 1024 U< IF + S" 2222 \ 3333" WRITE-BLOCK-LINE + S" 4444" WRITE-BLOCK-LINE + THEN + DROP UPDATE SAVE-BUFFERS ; + +T{ RND-TEST-BLOCK DUP TCSIRIR1 LOAD -> 2222 4444 }T + +VARIABLE T-CNT 0 T-CNT ! + +: MARK ( "" -- ) \ Use between <# and #> + CHAR HOLD ; IMMEDIATE + +: ?EXECUTE ( xt f -- ) + IF EXECUTE ELSE DROP THEN ; + +\ SAVE-INPUT and RESTORE-INPUT within a single block +\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR2 ( blk -- ) +\vf C/L 1024 U< IF +\vf BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE +\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE +\vf UPDATE SAVE-BUFFERS DROP +\vf ELSE +\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T + +\ REFILL across 2 blocks +\vf : TCSIRIR3 ( blks -- ) +\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK +\vf 1+ S" 10 11 12" WRITE-BLOCK ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T + +\ SAVE-INPUT and RESTORE-INPUT across 2 blocks +\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR4 ( blks -- ) +\vf C/L 1024 U< IF +\vf DUP BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE +\vf DROP UPDATE 1+ BLANK-BUFFER +\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE +\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE +\vf DROP UPDATE SAVE-BUFFERS +\vf ELSE +\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING THRU + +: TT1 ( blks -- ) + DUP S" BLK" WRITE-BLOCK + 1+ S" @" WRITE-BLOCK ; +T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T + +\ ------------------------------------------------------------------------------ + +BLOCK-ERRORS SET-ERROR-COUNT + +CR .( End of Block word tests) CR diff --git a/8086/msdos/tests/core.fr b/8086/msdos/tests/core.fr new file mode 100644 index 0000000..7c529d5 --- /dev/null +++ b/8086/msdos/tests/core.fr @@ -0,0 +1,1010 @@ +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +\ Added by GWJ so that ALIGN can be used before , (comma) is tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T \ vf: for CBM: s/X/x/ +T{ CHAR HELLO -> 48 }T \ vf: for CBM: s/HELLO/hello/ +T{ : GC1 [CHAR] X ; -> }T \ vf: for CBM: s/X/x/ +T{ : GC2 [CHAR] HELLO ; -> }T \ vf: for CBM: s/HELLO/hello/ +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T \ vf: for CBM: s/XY/xy/ +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +\vf T{ : GI5 BEGIN DUP 2 > +\vf WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +\vf T{ 1 GI5 -> 1 345 }T +\vf T{ 2 GI5 -> 2 345 }T +\vf T{ 3 GI5 -> 3 4 5 123 }T +\vf T{ 4 GI5 -> 4 5 123 }T +\vf T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +\vf : GE1 S" 123" ; IMMEDIATE +\vf : GE2 S" 123 1+" ; IMMEDIATE +\vf : GE3 S" : GE4 345 ;" ; +\vf : GE5 EVALUATE ; IMMEDIATE + +\vf T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +\vf T{ GE2 EVALUATE -> 124 }T +\vf T{ GE3 EVALUATE -> }T +\vf T{ GE4 -> 345 }T + +\vf T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +\vf T{ GE6 -> 123 }T +\vf T{ : GE7 GE2 GE5 ; -> }T +\vf T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +\vf : GS1 S" SOURCE" 2DUP EVALUATE +\vf >R SWAP >R = R> R> = ; +\vf T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +\vf : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +\vf T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; \ vf: for CBM: s/BA/ba/ +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND \ vf: for CBM: s/41/C1/ + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +\vf No way found yet to inject key strokes into dosbox from Makefile. +\vf T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + diff --git a/8086/msdos/tests/coreacpt.fth b/8086/msdos/tests/coreacpt.fth new file mode 100644 index 0000000..d629533 --- /dev/null +++ b/8086/msdos/tests/coreacpt.fth @@ -0,0 +1,35 @@ +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +CR .( End of Core input word set tests) CR + + diff --git a/8086/msdos/tests/coreext.fth b/8086/msdos/tests/coreext.fth new file mode 100644 index 0000000..990ba89 --- /dev/null +++ b/8086/msdos/tests/coreext.fth @@ -0,0 +1,769 @@ +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING MARKER (contributed by James Bowman) + +\vf T{ : MA? BL WORD FIND NIP 0<> ; -> }T +\vf T{ MARKER MA0 -> }T +\vf T{ : MA1 111 ; -> }T +\vf T{ MARKER MA2 -> }T +\vf T{ : MA1 222 ; -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +\vf T{ MA1 MA2 MA1 -> 222 111 }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +\vf T{ MA0 -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING VALUE TO + +\vf T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +\vf T{ VAL1 -> 111 }T +\vf T{ VAL2 -> -999 }T +\vf T{ 222 TO VAL1 -> }T +\vf T{ VAL1 -> 222 }T +\vf T{ : VD1 VAL1 ; -> }T +\vf T{ VD1 -> 222 }T +\vf T{ : VD2 TO VAL2 ; -> }T +\vf T{ VAL2 -> -999 }T +\vf T{ -333 VD2 -> }T +\vf T{ VAL2 -> -333 }T +\vf T{ VAL1 -> 222 }T +\vf T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +\vf T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING CASE OF ENDOF ENDCASE + +\vf : CS1 CASE 1 OF 111 ENDOF +\vf 2 OF 222 ENDOF +\vf 3 OF 333 ENDOF +\vf >R 999 R> +\vf ENDCASE +\vf ; + +\vf T{ 1 CS1 -> 111 }T +\vf T{ 2 CS1 -> 222 }T +\vf T{ 3 CS1 -> 333 }T +\vf T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +\vf : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF +\vf 2 OF 200 ENDOF +\vf >R -300 R> +\vf ENDCASE +\vf ENDOF +\vf -2 OF CASE R@ 1 OF -99 ENDOF +\vf >R -199 R> +\vf ENDCASE +\vf ENDOF +\vf >R 299 R> +\vf ENDCASE R> DROP +\vf ; + +\vf T{ -1 1 CS2 -> 100 }T +\vf T{ -1 2 CS2 -> 200 }T +\vf T{ -1 3 CS2 -> -300 }T +\vf T{ -2 1 CS2 -> -99 }T +\vf T{ -2 2 CS2 -> -199 }T +\vf T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +\vf : CS3 ( N1 -- N2 ) +\vf CASE 1- FALSE OF 11 ENDOF +\vf 1- FALSE OF 22 ENDOF +\vf 1- FALSE OF 33 ENDOF +\vf 44 SWAP +\vf ENDCASE +\vf ; + +\vf T{ 1 CS3 -> 11 }T +\vf T{ 2 CS3 -> 22 }T +\vf T{ 3 CS3 -> 33 }T +\vf T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +\vf T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +\vf T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +\vf T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +\vf T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING :NONAME RECURSE + +\vf VARIABLE NN1 +\vf VARIABLE NN2 +\vf :NONAME 1234 ; NN1 ! +\vf :NONAME 9876 ; NN2 ! +\vf T{ NN1 @ EXECUTE -> 1234 }T +\vf T{ NN2 @ EXECUTE -> 9876 }T + +\vf T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; +\vf CONSTANT RN1 -> }T +\vf T{ 0 RN1 EXECUTE -> 0 }T +\vf T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +\vf :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition +\vf 1- DUP +\vf CASE 0 OF EXIT ENDOF +\vf 1 OF 11 SWAP RECURSE ENDOF +\vf 2 OF 22 SWAP RECURSE ENDOF +\vf 3 OF 33 SWAP RECURSE ENDOF +\vf DROP ABS RECURSE EXIT +\vf ENDCASE +\vf ; CONSTANT RN2 + +\vf T{ 1 RN2 EXECUTE -> 0 }T +\vf T{ 2 RN2 EXECUTE -> 11 0 }T +\vf T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +\vf T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING C" + +T{ : CQ1 C" 123" ; -> }T +\vf T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +\vf T{ CQ2 COUNT EVALUATE -> }T +\vf T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +\vf TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +\vf VARIABLE SI_INC 0 SI_INC ! + +\vf : SI1 +\vf SI_INC @ >IN +! +\vf 15 SI_INC ! +\vf ; + +\vf : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +\vf T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE + +\vf T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +\vf T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +\vf : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +\vf T{ PA1 3456 +\vf DUP ROT ROT EVALUATE -> 4 3456 }T +\vf T{ CHAR A PARSE A SWAP DROP -> 0 }T +\vf T{ CHAR Z PARSE +\vf SWAP DROP -> 0 }T +\vf T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests +\vf T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +\vf T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +\vf T{ PARSE-NAME +\vf NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +\vf T{ PARSE-NAME +\vf NIP -> 0 }T + +\vf T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) +\vf PARSE-NAME PARSE-NAME S= ; -> }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +\vf T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +\vf T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Parse to end of line +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +\vf T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +\vf T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +\vf T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +\vf T{ SSQ1 -> TRUE }T +\vf T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +\vf T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +\vf T{ SSQ3 SWAP DROP -> 20 }T \ String length +\vf T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +\vf T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +\vf T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +\vf T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +\vf T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +\vf T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +\vf T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +\vf T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +\vf T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +\vf T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +\vf T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +\vf T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +\vf T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +\vf T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +\vf T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +\vf T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +\vf T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +\vf T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +\vf T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +\vf T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +\vf CR .( The next test should display:) +\vf CR .( One line...) +\vf CR .( another line) +\vf T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +\vf T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +\vf T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +\vf T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +\vf T{ SSQ7 -> 111 222 333 }T +\vf T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +\vf T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/8086/msdos/tests/coreplus.fth b/8086/msdos/tests/coreplus.fth new file mode 100644 index 0000000..82b1be2 --- /dev/null +++ b/8086/msdos/tests/coreplus.fth @@ -0,0 +1,306 @@ +\ Additional tests on the the ANS Forth Core word set + +\ This program was written by Gerry Jackson in 2007, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ This file provides some more tests on Core words where the original Hayes +\ tests are thought to be incomplete +\ +\ Words tested in this file are: +\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> +\ and +\ Parsing behaviour +\ Number prefixes # $ % and 'A' character input +\ Definition names +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - core.fr has been loaded so that constants MAX-INT, MIN-INT and +\ MAX-UINT are defined +\ ------------------------------------------------------------------------------ + +DECIMAL + +TESTING DO +LOOP with run-time increment, negative increment, infinite loop +\ Contributed by Reinhold Straub + +VARIABLE ITERATIONS +VARIABLE INCREMENT +: GD7 ( LIMIT START INCREMENT -- ) + INCREMENT ! + 0 ITERATIONS ! + DO + 1 ITERATIONS +! + I + ITERATIONS @ 6 = IF LEAVE THEN + INCREMENT @ + +LOOP ITERATIONS @ +; + +T{ 4 4 -1 GD7 -> 4 1 }T +T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T +T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T +T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 GD7 -> 1 2 3 3 }T +T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T +T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 GD7 -> -1 0 1 3 }T +T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T +T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T +T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with large and small increments + +\ Contributed by Andrew Haley + +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T + +T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with maximum and minimum increments + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 -> 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T + +\ ------------------------------------------------------------------------------ +\ TESTING +LOOP setting I to an arbitrary value + +\ The specification for +LOOP permits the loop index I to be set to any value +\ including a value outside the range given to the corresponding DO. + +\ SET-I is a helper to set I in a DO ... +LOOP to a given value +\ n2 is the value of I in a DO ... +LOOP +\ n3 is a test value +\ If n2=n3 then return n1-n2 else return 1 +: SET-I ( n1 n2 n3 -- n1-n2 | 1 ) + OVER = IF - ELSE 2DROP 1 THEN +; + +: -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) + SET-I DUP 1 = IF NEGATE THEN +; + +: PL1 20 1 DO I 18 I 3 SET-I +LOOP ; +T{ PL1 -> 1 2 3 18 19 }T +: PL2 20 1 DO I 20 I 2 SET-I +LOOP ; +T{ PL2 -> 1 2 }T +: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; +T{ PL3 -> 5 6 0 1 2 19 }T +: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; +T{ PL4 -> 1 2 3 4 }T +: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; +T{ PL5 -> -1 -2 -3 -19 -20 }T +: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; +T{ PL6 -> -1 -2 -3 -4 }T +: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; +T{ PL7 -> -1 -2 -3 -4 -5 }T +: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; +T{ PL8 -> -5 -6 0 -1 -2 -20 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple RECURSEs in one colon definition + +: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code + OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 + SWAP 1- SWAP ( -- m-1 n ) + DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) + 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) +; + +T{ 0 0 ACK -> 1 }T +T{ 3 0 ACK -> 5 }T +T{ 2 4 ACK -> 11 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING multiple ELSE's in an IF statement +\ Discussed on comp.lang.forth and accepted as valid ANS Forth + +\vf : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; +\vf T{ 0 MELSE -> 2 4 }T +\vf T{ -1 MELSE -> 1 3 5 }T + +\ ------------------------------------------------------------------------------ +TESTING manipulation of >IN in interpreter mode + +T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T +T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T + +\ ------------------------------------------------------------------------------ +TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] + +T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T +T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T +T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T +T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T +T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T +T{ CREATE IW5 456 , IMMEDIATE -> }T +T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T +T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T +T{ 111 IW6 IW7 IW7 -> 112 }T +T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T +T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T +: FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) +T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate +T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate + +\ ------------------------------------------------------------------------------ +TESTING that IMMEDIATE doesn't toggle a flag + +VARIABLE IT1 0 IT1 ! +: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE +T{ : IT3 IT2 ; IT1 @ -> 1234 }T + +\ ------------------------------------------------------------------------------ +TESTING parsing behaviour of S" ." and ( +\ which should parse to just beyond the terminating character no space needed + +T{ : GC5 S" A string"2DROP ; GC5 -> }T +T{ ( A comment)1234 -> 1234 }T +T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T + +\ ------------------------------------------------------------------------------ +TESTING number prefixes # $ % and 'c' character input +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ &1289 -> 1289 }T \ vf: s/#/&/ +T{ -&1289 -> -1289 }T \ vf: s/#-/-&/ +T{ $12eF -> 4847 }T +T{ -$12eF -> -4847 }T \ vf: s/$-/-$/ +T{ %10010110 -> 150 }T +T{ -%10010110 -> -150 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 122 }T +\vf T{ 'Z' -> 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ &1289 -> 509 }T \ vf: s/#/&/ +T{ -&1289 -> -509 }T \ vf: s/#/&/ +T{ $12eF -> 12EF }T +T{ -$12eF -> -12EF }T \ vf: s/$-/-$/ +T{ %10010110 -> 96 }T +T{ -%10010110 -> -96 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 7a }T +\vf T{ 'Z' -> 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ s/'''/ascii '/ +T{ : nmp &8327 -$2cbe %011010111 ascii ' ; nmp -> 8327 -11454 215 39 }T + +\ ------------------------------------------------------------------------------ +TESTING definition names +\ should support {1..31} graphical characters +: !"#$%&'()*+,-./0123456789:;<=>? 1 ; +T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T +: @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; +T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T +: _`abcdefghijklmnopqrstuvwxyz{|} 3 ; +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T +: _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different +T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T + +\ ------------------------------------------------------------------------------ +TESTING FIND with a zero length string and a non-existent word + +CREATE EMPTYSTRING 0 C, +: EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) + DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN + 0= SWAP EMPTYSTRING = = ; +T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T + +CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth + 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, + CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, + CHAR $ C, CHAR $ C, +T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING IF ... BEGIN ... REPEAT (unstructured) + +\vf T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T +\vf T{ -6 UNS1 -> -6 }T +\vf T{ 1 UNS1 -> 9 4 }T + +\ ------------------------------------------------------------------------------ +TESTING DOES> doesn't cause a problem with a CREATEd address + +: MAKE-2CONST DOES> 2@ ; +T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T + +\ ------------------------------------------------------------------------------ +TESTING ALLOT ( n -- ) where n <= 0 + +T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T +T{ HERE 0 ALLOT HERE = -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of additional Core tests) CR diff --git a/8086/msdos/tests/doubltst.fth b/8086/msdos/tests/doubltst.fth new file mode 100644 index 0000000..0f3f3b3 --- /dev/null +++ b/8086/msdos/tests/doubltst.fth @@ -0,0 +1,438 @@ +\ To test the ANS Forth Double-Number word set and double number extensions + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct +\ ------------------------------------------------------------------------------ +\ Version 0.13 Assumptions and dependencies changed +\ 0.12 1 August 2015 test D< acts on MS cells of double word +\ 0.11 7 April 2015 2VALUE tested +\ 0.6 1 April 2012 Tests placed in the public domain. +\ Immediate 2CONSTANTs and 2VARIABLEs tested +\ 0.5 20 November 2009 Various constants renamed to avoid +\ redefinition warnings. and replaced +\ with TRUE and FALSE +\ 0.4 6 March 2009 { and } replaced with T{ and }T +\ Tests rewritten to be independent of word size and +\ tests re-ordered +\ 0.3 20 April 2007 ANS Forth words changed to upper case +\ 0.2 30 Oct 2006 Updated following GForth test to include +\ various constants from core.fr +\ 0.1 Oct 2006 First version released +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ 2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/ +\ D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU< +\ Also tests the interpreter and compiler reading a double number +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ ------------------------------------------------------------------------------ +\ Constant definitions + +DECIMAL +0 INVERT CONSTANT 1SD +1SD 1 RSHIFT CONSTANT MAX-INTD \ 01...1 +MAX-INTD INVERT CONSTANT MIN-INTD \ 10...0 +MAX-INTD 2/ CONSTANT HI-INT \ 001...1 +MIN-INTD 2/ CONSTANT LO-INT \ 110...1 + +\ ------------------------------------------------------------------------------ +TESTING interpreter and compiler reading double numbers, with/without prefixes + +T{ 1. -> 1 0 }T +T{ -2. -> -2 -1 }T +T{ : RDL1 3. ; RDL1 -> 3 0 }T +T{ : RDL2 -4. ; RDL2 -> -4 -1 }T + +VARIABLE OLD-DBASE +DECIMAL BASE @ OLD-DBASE ! +T{ &12346789. -> 12346789. }T \ vf: s/#/&/ +T{ -&12346789. -> -12346789. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 313249263. }T +T{ -$12AbCdEf. -> -313249263. }T \ vf: s/$-/-$/ +T{ %10010110. -> 150. }T +T{ -%10010110. -> -150. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-DBASE ! 16 BASE ! +T{ &12346789. -> BC65A5. }T \ vf: s/#/&/ +T{ -&12346789. -> -BC65A5. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 12AbCdeF. }T +T{ -$12AbCdEf. -> -12ABCDef. }T \ vf: s/$-/-$/ +T{ %10010110. -> 96. }T +T{ -%10010110. -> -96. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ +T{ : dnmp &8327. -$2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T + +\ ------------------------------------------------------------------------------ +TESTING 2CONSTANT + +T{ 1 2 2CONSTANT 2C1 -> }T +T{ 2C1 -> 1 2 }T +T{ : CD1 2C1 ; -> }T +T{ CD1 -> 1 2 }T +T{ : CD2 2CONSTANT ; -> }T +T{ -1 -2 CD2 2C2 -> }T +T{ 2C2 -> -1 -2 }T +T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T +T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T + +\ ------------------------------------------------------------------------------ +\ Some 2CONSTANTs for the following tests + +1SD MAX-INTD 2CONSTANT MAX-2INT \ 01...1 +0 MIN-INTD 2CONSTANT MIN-2INT \ 10...0 +MAX-2INT 2/ 2CONSTANT HI-2INT \ 001...1 +MIN-2INT 2/ 2CONSTANT LO-2INT \ 110...0 + +\ ------------------------------------------------------------------------------ +TESTING DNEGATE + +T{ 0. DNEGATE -> 0. }T +T{ 1. DNEGATE -> -1. }T +T{ -1. DNEGATE -> 1. }T +T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T +T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D+ with small integers + +T{ 0. 5. D+ -> 5. }T +T{ -5. 0. D+ -> -5. }T +T{ 1. 2. D+ -> 3. }T +T{ 1. -2. D+ -> -1. }T +T{ -1. 2. D+ -> 1. }T +T{ -1. -2. D+ -> -3. }T +T{ -1. 1. D+ -> 0. }T + +TESTING D+ with mid range integers + +T{ 0 0 0 5 D+ -> 0 5 }T +T{ -1 5 0 0 D+ -> -1 5 }T +T{ 0 0 0 -5 D+ -> 0 -5 }T +T{ 0 -5 -1 0 D+ -> -1 -5 }T +T{ 0 1 0 2 D+ -> 0 3 }T +T{ -1 1 0 -2 D+ -> -1 -1 }T +T{ 0 -1 0 2 D+ -> 0 1 }T +T{ 0 -1 -1 -2 D+ -> -1 -3 }T +T{ -1 -1 0 1 D+ -> -1 0 }T +T{ MIN-INTD 0 2DUP D+ -> 0 1 }T +T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T + +TESTING D+ with large double integers + +T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T +T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T +T{ MAX-2INT MIN-2INT D+ -> -1. }T +T{ MAX-2INT LO-2INT D+ -> HI-2INT }T +T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T +T{ LO-2INT 2DUP D+ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D- with small integers + +T{ 0. 5. D- -> -5. }T +T{ 5. 0. D- -> 5. }T +T{ 0. -5. D- -> 5. }T +T{ 1. 2. D- -> -1. }T +T{ 1. -2. D- -> 3. }T +T{ -1. 2. D- -> -3. }T +T{ -1. -2. D- -> 1. }T +T{ -1. -1. D- -> 0. }T + +TESTING D- with mid-range integers + +T{ 0 0 0 5 D- -> 0 -5 }T +T{ -1 5 0 0 D- -> -1 5 }T +T{ 0 0 -1 -5 D- -> 1 4 }T +T{ 0 -5 0 0 D- -> 0 -5 }T +T{ -1 1 0 2 D- -> -1 -1 }T +T{ 0 1 -1 -2 D- -> 1 2 }T +T{ 0 -1 0 2 D- -> 0 -3 }T +T{ 0 -1 0 -2 D- -> 0 1 }T +T{ 0 0 0 1 D- -> 0 -1 }T +T{ MIN-INTD 0 2DUP D- -> 0. }T +T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T + +TESTING D- with large integers + +T{ MAX-2INT MAX-2INT D- -> 0. }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MAX-2INT HI-2INT D- -> LO-2INT DNEGATE }T +T{ HI-2INT LO-2INT D- -> MAX-2INT }T +T{ LO-2INT HI-2INT D- -> MIN-2INT 1. D+ }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MIN-2INT LO-2INT D- -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D0< D0= + +T{ 0. D0< -> FALSE }T +T{ 1. D0< -> FALSE }T +T{ MIN-INTD 0 D0< -> FALSE }T +T{ 0 MAX-INTD D0< -> FALSE }T +T{ MAX-2INT D0< -> FALSE }T +T{ -1. D0< -> TRUE }T +T{ MIN-2INT D0< -> TRUE }T + +T{ 1. D0= -> FALSE }T +T{ MIN-INTD 0 D0= -> FALSE }T +T{ MAX-2INT D0= -> FALSE }T +T{ -1 MAX-INTD D0= -> FALSE }T +T{ 0. D0= -> TRUE }T +T{ -1. D0= -> FALSE }T +T{ 0 MIN-INTD D0= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING D2* D2/ + +T{ 0. D2* -> 0. D2* }T +T{ MIN-INTD 0 D2* -> 0 1 }T +T{ HI-2INT D2* -> MAX-2INT 1. D- }T +T{ LO-2INT D2* -> MIN-2INT }T + +T{ 0. D2/ -> 0. }T +T{ 1. D2/ -> 0. }T +T{ 0 1 D2/ -> MIN-INTD 0 }T +T{ MAX-2INT D2/ -> HI-2INT }T +T{ -1. D2/ -> -1. }T +T{ MIN-2INT D2/ -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D< D= + +T{ 0. 1. D< -> TRUE }T +T{ 0. 0. D< -> FALSE }T +T{ 1. 0. D< -> FALSE }T +T{ -1. 1. D< -> TRUE }T +T{ -1. 0. D< -> TRUE }T +T{ -2. -1. D< -> TRUE }T +T{ -1. -2. D< -> FALSE }T +T{ 0 1 1. D< -> FALSE }T \ Suggested by Helmut Eller +T{ 1. 0 1 D< -> TRUE }T +T{ 0 -1 1 -2 D< -> FALSE }T +T{ 1 -2 0 -1 D< -> TRUE }T +T{ -1. MAX-2INT D< -> TRUE }T +T{ MIN-2INT MAX-2INT D< -> TRUE }T +T{ MAX-2INT -1. D< -> FALSE }T +T{ MAX-2INT MIN-2INT D< -> FALSE }T +T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T +T{ MIN-2INT 2DUP 1. D+ D< -> TRUE }T +T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T \ Ensure D< acts on MS cells + +T{ -1. -1. D= -> TRUE }T +T{ -1. 0. D= -> FALSE }T +T{ -1. 1. D= -> FALSE }T +T{ 0. -1. D= -> FALSE }T +T{ 0. 0. D= -> TRUE }T +T{ 0. 1. D= -> FALSE }T +T{ 1. -1. D= -> FALSE }T +T{ 1. 0. D= -> FALSE }T +T{ 1. 1. D= -> TRUE }T + +T{ 0 -1 0 -1 D= -> TRUE }T +T{ 0 -1 0 0 D= -> FALSE }T +T{ 0 -1 0 1 D= -> FALSE }T +T{ 0 0 0 -1 D= -> FALSE }T +T{ 0 0 0 0 D= -> TRUE }T +T{ 0 0 0 1 D= -> FALSE }T +T{ 0 1 0 -1 D= -> FALSE }T +T{ 0 1 0 0 D= -> FALSE }T +T{ 0 1 0 1 D= -> TRUE }T + +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MAX-2INT 0. D= -> FALSE }T +T{ MAX-2INT MAX-2INT D= -> TRUE }T +T{ MAX-2INT HI-2INT D= -> FALSE }T +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MIN-2INT MIN-2INT D= -> TRUE }T +T{ MIN-2INT LO-2INT D= -> FALSE }T +T{ MIN-2INT MAX-2INT D= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING 2LITERAL 2VARIABLE + +T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T +T{ CD3 -> MAX-2INT }T +T{ 2VARIABLE 2V1 -> }T +T{ 0. 2V1 2! -> }T +T{ 2V1 2@ -> 0. }T +T{ -1 -2 2V1 2! -> }T +T{ 2V1 2@ -> -1 -2 }T +T{ : CD4 2VARIABLE ; -> }T +T{ CD4 2V2 -> }T +T{ : CD5 2V2 2! ; -> }T +T{ -2 -1 CD5 -> }T +T{ 2V2 2@ -> -2 -1 }T +T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T +T{ 2V3 2@ -> 5 6 }T +T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T +T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T + +\ ------------------------------------------------------------------------------ +TESTING DMAX DMIN + +T{ 1. 2. DMAX -> 2. }T +T{ 1. 0. DMAX -> 1. }T +T{ 1. -1. DMAX -> 1. }T +T{ 1. 1. DMAX -> 1. }T +T{ 0. 1. DMAX -> 1. }T +T{ 0. -1. DMAX -> 0. }T +T{ -1. 1. DMAX -> 1. }T +T{ -1. -2. DMAX -> -1. }T + +T{ MAX-2INT HI-2INT DMAX -> MAX-2INT }T +T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT LO-2INT DMAX -> LO-2INT }T + +T{ MAX-2INT 1. DMAX -> MAX-2INT }T +T{ MAX-2INT -1. DMAX -> MAX-2INT }T +T{ MIN-2INT 1. DMAX -> 1. }T +T{ MIN-2INT -1. DMAX -> -1. }T + + +T{ 1. 2. DMIN -> 1. }T +T{ 1. 0. DMIN -> 0. }T +T{ 1. -1. DMIN -> -1. }T +T{ 1. 1. DMIN -> 1. }T +T{ 0. 1. DMIN -> 0. }T +T{ 0. -1. DMIN -> -1. }T +T{ -1. 1. DMIN -> -1. }T +T{ -1. -2. DMIN -> -2. }T + +T{ MAX-2INT HI-2INT DMIN -> HI-2INT }T +T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT LO-2INT DMIN -> MIN-2INT }T + +T{ MAX-2INT 1. DMIN -> 1. }T +T{ MAX-2INT -1. DMIN -> -1. }T +T{ MIN-2INT 1. DMIN -> MIN-2INT }T +T{ MIN-2INT -1. DMIN -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D>S DABS + +T{ 1234 0 D>S -> 1234 }T +T{ -1234 -1 D>S -> -1234 }T +T{ MAX-INTD 0 D>S -> MAX-INTD }T +T{ MIN-INTD -1 D>S -> MIN-INTD }T + +T{ 1. DABS -> 1. }T +T{ -1. DABS -> 1. }T +T{ MAX-2INT DABS -> MAX-2INT }T +T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING M+ M*/ + +T{ HI-2INT 1 M+ -> HI-2INT 1. D+ }T +T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T +T{ MIN-2INT 1 M+ -> MIN-2INT 1. D+ }T +T{ LO-2INT -1 M+ -> LO-2INT -1. D+ }T + +\ To correct the result if the division is floored, only used when +\ necessary i.e. negative quotient and remainder <> 0 + +: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ; + +\vf T{ 5. 7 11 M*/ -> 3. }T +\vf T{ 5. -7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. 7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. -7 11 M*/ -> 3. }T +\vf T{ MAX-2INT 8 16 M*/ -> HI-2INT }T +\vf T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T \ FLOORED SUBTRACT 1 +\vf T{ MIN-2INT 8 16 M*/ -> LO-2INT }T +\vf T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T +\vf T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T +\vf T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T +\vf T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T +\vf T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T +\vf T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T +\vf T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +\vf TESTING D. D.R + +\ Create some large double numbers +\vf MAX-2INT 71 73 M*/ 2CONSTANT DBL1 +\vf MIN-2INT 73 79 M*/ 2CONSTANT DBL2 + +\vf : D>ASCII ( D -- CADDR U ) +\vf DUP >R <# DABS #S R> SIGN #> ( -- CADDR1 U ) +\vf HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R> +\vf ; + +\vf DBL1 D>ASCII 2CONSTANT "DBL1" +\vf DBL2 D>ASCII 2CONSTANT "DBL2" + +\vf : DOUBLEOUTPUT +\vf CR ." You should see lines duplicated:" CR +\vf 5 SPACES "DBL1" TYPE CR +\vf 5 SPACES DBL1 D. CR +\vf 8 SPACES "DBL1" DUP >R TYPE CR +\vf 5 SPACES DBL1 R> 3 + D.R CR +\vf 5 SPACES "DBL2" TYPE CR +\vf 5 SPACES DBL2 D. CR +\vf 10 SPACES "DBL2" DUP >R TYPE CR +\vf 5 SPACES DBL2 R> 5 + D.R CR +\vf ; + +\vf T{ DOUBLEOUTPUT -> }T + +\ ------------------------------------------------------------------------------ +TESTING 2ROT DU< (Double Number extension words) + +T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T +T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T + +\vf T{ 1. 1. DU< -> FALSE }T +\vf T{ 1. -1. DU< -> TRUE }T +\vf T{ -1. 1. DU< -> FALSE }T +\vf T{ -1. -2. DU< -> FALSE }T +\vf T{ 0 1 1. DU< -> FALSE }T +\vf T{ 1. 0 1 DU< -> TRUE }T +\vf T{ 0 -1 1 -2 DU< -> FALSE }T +\vf T{ 1 -2 0 -1 DU< -> TRUE }T + +\vf T{ MAX-2INT HI-2INT DU< -> FALSE }T +\vf T{ HI-2INT MAX-2INT DU< -> TRUE }T +\vf T{ MAX-2INT MIN-2INT DU< -> TRUE }T +\vf T{ MIN-2INT MAX-2INT DU< -> FALSE }T +\vf T{ MIN-2INT LO-2INT DU< -> TRUE }T + +\ ------------------------------------------------------------------------------ +\vf TESTING 2VALUE + +\vf T{ 1111 2222 2VALUE 2VAL -> }T +\vf T{ 2VAL -> 1111 2222 }T +\vf T{ 3333 4444 TO 2VAL -> }T +\vf T{ 2VAL -> 3333 4444 }T +\vf T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T +\vf T{ 2VAL -> 5555 6666 }T + +\ ------------------------------------------------------------------------------ + +DOUBLE-ERRORS SET-ERROR-COUNT + +CR .( End of Double-Number word tests) CR + diff --git a/8086/msdos/tests/empty.fb b/8086/msdos/tests/empty.fb new file mode 100644 index 0000000..f5b7445 --- /dev/null +++ b/8086/msdos/tests/empty.fb @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/8086/msdos/tests/errorrep.fth b/8086/msdos/tests/errorrep.fth new file mode 100644 index 0000000..24e7bd1 --- /dev/null +++ b/8086/msdos/tests/errorrep.fth @@ -0,0 +1,88 @@ +\ To collect and report on the number of errors resulting from running the +\ ANS Forth and Forth 2012 test programs + +\ This program was written by Gerry Jackson in 2015, and is in the public +\ domain - it can be distributed and/or modified in any way but please +\ retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ ------------------------------------------------------------------------------ +\ This file is INCLUDED after Core tests are complete and only uses Core words +\ already tested. The purpose of this file is to count errors in test results +\ and present them as a summary at the end of the tests. + +DECIMAL + +VARIABLE TOTAL-ERRORS + +: ERROR-COUNT ( "name" n1 -- n2 ) \ n2 = n1 + 1cell + CREATE DUP , CELL+ + DOES> ( -- offset ) @ \ offset in address units +; + +0 \ Offset into ERRORS[] array +ERROR-COUNT CORE-ERRORS ERROR-COUNT CORE-EXT-ERRORS +ERROR-COUNT DOUBLE-ERRORS ERROR-COUNT EXCEPTION-ERRORS +ERROR-COUNT FACILITY-ERRORS ERROR-COUNT FILE-ERRORS +ERROR-COUNT LOCALS-ERRORS ERROR-COUNT MEMORY-ERRORS +ERROR-COUNT SEARCHORDER-ERRORS ERROR-COUNT STRING-ERRORS +ERROR-COUNT TOOLS-ERRORS ERROR-COUNT BLOCK-ERRORS +CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS + +\ SET-ERROR-COUNT called at the end of each test file with its own offset into +\ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs + +: SET-ERROR-COUNT ( offset -- ) + #ERRORS @ SWAP ERRORS[] + ! + #ERRORS @ TOTAL-ERRORS +! + 0 #ERRORS ! +; + +: INIT-ERRORS ( -- ) + ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP + 0 TOTAL-ERRORS ! + CORE-ERRORS SET-ERROR-COUNT +; + +INIT-ERRORS + +\ Report summary of errors + +25 CONSTANT MARGIN + +: SHOW-ERROR-LINE ( n caddr u -- ) + CR SWAP OVER TYPE MARGIN - ABS >R + DUP -1 = IF DROP R> 1- SPACES ." -" ELSE + R> .R THEN +; + +: SHOW-ERROR-COUNT ( caddr u offset -- ) + ERRORS[] + @ ROT ROT SHOW-ERROR-LINE +; + +: HLINE ( -- ) CR ." ---------------------------" ; + +: REPORT-ERRORS + HLINE + CR 8 SPACES ." Error Report" + CR ." Word Set" 13 SPACES ." Errors" + HLINE + S" Core" CORE-ERRORS SHOW-ERROR-COUNT + S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT + S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT + S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT + S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT + S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT + S" File-access" FILE-ERRORS SHOW-ERROR-COUNT + S" Locals" LOCALS-ERRORS SHOW-ERROR-COUNT + S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT + S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT + S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT + S" String" STRING-ERRORS SHOW-ERROR-COUNT + HLINE + TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE + HLINE CR CR +; diff --git a/8086/msdos/tests/evaluate-test.sh b/8086/msdos/tests/evaluate-test.sh new file mode 100755 index 0000000..144f661 --- /dev/null +++ b/8086/msdos/tests/evaluate-test.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +testsdir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" +basedir="$(realpath --relative-to="$PWD" "${testsdir}/..")" + +testname="$1" + +diff --ignore-trailing-space "${basedir}/${testname}.golden" \ + "${basedir}/${testname}.log" > tmp.result +exitcode=$? +test $exitcode -eq 0 \ + && echo "PASS: ${testname}" >> tmp.result \ + || echo "FAIL: ${testname}" >> tmp.result +cat tmp.result +mv tmp.result "${basedir}/${testname}.result" +exit $exitcode diff --git a/8086/msdos/tests/golden/block.golden b/8086/msdos/tests/golden/block.golden new file mode 100644 index 0000000..d241942 --- /dev/null +++ b/8086/msdos/tests/golden/block.golden @@ -0,0 +1,89 @@ + FLUSH exists +BLOCK.FTH **=== NOT TESTED === ******* Scr 21 Dr 5 EMPTY.FB + 0 Should show a (mostly) blank screen + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 20 Dr 5 EMPTY.FB + 0 List of the First test block + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 29 Dr 5 EMPTY.FB + 0 List of the Last test block + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 25 Dr 5 EMPTY.FB + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 End of Screen + Scr 21 Dr 5 EMPTY.FB + 0 Should show another (mostly) blank screen + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +*** | exists Given Characters per Line: 64 +* +End of Block word tests diff --git a/8086/msdos/tests/golden/core.golden b/8086/msdos/tests/golden/core.golden new file mode 100644 index 0000000..607d2cd --- /dev/null +++ b/8086/msdos/tests/golden/core.golden @@ -0,0 +1,23 @@ + +TESTER.FTH ERROR exists +CORE.FR +*********************YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS: + !"#$%&'()*+,-./0123456789:;<=>?@ +ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_` +abcdefghijklmnopqrstuvwxyz{|}~ +YOU SHOULD SEE 0-9 SEPARATED BY A SPACE: +0 1 2 3 4 5 6 7 8 9 +YOU SHOULD SEE 0-9 (WITH NO SPACES): +0123456789 +YOU SHOULD SEE A-G SEPARATED BY A SPACE: +A B C D E F G +YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES: +0 1 2 3 4 5 +YOU SHOULD SEE TWO SEPARATE LINES: +LINE 1 +LINE 2 +YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS: + SIGNED: -8000 7FFF +UNSIGNED: 0 FFFF +** GDX exists +End of Core word set tests diff --git a/8086/msdos/tests/golden/coreext.golden b/8086/msdos/tests/golden/coreext.golden new file mode 100644 index 0000000..4b81e2d --- /dev/null +++ b/8086/msdos/tests/golden/coreext.golden @@ -0,0 +1,52 @@ + +UTIL.FTH ?DEFTEST1 exists +Test utilities loaded + +ERRORREP.FTH +COREEXT.FTH ************** + +Output from .( +You should see -9876: -9876 +and again: -9876 + + +On the next 2 lines you should see First then Second messages: +First message via .( +Second message via ." + +* + +Output from .R and U.R +You should see lines duplicated: +indented by 0 spaces +30278 +30278 +-31871 +-31871 +30278 +30278 +33665 +33665 + +indented by 0 spaces +30278 +30278 +-31871 +-31871 +30278 +30278 +33665 +33665 + +indented by 5 spaces + 30278 + 30278 + -31871 + -31871 + 30278 + 30278 + 33665 + 33665 + +*** +End of Core Extension word tests diff --git a/8086/msdos/tests/golden/coreplus.golden b/8086/msdos/tests/golden/coreplus.golden new file mode 100644 index 0000000..0c3fde5 --- /dev/null +++ b/8086/msdos/tests/golden/coreplus.golden @@ -0,0 +1,5 @@ + +COREPLUS.FTH ******** +You should see 2345: 2345 +***** +End of additional Core tests diff --git a/8086/msdos/tests/golden/doubltst.golden b/8086/msdos/tests/golden/doubltst.golden new file mode 100644 index 0000000..146428f --- /dev/null +++ b/8086/msdos/tests/golden/doubltst.golden @@ -0,0 +1,3 @@ + +DOUBLTST.FTH ***************** +End of Double-Number word tests diff --git a/8086/msdos/tests/golden/incltest.golden b/8086/msdos/tests/golden/incltest.golden new file mode 100644 index 0000000..eb978d3 --- /dev/null +++ b/8086/msdos/tests/golden/incltest.golden @@ -0,0 +1,2 @@ +hello, world +hello, world, from test-hello diff --git a/8086/msdos/tests/golden/logtest.golden b/8086/msdos/tests/golden/logtest.golden new file mode 100644 index 0000000..6000c89 --- /dev/null +++ b/8086/msdos/tests/golden/logtest.golden @@ -0,0 +1 @@ +logtest done diff --git a/8086/msdos/tests/golden/prelim.golden b/8086/msdos/tests/golden/prelim.golden new file mode 100644 index 0000000..d381a31 --- /dev/null +++ b/8086/msdos/tests/golden/prelim.golden @@ -0,0 +1,41 @@ + +ANS-SHIM.FTH +PRELIM.FTH + +CR CR SOURCE TYPE ( Preliminary test ) CR +SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR +( The next line of output should be blank to test CR ) SOURCE TYPE CR CR + +( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR +( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR +( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR +( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR +( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR +( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC +( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC +( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC +( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC +( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC +Pass #11: testing WORD COUNT .MSG +Pass #12: testing = returns all 1's for true +Pass #13: testing = returns 0 for false +Pass #14: testing -1 interpreted correctly +Pass #15: testing 2* +Pass #16: testing 2* +Pass #17: testing AND +Pass #18: testing AND +Pass #19: testing AND +Pass #20: testing ?F~ ?~~ Pass Error +Pass #21: testing ?~ +Pass #22: testing EMIT +Pass #23: testing S" + +Results: + +Pass messages #1 to #23 should be displayed above +and no error messages + +0 tests failed out of 57 additional tests + + +--- End of Preliminary Tests --- diff --git a/8086/msdos/tests/golden/report-blk.golden b/8086/msdos/tests/golden/report-blk.golden new file mode 100644 index 0000000..80361e9 --- /dev/null +++ b/8086/msdos/tests/golden/report-blk.golden @@ -0,0 +1,21 @@ + +--------------------------- + Error Report +Word Set Errors +--------------------------- +Core 0 +Core extension 0 +Block 0 +Double number 0 +Exception - +Facility - +File-access - +Locals - +Memory-allocation - +Programming-tools - +Search-order - +String - +--------------------------- +Total 0 +--------------------------- + diff --git a/8086/msdos/tests/golden/report-noblk.golden b/8086/msdos/tests/golden/report-noblk.golden new file mode 100644 index 0000000..acdc397 --- /dev/null +++ b/8086/msdos/tests/golden/report-noblk.golden @@ -0,0 +1,21 @@ + +--------------------------- + Error Report +Word Set Errors +--------------------------- +Core 0 +Core extension 0 +Block - +Double number 0 +Exception - +Facility - +File-access - +Locals - +Memory-allocation - +Programming-tools - +Search-order - +String - +--------------------------- +Total 0 +--------------------------- + diff --git a/8086/msdos/tests/golden/volks4th-prelim.golden b/8086/msdos/tests/golden/volks4th-prelim.golden new file mode 100644 index 0000000..cd2bedb --- /dev/null +++ b/8086/msdos/tests/golden/volks4th-prelim.golden @@ -0,0 +1,41 @@ + +ANS-SHIM.FTH +PRELIM.FTH + +CR CR SOURCE TYPE ( Preliminary test ) CR +SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR +( The next line of output should be blank to test CR ) SOURCE TYPE CR CR + +( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR +( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR +( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR +( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR +( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR +( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC +( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC +( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC +( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC +( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC +Pass #11: testing WORD COUNT .MSG +Pass #12: testing = returns all 1's for true +Pass #13: testing = returns 0 for false +Pass #14: testing -1 interpreted correctly +Pass #15: testing 2* +Pass #16: testing 2* +Pass #17: testing AND +Pass #18: testing AND +Pass #19: testing AND + PASS exists Pass #20: testing ?F~ ?~~ Pass Error +Pass #21: testing ?~ +Pass #22: testing EMIT +Pass #23: testing S" + +Results: + +Pass messages #1 to #23 should be displayed above +and no error messages + +0 tests failed out of 57 additional tests + + +--- End of Preliminary Tests --- diff --git a/8086/msdos/tests/incltest.fth b/8086/msdos/tests/incltest.fth new file mode 100644 index 0000000..02da693 --- /dev/null +++ b/8086/msdos/tests/incltest.fth @@ -0,0 +1,10 @@ + +\needs (type include extend.fb include multi.vid include dos.fb +include log2file.fb +logopen output.log + +.( hello, world) cr +: test-hello ." hello, world, from test-hello" cr ; +test-hello + +logclose diff --git a/8086/msdos/tests/log2file.fb b/8086/msdos/tests/log2file.fb new file mode 100644 index 0000000..4223291 --- /dev/null +++ b/8086/msdos/tests/log2file.fb @@ -0,0 +1 @@ +\ logging to a text file phz 03jan22 \ load screen phz 25feb22 Code m+! ( 16b addr -- ) D W mov W inc W inc A pop A W ) add CS ?[ W dec W dec W ) inc ]? D pop Next end-code : (blk blk @ 0= IF ascii ) parse 2drop THEN ; (blk 1 2 +thru ( ) \ log-type log-emit log-cr phz 25feb22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb variable logpos 0 , : log-type ( addr count -- ) dup logpos m+! 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit ( char -- ) 1 logpos m+! dup (emit logfcb @ fputc ; : log-cr ( -- ) 2 logpos m+! (cr #cr logfcb @ fputc #lf logfcb @ fputc ; \ alsologtofile logopen logclose logreopen phz 25feb22 Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; : logopen ( -- ) isfile push logpos dup 2+ off off logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; : logreopen ( -- ) logfcb @ freset logpos 2@ logfcb @ fseek alsologtofile ; \ phz 25feb22 \ No newline at end of file diff --git a/8086/msdos/tests/log2file.fth b/8086/msdos/tests/log2file.fth new file mode 100644 index 0000000..dffcb3f --- /dev/null +++ b/8086/msdos/tests/log2file.fth @@ -0,0 +1,114 @@ + +\ *** Block No. 0, Hexblock 0 + +\ logging to a text file phz 03jan22 + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ load screen phz 25feb22 + + Code m+! ( 16b addr -- ) + D W mov W inc W inc A pop A W ) add + CS ?[ W dec W dec W ) inc ]? + D pop Next end-code + + + : (blk blk @ 0= IF ascii ) parse 2drop THEN ; + + (blk 1 2 +thru ( ) + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ log-type log-emit log-cr phz 25feb22 + context @ dos also context ! +\ vocabulary log dos also log definitions + file logfile + variable logfcb + variable logpos 0 , + + : log-type ( addr count -- ) dup logpos m+! + 2dup (type ds@ -rot logfcb @ lfputs ; + + : log-emit ( char -- ) 1 logpos m+! + dup (emit logfcb @ fputc ; + + : log-cr ( -- ) 2 logpos m+! + (cr #cr logfcb @ fputc #lf logfcb @ fputc ; + + +\ *** Block No. 3, Hexblock 3 + +\ alsologtofile logopen logclose logreopen phz 25feb22 + +Output: alsologtofile + log-emit log-cr log-type (del (page (at (at? ; + + : logopen ( -- ) + isfile push logpos dup 2+ off off + logfile make isfile@ dup freset logfcb ! + alsologtofile ; + + : logclose ( -- ) display logfcb @ fclose ; + + : logreopen ( -- ) + logfcb @ freset logpos 2@ logfcb @ fseek + alsologtofile ; + + +\ *** Block No. 4, Hexblock 4 + +\ phz 25feb22 + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/tests/logapp.fth b/8086/msdos/tests/logapp.fth new file mode 100644 index 0000000..39cdc5b --- /dev/null +++ b/8086/msdos/tests/logapp.fth @@ -0,0 +1,78 @@ + + +\ Experimental code and test for text logs that can be closed +\ and reopened for appending. +\ Already integrated into log2file.fb/.fth +\ Yet to be done: A more permanent test for m+! +\ and an extension of logtest.fb/.fth to also cover the reopen feature. + + +\ Code +! ( 16b addr -- ) +\ D W mov A pop A W ) add D pop Next end-code + + Code m+! ( 16b addr -- ) + D W mov W inc W inc A pop A W ) add + CS ?[ W dec W dec W ) inc ]? + D pop Next end-code + + + + + +\ *** Block No. 2, Hexblock 2 + +\ log-type log-emit log-cr alsologtofile phz 04jan22 + context @ dos also context ! +\ vocabulary log dos also log definitions + file logfile + variable logfcb + variable logpos 0 , + + : log-type + dup logpos m+! + 2dup (type ds@ -rot logfcb @ lfputs ; + + : log-emit + 1 logpos m+! + dup (emit logfcb @ fputc ; + + : log-cr + 2 logpos m+! + (cr #cr logfcb @ fputc #lf logfcb @ fputc ; + +Output: alsologtofile + log-emit log-cr log-type (del (page (at (at? ; + + + +\ *** Block No. 3, Hexblock 3 + +\ logopen logclose phz 11jan22 + + : logopen ( -- ) + isfile push logpos dup 2+ off off + logfile make isfile@ dup freset logfcb ! + alsologtofile ; + + : logclose ( -- ) display logfcb @ fclose ; + + : logreopen ( -- ) + logfcb @ freset logpos 2@ logfcb @ fseek + alsologtofile ; + + logopen output.log + .( logtest started) cr + logpos @ cr u. cr + .( logtest interrupted) cr + logclose + logreopen + create 2v 4 allot + hex + 12345. 2v 2! + 1 2v m+! + 2v 2@ d. cr + 1ffff. 2v 2! + 1 2v m+! + 2v 2@ d. cr + .( logtest done) cr + logclose diff --git a/8086/msdos/tests/logprep.fth b/8086/msdos/tests/logprep.fth new file mode 100644 index 0000000..4e4e3d6 --- /dev/null +++ b/8086/msdos/tests/logprep.fth @@ -0,0 +1,14 @@ + + include extend2.fth +\needs drv : drv 2 ; \ showing C: if drv isn't defined + include multivid.fth + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +\ ' .blk|tib Is .status + +\ include dos2.fth + include dos3.fth + include log2file.fth diff --git a/8086/msdos/tests/logtest.fb b/8086/msdos/tests/logtest.fb new file mode 100644 index 0000000..9db9527 --- /dev/null +++ b/8086/msdos/tests/logtest.fb @@ -0,0 +1 @@ +\ logtest.fb phz 04jan22 basic tests for log2file.fb \ loadscreen phz 22jan22 include log2file.fb logopen output.log .( logtest done) cr logclose \ No newline at end of file diff --git a/8086/msdos/tests/logtest.fth b/8086/msdos/tests/logtest.fth new file mode 100644 index 0000000..57a43d0 --- /dev/null +++ b/8086/msdos/tests/logtest.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ logtest.fb phz 04jan22 + + basic tests for log2file.fb + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen phz 22jan22 + + include log2file.fb + + logopen output.log + .( logtest done) cr + logclose + + + + + + + + + diff --git a/8086/msdos/tests/prelim.fth b/8086/msdos/tests/prelim.fth new file mode 100644 index 0000000..8ca9ef5 --- /dev/null +++ b/8086/msdos/tests/prelim.fth @@ -0,0 +1,233 @@ +CR CR SOURCE TYPE ( Preliminary test ) CR +SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR +( The next line of output should be blank to test CR ) SOURCE TYPE CR CR + +( It is now assumed that SOURCE, TYPE, CR and comments work. SOURCE and ) +( TYPE will be used to report test passes until something better can be ) +( defined to report errors. Until then reporting failures will depend on the ) +( system under test and will usually be via reporting an unrecognised word ) +( or possibly the system crashing. Tests will be numbered by #n from now on ) +( to assist fault finding. Test successes will be indicated by ) +( 'Pass: #n ...' and failures by 'Error: #n ...' ) + +( Initial tests of >IN +! and 1+ ) +( Check that n >IN +! acts as an interpretive IF, where n >= 0 ) +( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR +( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR +( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR + +( Test results can now be reported using the >IN +! trick to skip ) +( 1 or more characters ) + +( The value of BASE is unknown so it is not safe to use digits > 1, therefore ) +( it will be set it to binary and then decimal, this also tests @ and ! ) + +( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR +( Set BASE to decimal ) 1010 BASE ! +( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR + +( Now in decimal mode and digits >1 can be used ) + +( A better error reporting word is needed, much like .( which can't ) +( be used as it is in the Core Extension word set, similarly PARSE can't be ) +( used either, only WORD is available to parse a message and must be used ) +( in a colon definition. Therefore a simple colon definition is tested next ) + +( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC +( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC + +( VARIABLE is now tested as one will be used instead of DROP e.g. Y ! ) + +( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC + +: MSG 41 WORD COUNT ; ( 41 is the ASCII code for right parenthesis ) +( The next tests MSG leaves 2 items on the data stack ) +( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC +( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC + +( For reporting success .MSG( is now defined ) +: .MSG( MSG TYPE ; .MSG( Pass #11: testing WORD COUNT .MSG) CR + +( To define an error reporting word, = 2* AND will be needed, test them first ) +( This assumes 2's complement arithmetic ) +1 1 = 1+ 1+ >IN +! x.MSG( Pass #12: testing = returns all 1's for true) CR +1 0 = 1+ >IN +! x.MSG( Pass #13: testing = returns 0 for false) CR +1 1 = -1 = 1+ 1+ >IN +! x.MSG( Pass #14: testing -1 interpreted correctly) CR + +1 2* >IN +! xx.MSG( Pass #15: testing 2*) CR +-1 2* 1+ 1+ 1+ >IN +! x.MSG( Pass #16: testing 2*) CR + +-1 -1 AND 1+ 1+ >IN +! x.MSG( Pass #17: testing AND) CR +-1 0 AND 1+ >IN +! x.MSG( Pass #18: testing AND) CR +6 -1 AND >IN +! xxxxxx.MSG( Pass #19: testing AND) CR + +( Define ~ to use as a 'to end of line' comment. \ cannot be used as it a ) +( Core Extension word ) +: ~ ( -- ) SOURCE >IN ! Y ! ; + +( Rather than relying on a pass message test words can now be defined to ) +( report errors in the event of a failure. For convenience words ?T~ and ) +( ?F~ are defined together with a helper ?~~ to test for TRUE and FALSE ) +( Usage is: ?T~ Error #n: ) +( Success makes >IN index the ~ in ?T~ or ?F~ to skip the error message. ) +( Hence it is essential there is only 1 space between ?T~ and Error ) + +: ?~~ ( -1 | 0 -- ) 2* >IN +! ; +: ?F~ ( f -- ) 0 = ?~~ ; +: ?T~ ( f -- ) -1 = ?~~ ; + +( Errors will be counted ) +VARIABLE #ERRS 0 #ERRS ! +: Error 1 #ERRS +! -6 >IN +! .MSG( CR ; +: Pass -1 #ERRS +! 1 >IN +! Error ; ~ Pass is defined solely to test Error + +-1 ?F~ Pass #20: testing ?F~ ?~~ Pass Error +-1 ?T~ Error #1: testing ?T~ ?~~ ~ + +0 0 = 0= ?F~ Error #2: testing 0= +1 0 = 0= ?T~ Error #3: testing 0= +-1 0 = 0= ?T~ Error #4: testing 0= + +0 0 = ?T~ Error #5: testing = +0 1 = ?F~ Error #6: testing = +1 0 = ?F~ Error #7: testing = +-1 1 = ?F~ Error #8: testing = +1 -1 = ?F~ Error #9: testing = + +-1 0< ?T~ Error #10: testing 0< +0 0< ?F~ Error #11: testing 0< +1 0< ?F~ Error #12: testing 0< + + DEPTH 1+ DEPTH = ?~~ Error #13: testing DEPTH + ~ Up to now whether the data stack was empty or not hasn't mattered as + ~ long as it didn't overflow. Now it will be emptied - also + ~ removing any unreported underflow + DEPTH 0< 0= 1+ >IN +! ~ 0 0 >IN ! Remove any underflow + DEPTH 0= 1+ >IN +! ~ Y ! 0 >IN ! Empty the stack + DEPTH 0= ?T~ Error #14: data stack not emptied + + 4 -5 SWAP 4 = SWAP -5 = = ?T~ Error #15: testing SWAP + 111 222 333 444 + DEPTH 4 = ?T~ Error #16: testing DEPTH + 444 = SWAP 333 = = DEPTH 3 = = ?T~ Error #17: testing SWAP DEPTH + 222 = SWAP 111 = = DEPTH 1 = = ?T~ Error #18: testing SWAP DEPTH + DEPTH 0= ?T~ Error #19: testing DEPTH = 0 + +~ From now on the stack is expected to be empty after a test so +~ ?~ will be defined to include a check on the stack depth. Note +~ that ?~~ was defined and used earlier instead of ?~ to avoid +~ (irritating) redefinition messages that many systems display had +~ ?~ simply been redefined + +: ?~ ( -1 | 0 -- ) DEPTH 1 = AND ?~~ ; ~ -1 test success, 0 test failure + +123 -1 ?~ Pass #21: testing ?~ +Y ! ~ equivalent to DROP + +~ Testing the remaining Core words used in the Hayes tester, with the above +~ definitions these are straightforward + +1 DROP DEPTH 0= ?~ Error #20: testing DROP +123 DUP = ?~ Error #21: testing DUP +123 ?DUP = ?~ Error #22: testing ?DUP +0 ?DUP 0= ?~ Error #23: testing ?DUP +123 111 + 234 = ?~ Error #24: testing + +123 -111 + 12 = ?~ Error #25: testing + +-123 111 + -12 = ?~ Error #26: testing + +-123 -111 + -234 = ?~ Error #27: testing + +-1 NEGATE 1 = ?~ Error #28: testing NEGATE +0 NEGATE 0= ?~ Error #29: testing NEGATE +987 NEGATE -987 = ?~ Error #30: testing NEGATE +HERE DEPTH SWAP DROP 1 = ?~ Error #31: testing HERE +CREATE TST1 HERE TST1 = ?~ Error #32: testing CREATE HERE +16 ALLOT HERE TST1 NEGATE + 16 = ?~ Error #33: testing ALLOT +-16 ALLOT HERE TST1 = ?~ Error #34: testing ALLOT +0 CELLS 0= ?~ Error #35: testing CELLS +1 CELLS ALLOT HERE TST1 NEGATE + VARIABLE CSZ CSZ ! +CSZ @ 0= 0= ?~ Error #36: testing CELLS +3 CELLS CSZ @ DUP 2* + = ?~ Error #37: testing CELLS +-3 CELLS CSZ @ DUP 2* + + 0= ?~ Error #38: testing CELLS +: TST2 ( f -- n ) DUP IF 1+ THEN ; +0 TST2 0= ?~ Error #39: testing IF THEN +1 TST2 2 = ?~ Error #40: testing IF THEN +: TST3 ( n1 -- n2 ) IF 123 ELSE 234 THEN ; +0 TST3 234 = ?~ Error #41: testing IF ELSE THEN +1 TST3 123 = ?~ Error #42: testing IF ELSE THEN +: TST4 ( -- n ) 0 5 0 DO 1+ LOOP ; +TST4 5 = ?~ Error #43: testing DO LOOP +: TST5 ( -- n ) 0 10 0 DO I + LOOP ; +TST5 45 = ?~ Error #44: testing I +: TST6 ( -- n ) 0 10 0 DO DUP 5 = IF LEAVE ELSE 1+ THEN LOOP ; +TST6 5 = ?~ Error #45: testing LEAVE +: TST7 ( -- n1 n2 ) 123 >R 234 R> ; +TST7 NEGATE + 111 = ?~ Error #46: testing >R R> +: TST8 ( -- ch ) [CHAR] A ; +TST8 65 = ?~ Error #47: testing [CHAR] +: TST9 ( -- ) [CHAR] s [CHAR] s [CHAR] a [CHAR] P 4 0 DO EMIT LOOP ; +TST9 .MSG( #22: testing EMIT) CR +: TST10 ( -- ) S" Pass #23: testing S" TYPE [CHAR] " EMIT CR ; TST10 + +~ The Hayes core test core.fr uses CONSTANT before it is tested therefore +~ we test CONSTANT here + +1234 CONSTANT CTEST +CTEST 1234 = ?~ Error #48: testing CONSTANT + +~ The Hayes tester uses some words from the Core extension word set +~ These will be conditionally defined following definition of a +~ word called ?DEFINED to determine whether these are already defined + +VARIABLE TIMM1 0 TIMM1 ! +: TIMM2 123 TIMM1 ! ; IMMEDIATE +: TIMM3 TIMM2 ; TIMM1 @ 123 = ?~ Error #49: testing IMMEDIATE + +: ?DEFINED ( "name" -- 0 | -1 ) 32 WORD FIND SWAP DROP 0= 0= ; +?DEFINED SWAP ?~ Error #50: testing FIND ?DEFINED +?DEFINED <> 0= ?~ Error #51 testing FIND ?DEFINED + +?DEFINED \ ?~ : \ ~ ; IMMEDIATE +\ Error #52: testing \ +: TIMM4 \ Error #53: testing \ is IMMEDIATE +; + +~ TRUE and FALSE are defined as colon definitions as they have been used +~ more than CONSTANT above + +?DEFINED TRUE ?~ : TRUE 1 NEGATE ; +?DEFINED FALSE ?~ : FALSE 0 ; +?DEFINED HEX ?~ : HEX 16 BASE ! ; + +TRUE -1 = ?~ Error #54: testing TRUE +FALSE 0= ?~ Error #55: testing FALSE +10 HEX 0A = ?~ Error #56: testing HEX +AB 0A BASE ! 171 = ?~ Error #57: testing hex number + +~ Delete the ~ on the next 2 lines to check the final error report +~ Error #998: testing a deliberate failure +~ Error #999: testing a deliberate failure + +~ Describe the messages that should be seen. The previously defined .MSG( +~ can be used for text messages + +CR .MSG( Results: ) CR +CR .MSG( Pass messages #1 to #23 should be displayed above) +CR .MSG( and no error messages) CR + +~ Finally display a message giving the number of tests that failed. +~ This is complicated by the fact that untested words including .( ." and . +~ cannot be used. Also more colon definitions shouldn't be defined than are +~ needed. To display a number, note that the number of errors will have +~ one or two digits at most and an interpretive loop can be used to +~ display those. + +CR +0 #ERRS @ +~ Loop to calculate the 10's digit (if any) +DUP NEGATE 9 + 0< NEGATE >IN +! ( -10 + SWAP 1+ SWAP 0 >IN ! ) +~ Display the error count +SWAP ?DUP 0= 1+ >IN +! ( 48 + EMIT ( ) 48 + EMIT + +.MSG( test) #ERRS @ 1 = 1+ >IN +! ~ .MSG( s) +.MSG( failed out of 57 additional tests) CR + +CR CR .MSG( --- End of Preliminary Tests --- ) CR diff --git a/8086/msdos/tests/test-blk.fth b/8086/msdos/tests/test-blk.fth new file mode 100644 index 0000000..76840f0 --- /dev/null +++ b/8086/msdos/tests/test-blk.fth @@ -0,0 +1,26 @@ + +include log2file.fth +logopen output.log + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth +include doubltst.fth + +: flush logclose flush logreopen ; +include block.fth + +REPORT-ERRORS + +logclose + diff --git a/8086/msdos/tests/test-min.fth b/8086/msdos/tests/test-min.fth new file mode 100644 index 0000000..68071f9 --- /dev/null +++ b/8086/msdos/tests/test-min.fth @@ -0,0 +1,14 @@ + +include log2file.fth +logopen output.log + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth + +\ 1 verbose ! +include core.fr + +logclose diff --git a/8086/msdos/tests/test-std.fth b/8086/msdos/tests/test-std.fth new file mode 100644 index 0000000..baaea50 --- /dev/null +++ b/8086/msdos/tests/test-std.fth @@ -0,0 +1,29 @@ + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +include log2file.fth +logopen output.log + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth + +\ ' .blk|tib Is .status + +include doubltst.fth + +REPORT-ERRORS + +logclose diff --git a/8086/msdos/tests/tester.fth b/8086/msdos/tests/tester.fth new file mode 100644 index 0000000..2cf108d --- /dev/null +++ b/8086/msdos/tests/tester.fth @@ -0,0 +1,66 @@ +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 + +\ 24/11/2015 Replaced Core Ext word <> with = 0= +\ 31/3/2015 Variable #ERRORS added and incremented for each error reported. +\ 22/1/09 The words { and } have been changed to T{ and }T respectively to +\ agree with the Forth 200X file ttester.fs. This avoids clashes with +\ locals using { ... } and the FSL use of } + +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! +\ TRUE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +VARIABLE #ERRORS 0 #ERRORS ! + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + #ERRORS @ 1 + #ERRORS ! +\ QUIT \ *** Uncomment this line to QUIT on an error +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: T{ \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP [CHAR] * EMIT + THEN ; + diff --git a/8086/msdos/tests/testprep.fb b/8086/msdos/tests/testprep.fb new file mode 100644 index 0000000..64c92b4 --- /dev/null +++ b/8086/msdos/tests/testprep.fb @@ -0,0 +1 @@ +\ include file to bundle what test-*.fth need phz 30jan22\ on top of kernel.com \ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 include extend.fb include multi.vid include dos.fb include include.fb include log2file.fb \ No newline at end of file diff --git a/8086/msdos/tests/testprep.fth b/8086/msdos/tests/testprep.fth new file mode 100644 index 0000000..d438799 --- /dev/null +++ b/8086/msdos/tests/testprep.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include file to bundle what test-*.fth need phz 30jan22 +\ on top of kernel.com + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 + + include extend.fb + include multi.vid + include dos.fb + include include.fb + include log2file.fb + + + + + + + + + diff --git a/8086/msdos/tests/util.fth b/8086/msdos/tests/util.fth new file mode 100644 index 0000000..b224c79 --- /dev/null +++ b/8086/msdos/tests/util.fth @@ -0,0 +1,143 @@ +( The ANS/Forth 2012 test suite is being modified so that the test programs ) +( for the optional word sets only use standard words from the Core word set. ) +( This file, which is included *after* the Core test programs, contains ) +( various definitions for use by the optional word set test programs to ) +( remove any dependencies between word sets. ) + +DECIMAL + +( First a definition to see if a word is already defined. Note that ) +( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools ) +( word set. ) + +VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 ) + +( [?DEF] followed by [?IF] cannot be used again until after [THEN] ) +: [?DEF] ( "name" -- ) + BL WORD FIND SWAP DROP 0= (\?) ! +; + +\ Test [?DEF] +T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T +: ?DEFTEST1 1 ; +T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T + +: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ; + +\ Equivalents of [IF] [ELSE] [THEN], these must not be nested +: [?IF] ( f -- ) (\?) ! ; IMMEDIATE +: [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE +: [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE + +( A conditional comment and \ will be defined. Note that these definitions ) +( are inadequate for use in Forth blocks. If needed in the blocks test ) +( program they will need to be modified here or redefined there ) + +( \? is a conditional comment ) +: \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE + +\ Test \? +T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined + ?DEFTEST1 -> 1 }T +T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined + ?DEFTEST1 -> 2 }T + +[?DEF] TRUE \? -1 CONSTANT TRUE +[?DEF] FALSE \? 0 CONSTANT FALSE +[?DEF] NIP \? : NIP SWAP DROP ; +[?DEF] TUCK \? : TUCK SWAP OVER ; + +[?DEF] PARSE +\? : BUMP ( caddr u n -- caddr+n u-n ) +\? TUCK - >R CHARS + R> +\? ; + +\? : PARSE ( ch "ccc" -- caddr u ) +\? >R SOURCE >IN @ BUMP +\? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch ) +\? BEGIN +\? DUP +\? WHILE +\? OVER C@ R@ = 0= +\? WHILE +\? 1 BUMP +\? REPEAT +\? 1- ( end u2 ) \ delimiter found +\? THEN +\? SOURCE NIP SWAP - >IN ! ( -- end ) +\? R> DROP R> ( -- end start ) +\? TUCK - 1 CHARS / ( -- start u ) +\? ; + +[?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE + +\ S= to compare (case sensitive) two strings to avoid use of COMPARE from +\ the String word set. It is defined in core.fr and conditionally defined +\ here if core.fr has not been included by the user + +[?DEF] S= +\? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal +\? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN +\? DUP 0= IF DROP 2DROP TRUE EXIT THEN +\? 0 DO +\? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN +\? CHAR+ SWAP CHAR+ +\? LOOP 2DROP TRUE +\? ; + +\ Buffer for strings in interpretive mode since S" only valid in compilation +\ mode when File-Access word set is defined + +64 CONSTANT SBUF-SIZE +CREATE SBUF1 SBUF-SIZE CHARS ALLOT +CREATE SBUF2 SBUF-SIZE CHARS ALLOT + +\ ($") saves a counted string at (caddr) +: ($") ( caddr "ccc" -- caddr' u ) + [CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca) + CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 ) + 2R> +; + +: $" ( "ccc" -- caddr u ) SBUF1 ($") ; +: $2" ( "ccc" -- caddr u ) SBUF2 ($") ; +: $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ; +: CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ; + +\ More definitions in core.fr used in other test programs, conditionally +\ defined here if core.fr has not been loaded + +[?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT +[?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT +[?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +[?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT +[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +[?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ; + +BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE ! + + +\ ------------------------------------------------------------------------------ +\ Tests + +: STR1 S" abcd" ; : STR2 S" abcde" ; +: STR3 S" abCd" ; : STR4 S" wbcd" ; +: S"" S" " ; + +T{ STR1 2DUP S= -> TRUE }T +T{ STR2 2DUP S= -> TRUE }T +T{ S"" 2DUP S= -> TRUE }T +T{ STR1 STR2 S= -> FALSE }T +T{ STR1 STR3 S= -> FALSE }T +T{ STR1 STR4 S= -> FALSE }T + +T{ CLEAR-SBUFS -> }T +T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T +T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T +T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T +T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T + +\ ------------------------------------------------------------------------------ + +CR $" Test utilities loaded" TYPE CR diff --git a/8086/msdos/tests/vocdos.fth b/8086/msdos/tests/vocdos.fth new file mode 100644 index 0000000..a74e972 --- /dev/null +++ b/8086/msdos/tests/vocdos.fth @@ -0,0 +1,9 @@ + +logopen output.log + +clear + +forth also dos words +cr + +logclose diff --git a/8086/msdos/tests/vocforth.fth b/8086/msdos/tests/vocforth.fth new file mode 100644 index 0000000..8239fc2 --- /dev/null +++ b/8086/msdos/tests/vocforth.fth @@ -0,0 +1,9 @@ + +logopen output.log + +clear + +forth words +cr + +logclose diff --git a/8086/msdos/v4th.com b/8086/msdos/v4th.com new file mode 100644 index 0000000..6e4849f Binary files /dev/null and b/8086/msdos/v4th.com differ diff --git a/8086/msdos/v4thblk.com b/8086/msdos/v4thblk.com new file mode 100644 index 0000000..eb95cb1 Binary files /dev/null and b/8086/msdos/v4thblk.com differ diff --git a/8086/msdos/v4thfile.com b/8086/msdos/v4thfile.com new file mode 100644 index 0000000..c3669bc Binary files /dev/null and b/8086/msdos/v4thfile.com differ diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile new file mode 100644 index 0000000..d39ca1f --- /dev/null +++ b/8086/pc-baremetal/Makefile @@ -0,0 +1,25 @@ +TARGET = forth.com +BASE = ../.. +BLKPACK = $(BASE)/tools/blkpack +BOOTPRG = ./bootdisk + +.PHONY: all +all: $(TARGET) + +%.fb: %.fth $(BLKPACK) + $(BLKPACK) < $< > $@ + +$(TARGET): kernel.fb meta.fb + emu2 $(BASE)/8086/pc-baremetal/volks4th.com "include kernel.fb bye" + +.PHONY: floppy +floppy: + $(BOOTPRG)/mkimg144 -bs $(BOOTPRG)/flp144.bin -o floppy.img -us $(TARGET) + +.PHONY: qemu +qemu: + qemu-system-i386 -curses -drive file=floppy.img,if=floppy,format=raw -monitor telnet:127.0.0.1:1234,server,nowait + +.PHONY: clean +clean: + rm -f $(TARGET) meta.com *.fb floppy.img diff --git a/8086/pc-baremetal/bootdisk/Makefile b/8086/pc-baremetal/bootdisk/Makefile new file mode 100644 index 0000000..94ddeb3 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/Makefile @@ -0,0 +1,14 @@ +TARGET = mkimg144 flp144.bin + +.PHONY: all +all: $(TARGET) + +flp144.bin: flp144.asm + nasm $< -f bin -o $@ + +mkimg144: mkimg144.c + $(CC) -o $@ $< + +.PHONY: clean +clean: + rm -f $(TARGET) diff --git a/8086/pc-baremetal/bootdisk/flp144.asm b/8086/pc-baremetal/bootdisk/flp144.asm new file mode 100644 index 0000000..41ad802 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/flp144.asm @@ -0,0 +1,526 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; "BootProg" Loader v 1.5 by Alexey Frunze (c) 2000-2015 ;; +;; 2-clause BSD license. ;; +;; ;; +;; ;; +;; This is a version of boot12.asm fully ready for a 1.44MB 3"5 floppy. ;; +;; ;; +;; ;; +;; How to Compile: ;; +;; ~~~~~~~~~~~~~~~ ;; +;; nasm flp144.asm -f bin -o flp144.bin ;; +;; ;; +;; ;; +;; Features: ;; +;; ~~~~~~~~~ ;; +;; - FAT12 supported ;; +;; ;; +;; - Loads a 16-bit executable file in the MS-DOS .COM or .EXE format ;; +;; from the root directory of a disk and transfers control to it ;; +;; (the "ProgramName" variable holds the name of the file to be loaded) ;; +;; ;; +;; - Prints an error if the file isn't found or couldn't be read ;; +;; (the "RE" message stands for "Read Error", ;; +;; the "NF" message stands for "file Not Found") ;; +;; and waits for a key to be pressed, then executes the Int 19h ;; +;; instruction and lets the BIOS continue bootstrap. ;; +;; ;; +;; ;; +;; Known Limitations: ;; +;; ~~~~~~~~~~~~~~~~~~ ;; +;; - Works only on the 1st MBR partition which must be a PRI DOS partition ;; +;; with FAT12 (File System ID: 1) ;; +;; ;; +;; ;; +;; Known Bugs: ;; +;; ~~~~~~~~~~~ ;; +;; - All bugs are fixed as far as I know. The boot sector has been tested ;; +;; on the following types of diskettes: ;; +;; - 360KB 5"25 ;; +;; - 1.2MB 5"25 ;; +;; - 1.44MB 3"5 ;; +;; ;; +;; ;; +;; Memory Layout: ;; +;; ~~~~~~~~~~~~~~ ;; +;; The diagram below shows the typical memory layout. The actual location ;; +;; of the boot sector and its stack may be lower than A0000H if the BIOS ;; +;; reserves memory for its Extended BIOS Data Area just below A0000H and ;; +;; reports less than 640 KB of RAM via its Int 12H function. ;; +;; ;; +;; physical address ;; +;; +------------------------+ 00000H ;; +;; | Interrupt Vector Table | ;; +;; +------------------------+ 00400H ;; +;; | BIOS Data Area | ;; +;; +------------------------+ 00500H ;; +;; | PrtScr Status / Unused | ;; +;; +------------------------+ 00600H ;; +;; | Loaded Image | ;; +;; +------------------------+ nnnnnH ;; +;; | Available Memory | ;; +;; +------------------------+ A0000H - 512 - 2KB ;; +;; | 2KB Boot Stack | ;; +;; +------------------------+ A0000H - 512 ;; +;; | Boot Sector | ;; +;; +------------------------+ A0000H ;; +;; | Video RAM | ;; +;; ;; +;; ;; +;; Boot Image Startup (register values): ;; +;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; +;; dl = BIOS boot drive number (e.g. 0, 80H) ;; +;; cs:ip = program entry point ;; +;; ss:sp = program stack (don't confuse with boot sector's stack) ;; +;; COM program defaults: cs = ds = es = ss = 50h, sp = 0, ip = 100h ;; +;; EXE program defaults: ds = es = 50h, other stuff depends on EXE header ;; +;; Magic numbers: ;; +;; si = 16381 (prime number 2**14-3) ;; +;; di = 32749 (prime number 2**15-19) ;; +;; bp = 65521 (prime number 2**16-15) ;; +;; The magic numbers let the program know whether it has been loaded by ;; +;; this boot sector or by MS-DOS, which may be handy for universal, bare- ;; +;; metal and MS-DOS programs. ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +[BITS 16] + +;;? equ 0 +ImageLoadSeg equ 60h ; <=07Fh because of "push byte ImageLoadSeg" instructions + +[SECTION .text] +[ORG 0] + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boot sector starts here ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + jmp short start ; MS-DOS/Windows checks for this jump + nop +bsOemName DB "BootProg" ; 0x03 + +;;;;;;;;;;;;;;;;;;;;; +;; BPB starts here ;; +;;;;;;;;;;;;;;;;;;;;; + +bpbBytesPerSector DW 512 ; 0x0B +bpbSectorsPerCluster DB 1 ; 0x0D +bpbReservedSectors DW 1 ; 0x0E +bpbNumberOfFATs DB 2 ; 0x10 +bpbRootEntries DW 224 ; 0x11 +bpbTotalSectors DW 2880 ; 0x13 +bpbMedia DB 0F0h ; 0x15 +bpbSectorsPerFAT DW 9 ; 0x16 +bpbSectorsPerTrack DW 18 ; 0x18 +bpbHeadsPerCylinder DW 2 ; 0x1A +bpbHiddenSectors DD 0 ; 0x1C +bpbTotalSectorsBig DD 0 ; 0x20 + +;;;;;;;;;;;;;;;;;;; +;; BPB ends here ;; +;;;;;;;;;;;;;;;;;;; + +bsDriveNumber DB 0 ; 0x24 +bsUnused DB 0 ; 0x25 +bsExtBootSignature DB 29H ; 0x26 +bsSerialNumber DD 11223344h ; 0x27 +bsVolumeLabel DB "NO NAME " ; 0x2B +bsFileSystem DB "FAT12 " ; 0x36 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boot sector code starts here ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +start: + cld + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; How much RAM is there? ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + int 12h ; get conventional memory size (in KBs) + shl ax, 6 ; and convert it to 16-byte paragraphs + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the boot sector and its stack ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + sub ax, 512 / 16 ; reserve 512 bytes for the boot sector code + mov es, ax ; es:0 -> top - 512 + + sub ax, 2048 / 16 ; reserve 2048 bytes for the stack + mov ss, ax ; ss:0 -> top - 512 - 2048 + mov sp, 2048 ; 2048 bytes for the stack + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Copy ourselves to top of memory ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov cx, 256 + mov si, 7C00h + xor di, di + mov ds, di + rep movsw + +;;;;;;;;;;;;;;;;;;;;;; +;; Jump to the copy ;; +;;;;;;;;;;;;;;;;;;;;;; + + push es + push byte main + retf + +main: + push cs + pop ds + + mov [bsDriveNumber], dl ; store BIOS boot drive number + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the FAT12 image (6KB max) ;; +;; and load it in its entirety ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov ax, [bpbBytesPerSector] + shr ax, 4 ; ax = sector size in paragraphs + mov cx, [bpbSectorsPerFAT] ; cx = FAT size in sectors + mul cx ; ax = FAT size in paragraphs + + mov di, ss + sub di, ax + mov es, di + xor bx, bx ; es:bx -> buffer for the FAT + + mov ax, [bpbHiddenSectors] + mov dx, [bpbHiddenSectors+2] + add ax, [bpbReservedSectors] + adc dx, bx ; dx:ax = LBA + + call ReadSector + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reserve memory for the root directory ;; +;; and load it in its entirety ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov bx, ax + mov di, dx ; save LBA to di:bx + + mov ax, 32 + + mov si, [bpbRootEntries] + mul si + div word [bpbBytesPerSector] + mov cx, ax ; cx = root directory size in sectors + + mov al, [bpbNumberOfFATs] + cbw + mul word [bpbSectorsPerFAT] + add ax, bx + adc dx, di ; dx:ax = LBA + + push es ; push FAT segment (2nd parameter) + + push byte ImageLoadSeg + pop es + xor bx, bx ; es:bx -> buffer for root directory + + call ReadSector + + add ax, cx + adc dx, bx ; adjust LBA for cluster data + + push dx + push ax ; push LBA for data (1st parameter) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Look for the COM/EXE file to load and run ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + mov di, bx ; es:di -> root entries array + mov dx, si ; dx = number of root entries + mov si, ProgramName ; ds:si -> program name + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Looks for a file/dir by its name ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Input: DS:SI -> file name (11 chars) ;; +;; ES:DI -> root directory array ;; +;; DX = number of root entries ;; +;; Output: SI = cluster number ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +FindName: + mov cx, 11 +FindNameCycle: + cmp byte [es:di], ch + je FindNameFailed ; end of root directory + pusha + repe cmpsb + popa + je FindNameFound + add di, 32 + dec dx + jnz FindNameCycle ; next root entry +FindNameFailed: + jmp ErrFind +FindNameFound: + mov si, [es:di+1Ah] ; si = cluster no. + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Load the entire file ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadNextCluster: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reads a FAT12 cluster ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Inout: ES:BX -> buffer ;; +;; SI = cluster no ;; +;; Output: SI = next cluster ;; +;; ES:BX -> next addr ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadCluster: + mov bp, sp + + lea ax, [si-2] + xor ch, ch + mov cl, [bpbSectorsPerCluster] + ; cx = sector count + mul cx + + add ax, [bp] + adc dx, [bp+1*2] + ; dx:ax = LBA + + call ReadSector + + mov ax, [bpbBytesPerSector] + shr ax, 4 ; ax = paragraphs per sector + mul cx ; ax = paragraphs read + + mov cx, es + add cx, ax + mov es, cx ; es:bx updated + + mov ax, 3 + mul si + shr ax, 1 + xchg ax, si ; si = cluster * 3 / 2 + + push ds + mov ds, [bp+2*2] ; ds = FAT segment + mov si, [si] ; si = next cluster + pop ds + + jnc ReadClusterEven + + shr si, 4 + +ReadClusterEven: + and si, 0FFFh ; mask cluster value +ReadClusterDone: + + cmp si, 0FF8h + jc ReadNextCluster ; if not End Of File + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Type detection, .COM or .EXE? ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + push byte ImageLoadSeg + pop ds + mov ax, ds ; ax=ds=seg the file is loaded to + + cmp word [0], 5A4Dh ; "MZ" signature? + + je RelocateEXE ; yes, it's an EXE program + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Setup and run a .COM program ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + sub ax, 10h ; "org 100h" stuff :) + mov es, ax + mov ds, ax + mov ss, ax + xor sp, sp + push es + push word 100h + jmp short Run + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Relocate, setup and run a .EXE program ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +RelocateEXE: + + add ax, [08h] ; ax = image base + mov cx, [06h] ; cx = reloc items + mov bx, [18h] ; bx = reloc table pointer + + jcxz RelocationDone + +ReloCycle: + mov di, [bx] ; di = item ofs + mov dx, [bx+2] ; dx = item seg (rel) + add dx, ax ; dx = item seg (abs) + + push ds + mov ds, dx ; ds = dx + add [di], ax ; fixup + pop ds + + add bx, 4 ; point to next entry + loop ReloCycle + +RelocationDone: + + mov bx, ax + add bx, [0Eh] + mov ss, bx ; ss for EXE + mov sp, [10h] ; sp for EXE + + add ax, [16h] ; cs + push ax + push word [14h] ; ip +Run: + mov dl, [cs:bsDriveNumber] ; pass the BIOS boot drive + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Set the magic numbers so the program knows that it ;; +;; has been loaded by this bootsector and not by MS-DOS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + mov si, 16381 ; prime number 2**14-3 + mov di, 32749 ; prime number 2**15-19 + mov bp, 65521 ; prime number 2**16-15 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; All done, transfer control to the program now ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + retf + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reads a sector using BIOS Int 13h fn 2 ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Input: DX:AX = LBA ;; +;; CX = sector count ;; +;; ES:BX -> buffer address ;; +;; Output: CF = 1 if error ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ReadSector: + pusha + +ReadSectorNext: + mov di, 5 ; attempts to read + +ReadSectorRetry: + pusha + + div word [bpbSectorsPerTrack] + ; ax = LBA / SPT + ; dx = LBA % SPT = sector - 1 + + mov cx, dx + inc cx + ; cx = sector no. + + xor dx, dx + div word [bpbHeadsPerCylinder] + ; ax = (LBA / SPT) / HPC = cylinder + ; dx = (LBA / SPT) % HPC = head + + mov ch, al + ; ch = LSB 0...7 of cylinder no. + shl ah, 6 + or cl, ah + ; cl = MSB 8...9 of cylinder no. + sector no. + + mov dh, dl + ; dh = head no. + + mov dl, [bsDriveNumber] + ; dl = drive no. + + mov ax, 201h + ; al = sector count = 1 + ; ah = 2 = read function no. + + int 13h ; read sectors + jnc ReadSectorDone ; CF = 0 if no error + + xor ah, ah ; ah = 0 = reset function + int 13h ; reset drive + + popa + dec di + jnz ReadSectorRetry ; extra attempt + jmp short ErrRead + +ReadSectorDone: + popa + dec cx + jz ReadSectorDone2 ; last sector + + add bx, [bpbBytesPerSector] ; adjust offset for next sector + add ax, 1 + adc dx, 0 ; adjust LBA for next sector + jmp short ReadSectorNext + +ReadSectorDone2: + popa + ret + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Error Messaging Code ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +ErrRead: + mov si, MsgErrRead + jmp short Error +ErrFind: + mov si, MsgErrFind +Error: + mov ah, 0Eh + mov bx, 7 + + lodsb + int 10h ; 1st char + lodsb + int 10h ; 2nd char + + xor ah, ah + int 16h ; wait for a key... + mov dl, [bsDriveNumber] ; restore BIOS boot drive number + int 19h ; bootstrap + +;;;;;;;;;;;;;;;;;;;;;; +;; String constants ;; +;;;;;;;;;;;;;;;;;;;;;; + +MsgErrRead db "RE" +MsgErrFind db "NF" + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Fill free space with zeroes ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + times (512-13-($-$$)) db 0 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Name of the file to load and run ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ProgramName db "FORTH COM" ; name and extension each must be + ; padded with spaces (11 bytes total) + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; End of the sector ID ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + + dw 0AA55h ; BIOS checks for this ID diff --git a/8086/pc-baremetal/bootdisk/flp144.bin b/8086/pc-baremetal/bootdisk/flp144.bin new file mode 100644 index 0000000..f6f3fbe Binary files /dev/null and b/8086/pc-baremetal/bootdisk/flp144.bin differ diff --git a/8086/pc-baremetal/bootdisk/license.txt b/8086/pc-baremetal/bootdisk/license.txt new file mode 100644 index 0000000..cc4dcc2 --- /dev/null +++ b/8086/pc-baremetal/bootdisk/license.txt @@ -0,0 +1,26 @@ +Copyright (c) 2000-2015, Alexey Frunze +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +The views and conclusions contained in the software and documentation are those +of the authors and should not be interpreted as representing official policies, +either expressed or implied, of the FreeBSD Project. diff --git a/8086/pc-baremetal/bootdisk/mkimg144 b/8086/pc-baremetal/bootdisk/mkimg144 new file mode 100755 index 0000000..d3e1c18 Binary files /dev/null and b/8086/pc-baremetal/bootdisk/mkimg144 differ diff --git a/8086/pc-baremetal/bootdisk/mkimg144.c b/8086/pc-baremetal/bootdisk/mkimg144.c new file mode 100644 index 0000000..06a32fe --- /dev/null +++ b/8086/pc-baremetal/bootdisk/mkimg144.c @@ -0,0 +1,612 @@ +#include +#include +#include +#include +#include +#include + +typedef unsigned char uchar, uint8; +typedef unsigned short uint16; +#ifndef __SMALLER_C__ +#if UINT_MAX >= 0xFFFFFFFF +typedef unsigned uint32; +#else +typedef unsigned long uint32; +#endif +#else +typedef unsigned long uint32; +#endif +typedef unsigned uint; +typedef unsigned long ulong; + +#ifndef __SMALLER_C__ +#define C_ASSERT(expr) extern char CAssertExtern[(expr)?1:-1] +C_ASSERT(CHAR_BIT == 8); +C_ASSERT(sizeof(uint16) == 2); +C_ASSERT(sizeof(uint32) == 4); +#endif + +#pragma pack (push, 1) + +typedef struct tFATBPB1 +{ + uint16 BytesPerSector; + uint8 SectorsPerCluster; + uint16 ReservedSectorsCount; + uint8 NumberOfFATs; + uint16 RootEntriesCount; + uint16 TotalSectorsCount16; + uint8 MediaType; + uint16 SectorsPerFAT1x; + uint16 SectorsPerTrack; + uint16 HeadsPerCylinder; + uint32 HiddenSectorsCount; + uint32 TotalSectorsCount32; +} tFATBPB1; + +typedef union tFATBPB2 +{ + struct + { + uint8 DriveNumber; + uint8 reserved1; + uint8 ExtendedBootSignature; + uint32 VolumeSerialNumber; + char VolumeLabel[11]; + char FileSystemName[8]; + uchar aBootCode1x[0x1C]; + } FAT1x; + struct + { + uint32 SectorsPerFAT32; + uint16 ExtendedFlags; + uint16 FSVersion; + uint32 RootDirectoryClusterNo; + uint16 FSInfoSectorNo; + uint16 BackupBootSectorNo; + uint8 reserved[12]; + uint8 DriveNumber; + uint8 reserved1; + uint8 ExtendedBootSignature; + uint32 VolumeSerialNumber; + char VolumeLabel[11]; + char FileSystemName[8]; + } FAT32; +} tFATBPB2; + +typedef struct tFATBPB +{ + tFATBPB1 BPB1; + tFATBPB2 BPB2; +} tFATBPB; + +typedef struct tFATBootSector +{ + uchar aJump[3]; + char OEMName[8]; + tFATBPB BPB; + uchar aBootCode32[0x1A4]; + uint16 Signature0xAA55; +} tFATBootSector; + +typedef enum tFATDirEntryAttribute +{ + dea_READ_ONLY = 0x01, + dea_HIDDEN = 0x02, + dea_SYSTEM = 0x04, + dea_VOLUME_ID = 0x08, + dea_DIRECTORY = 0x10, + dea_ARCHIVE = 0x20, + dea_LONG_NAME = dea_READ_ONLY|dea_HIDDEN|dea_SYSTEM|dea_VOLUME_ID +} tFATDirEntryAttribute; + +typedef struct tFATDirectoryEntry +{ + char Name[8]; + char Extension[3]; + uint8 Attribute; + uint8 WinNTreserved; + uint8 CreationTimeSecTenths; + uint16 CreationTime2Secs; + uint16 CreationDate; + uint16 LastAccessDate; + uint16 FirstClusterHiWord; + uint16 LastWriteTime; + uint16 LastWriteDate; + uint16 FirstClusterLoWord; + uint32 Size; +} tFATDirectoryEntry; + +#define DELETED_DIR_ENTRY_MARKER 0xE5 + +#pragma pack (pop) + +#ifndef __SMALLER_C_32__ +C_ASSERT(sizeof(tFATBootSector) == 512); +C_ASSERT(sizeof(tFATDirectoryEntry) == 32); +#endif + +#define FBUF_SIZE 1024 + +char* BootSectName; + +char* OutName = "floppy.img"; + +int UniqueSerial; + +FILE* fout; + +tFATBootSector BootSector; +uint32 Fat1Lba; +uint32 SectorsPerFat; +uint32 Fats; +uint32 RootDirLba; +uint32 DirEntriesPerSector; +uint32 RootDirEntries; +uint32 RootDirSectors; +uint32 Cluster2Lba; +uint32 SectorsPerCluster; +uint32 ClusterSize; +uint32 DataSectors; +uint32 Clusters; + +uint8 FatSector[512]; +uint32 Cluster; + +tFATDirectoryEntry RootDirSector[512 / sizeof(tFATDirectoryEntry)]; +uint32 RootDirEntryIdx; + +void error(char* format, ...) +{ +#ifndef __SMALLER_C__ + va_list vl; + va_start(vl, format); +#else + void* vl = &format + 1; +#endif + + if (fout) + fclose(fout); + remove(OutName); + + puts(""); + + vprintf(format, vl); + +#ifndef __SMALLER_C__ + va_end(vl); +#endif + + exit(EXIT_FAILURE); +} + +FILE* Fopen(const char* filename, const char* mode) +{ + FILE* stream = fopen(filename, mode); + if (!stream) + error("Can't open/create file \"%s\"\n", filename); + return stream; +} + +void Fclose(FILE* stream) +{ + if (fclose(stream)) + error("Can't close a file\n"); +} + +void Fseek(FILE* stream, long offset, int whence) +{ + int r = fseek(stream, offset, whence); + if (r) + error("Can't seek a file\n"); +} + +void Fread(void* ptr, size_t size, FILE* stream) +{ + size_t r = fread(ptr, 1, size, stream); + if (r != size) + error("Can't read a file\n"); +} + +void Fwrite(const void* ptr, size_t size, FILE* stream) +{ + size_t r = fwrite(ptr, 1, size, stream); + if (r != size) + error("Can't write a file\n"); +} + +void FillWithByte(unsigned char byte, unsigned long size, FILE* stream) +{ + static unsigned char buf[FBUF_SIZE]; + memset(buf, byte, FBUF_SIZE); + while (size) + { + unsigned long csz = size; + if (csz > FBUF_SIZE) + csz = FBUF_SIZE; + Fwrite(buf, csz, stream); + size -= csz; + } +} + +// Determines binary file size portably (when stat()/fstat() aren't available) +long fsize(FILE* binaryStream) +{ + long ofs, ofs2; + int result; + + if (fseek(binaryStream, 0, SEEK_SET) != 0 || + fgetc(binaryStream) == EOF) + return 0; + + ofs = 1; + + while ((result = fseek(binaryStream, ofs, SEEK_SET)) == 0 && + (result = (fgetc(binaryStream) == EOF)) == 0 && + ofs <= LONG_MAX / 4 + 1) + ofs *= 2; + + // If the last seek failed, back up to the last successfully seekable offset + if (result != 0) + ofs /= 2; + + for (ofs2 = ofs / 2; ofs2 != 0; ofs2 /= 2) + if (fseek(binaryStream, ofs + ofs2, SEEK_SET) == 0 && + fgetc(binaryStream) != EOF) + ofs += ofs2; + + // Return -1 for files longer than LONG_MAX + if (ofs == LONG_MAX) + return -1; + + return ofs + 1; +} + +void FlushFatSector(void) +{ + uint32 ofs = (Cluster * 3 / 2) & 511; + uint32 i; + + if (ofs == 0 && (Cluster & 1) == 0) + return; + + for (i = 0; i < Fats; i++) + { + uint32 ofs = Fat1Lba + i * SectorsPerFat; + ofs += (Cluster * 3 / 2) / 512; + Fseek(fout, ofs * 512, SEEK_SET); + Fwrite(FatSector, sizeof FatSector, fout); + } + + memset(FatSector, 0, sizeof FatSector); +} + +void ChainCluster(uint32 nextCluster) +{ + uint32 ofs = (Cluster * 3 / 2) & 511; + + if (Cluster & 1) + FatSector[ofs] |= nextCluster << 4; + else + FatSector[ofs] = nextCluster; + + if (ofs == 511) + FlushFatSector(); + + ofs = (ofs + 1) & 511; + + if (Cluster & 1) + FatSector[ofs] = nextCluster >> 4; + else + FatSector[ofs] = (nextCluster >> 8) & 0xF; + + if (ofs == 511 && (Cluster & 1)) + FlushFatSector(); + + Cluster++; +} + +void FlushRootDirSector(void) +{ + uint32 ofs; + + if (RootDirEntryIdx % DirEntriesPerSector == 0) + return; + + ofs = RootDirLba + RootDirEntryIdx / DirEntriesPerSector; + + Fseek(fout, ofs * 512, SEEK_SET); + Fwrite(RootDirSector, sizeof RootDirSector, fout); +} + +void AddRootDirEntry(tFATDirectoryEntry* de) +{ + RootDirSector[RootDirEntryIdx % DirEntriesPerSector] = *de; + + if ((RootDirEntryIdx + 1) % DirEntriesPerSector == 0) + FlushRootDirSector(); + + RootDirEntryIdx++; +} + +void Init(void) +{ + if (BootSectName) + { + FILE* fsect = Fopen(BootSectName, "rb"); + Fread(&BootSector, sizeof BootSector, fsect); + Fclose(fsect); + } + else + { + memcpy(BootSector.OEMName, "BootProg", 8); + memcpy(BootSector.BPB.BPB2.FAT1x.VolumeLabel, "NO NAME ", 11); + memcpy(BootSector.BPB.BPB2.FAT1x.FileSystemName, "FAT12 ", 8); + BootSector.aJump[0] = 0xEB; // jmp short $+0x3E + BootSector.aJump[1] = 0x3C; + BootSector.aJump[2] = 0x90; // nop + // TBD??? replace the below with code to print an error message like "Not a system/bootable disk"? + BootSector.BPB.BPB2.FAT1x.aBootCode1x[0] = 0xF4; // hlt + BootSector.BPB.BPB2.FAT1x.aBootCode1x[1] = 0xEB; // jmp short $-1 + BootSector.BPB.BPB2.FAT1x.aBootCode1x[2] = 0xFD; + } + + fout = Fopen(OutName, "wb"); + + BootSector.BPB.BPB1.BytesPerSector = 512; // note, we're normally assuming 512 bytes per sector everywhere + BootSector.BPB.BPB1.SectorsPerCluster = 1; + BootSector.BPB.BPB1.ReservedSectorsCount = 1; // includes the boot sector + BootSector.BPB.BPB1.NumberOfFATs = 2; + BootSector.BPB.BPB1.RootEntriesCount = 224; // must be a multiple of 16 (16 32-byte entries in 512-byte sector) + BootSector.BPB.BPB1.TotalSectorsCount16 = 2880; + BootSector.BPB.BPB1.MediaType = 0xF0; + BootSector.BPB.BPB1.SectorsPerFAT1x = 9; + BootSector.BPB.BPB1.SectorsPerTrack = 18; + BootSector.BPB.BPB1.HeadsPerCylinder = 2; + BootSector.BPB.BPB1.HiddenSectorsCount = 0; + BootSector.BPB.BPB1.TotalSectorsCount32 = 0; + BootSector.BPB.BPB2.FAT1x.DriveNumber = 0; + BootSector.BPB.BPB2.FAT1x.reserved1 = 0; + BootSector.BPB.BPB2.FAT1x.ExtendedBootSignature = 0x29; + BootSector.BPB.BPB2.FAT1x.VolumeSerialNumber = 0x11223344; + if (UniqueSerial) + BootSector.BPB.BPB2.FAT1x.VolumeSerialNumber = time(NULL); + BootSector.Signature0xAA55 = 0xAA55; + + // Write the boot sector + Fwrite(&BootSector, sizeof BootSector, fout); + + // Zero out the rest of the image + FillWithByte(0, (BootSector.BPB.BPB1.TotalSectorsCount16 - 1) * 512UL, fout); + + // FAT12's first two entries need special initialization + ChainCluster(0xF00 | BootSector.BPB.BPB1.MediaType); + ChainCluster(0xFFF); + + // Helper variables + + Fat1Lba = BootSector.BPB.BPB1.ReservedSectorsCount; + SectorsPerFat = BootSector.BPB.BPB1.SectorsPerFAT1x; + Fats = BootSector.BPB.BPB1.NumberOfFATs; + + RootDirLba = Fat1Lba + SectorsPerFat * Fats; + DirEntriesPerSector = 512 / sizeof(tFATDirectoryEntry); + RootDirEntries = BootSector.BPB.BPB1.RootEntriesCount; + RootDirSectors = (RootDirEntries * sizeof(tFATDirectoryEntry) + 511) / 512; + + Cluster2Lba = RootDirLba + RootDirSectors; + SectorsPerCluster = BootSector.BPB.BPB1.SectorsPerCluster; + ClusterSize = SectorsPerCluster * 512; + DataSectors = BootSector.BPB.BPB1.TotalSectorsCount16 - + BootSector.BPB.BPB1.ReservedSectorsCount - SectorsPerFat * Fats - RootDirSectors; + Clusters = DataSectors / SectorsPerCluster; +} + +void Done(void) +{ + FlushFatSector(); + FlushRootDirSector(); + Fclose(fout); +} + +void NameTo8Dot3Name(const char* in, char out[8 + 3]) +{ + static const char aInvalid8Dot3NameChars[] = "\"*+,./:;<=>?[\\]|"; + int i, j; + int namelen = 0, dots = 0, extlen = 0; + + memset(out, ' ', 8 + 3); + + if (*in == '\0' || *in == '.') + goto lerr; + + for (j = i = 0; in[i]; i++) + { + int c = (unsigned char)in[i]; + if (i >= 12) // at most 12 input chars can fit into an 8.3 name + goto lerr; + if (i == 0 && c == 0xE5) + { + // 0xE5 in the first character of the name is a marker for deleted files, + // it needs to be translated to 0x05 + c = 0x05; + } + else if (c == '.') + { + if (dots++) // at most one dot allowed + goto lerr; + j = 8; // now writing extension + continue; + } + if (c <= 0x20 || strchr(aInvalid8Dot3NameChars, c) != NULL) + goto lerr; + if (dots) + { + if (++extlen > 3) // at most 3 chars in extension + goto lerr; + } + else + { + if (++namelen > 8) // at most 8 chars in name + goto lerr; + } + if (c >= 'a' && c <= 'z') + c -= 'a' - 'A'; + out[j++] = c; + } + + // TBD??? error out on the following reserved names: "COM1"-"COM9", "CON", "LPT1"-"LPT9", "NUL", "PRN"? + + return; + +lerr: + error("Can't convert \"%s\" to an 8.3 DOS name\n", in); +} + +void AddFile(char* fname) +{ + char* pslash = strrchr(fname, '/'); + char* pbackslash = strrchr(fname, '\\'); + char* pname; + char name8_3[8 + 3]; + FILE* f; + long size; + tFATDirectoryEntry de; + uint32 ofs; + + // First, find where the path ends in the file name, if any + + // In DOS/Windows paths can contain either '\\' or '/' as a separator between directories, + // choose the right-most + if (pslash && pbackslash) + { + if (pslash < pbackslash) + pslash = pbackslash; + } + else if (!pslash) + { + pslash = pbackslash; + } + // If there's no slash, it could be "c:file" + if (!pslash && ((*fname >= 'A' && *fname <= 'Z') || (*fname >= 'a' && *fname <= 'z')) && fname[1] == ':') + pslash = fname + 1; + + pname = pslash ? pslash + 1 : fname; + + // Convert the name to 8.3 + NameTo8Dot3Name(pname, name8_3); + + // TBD!!! error out on duplicate files/names + + // Copy the file + + f = Fopen(fname, "rb"); + + // Prepare the directory entry + memset(&de, 0, sizeof de); + memcpy(de.Name, name8_3, 8 + 3); + de.Attribute = dea_ARCHIVE; + de.Size = size = fsize(f); + if (RootDirEntryIdx >= RootDirEntries || + size < 0 || (unsigned long)size > Clusters * ClusterSize) + error("No space for file \"%s\"", fname); + if (size) + { + de.FirstClusterLoWord = Cluster; + de.FirstClusterHiWord = Cluster >> 16; + } + // TBD??? set file date/time to now? + de.LastWriteDate = ((1990 - 1980) << 9) | (1 << 5) | 1; // 1990/01/01 + de.LastWriteTime = (12 << 11) | (0 << 5) | (0 >> 1); // 12(PM):00:00 + + // Seek both files + Fseek(f, 0, SEEK_SET); + ofs = Cluster2Lba + (Cluster - 2) * SectorsPerCluster; + Fseek(fout, ofs * 512, SEEK_SET); + + // Copy data sectors + while (size) + { + uint8 sector[512]; + long sz = (size > 512) ? 512 : size; + + memset(sector, 0, 512); // pad with zeroes the last partial sector + Fread(sector, sz, f); + + Fwrite(sector, 512, fout); + + size -= sz; + } + + // Allocate and chain clusters in the FAT + size = de.Size; + while (size) + { + if (size > (long)ClusterSize) + { + // There's at least one more cluster in the chain + ChainCluster(Cluster + 1); + size -= ClusterSize; + } + else + { + // No more clusters, this is the last one in the chain + ChainCluster(0xFF8); + size = 0; + } + Clusters--; + } + + // Write the directory entry + AddRootDirEntry(&de); + + Fclose(f); +} + +int main(int argc, char* argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + { + if (!strcmp(argv[i], "-o")) + { + if (i + 1 < argc) + { + argv[i++] = NULL; + OutName = argv[i]; + argv[i] = NULL; + continue; + } + } + else if (!strcmp(argv[i], "-bs")) + { + if (i + 1 < argc) + { + argv[i++] = NULL; + BootSectName = argv[i]; + argv[i] = NULL; + continue; + } + } + else if (!strcmp(argv[i], "-us")) + { + UniqueSerial = 1; + argv[i++] = NULL; + continue; + } + + if (argv[i][0] == '-') + error("Invalid or unsupported command line option\n"); + } + + Init(); + + for (i = 1; i < argc; i++) + if (argv[i]) + AddFile(argv[i]); + + Done(); + + return 0; +} diff --git a/8086/pc-baremetal/bootdisk/readme.txt b/8086/pc-baremetal/bootdisk/readme.txt new file mode 100644 index 0000000..d36ba8d --- /dev/null +++ b/8086/pc-baremetal/bootdisk/readme.txt @@ -0,0 +1,139 @@ +The "BootProg" Boot Sector + + +What is BootProg? + +BootProg is a collection of 512-byte boot sectors (for the x86 PC) capable of +loading and executing a program from a FAT12-formatted floppy or a FAT16/32- +formatted hard disk (bootable USB sticks and CDs can also be made with +BootProg). + +BootProg understands programs in the MS-DOS .COM or .EXE format. This makes +it possible to use existing 16-bit compilers such as Borland/Turbo C/C++, +Sybase/Open Watcom C/C++ and Smaller C and a variety of assemblers such as +NASM, FASM, TASM and MASM among the others. + +BootProg doesn't require that the program occupy a contiguous span of sectors +or FAT clusters or reside at a specific fixed location on the disk. BootProg +faithfully parses the root directory and the chain of FAT clusters in order to +locate the program contents. The only requirement is that the program be named +"STARTUP.BIN" (without quotes). This makes updating the program easy. You just +need to update the file and you can reboot and execute it immediately. + + +What can BootProg be used for? + +You can make a boot loader for your OS. The program that BootProg loads can be +your 2nd stage boot loader. Or, if your OS is relatively small, STARTUP.BIN +could contain the entire OS. + +You can write low-level utilities to work with your PC's hardware and load them +with BootProg without having to jump through the hoops with your Windows, Linux +or even DOS. + +You can make cool graphics demos or games that run on bare hardware. + + +What can't BootProg be used for? + +Many things. Most importantly, if you make a DOS program that uses any MS-DOS +service functions (e.g. int 21h) or data structures, it will not work when +loaded by BootProg. It must use either BIOS services (e.g. int 10h, int 16h, +int 13h and such) or access hardware directly or both. + +However, it is possible to create universal/hybrid programs that would work +both in DOS and when loaded by BootProg. BootProg will set registers si, di and +bp to the values 16381, 32749 and 65521 respectively before transferring control +to your program. Your program can then check the values in these registers and +use DOS services in DOS or something else instead on bare hardware. You can also +choose to make the program run with reduced functionality if not on DOS or +vice versa. + + +How does it work? + +Nothing special. It just finds STARTUP.BIN, loads it, performs any relocations +necessary for the .EXE type of programs, sets the magic numbers 16381, 32749 +and 65521 in registers si, di and bp respectively and passes control to your +program. + +If BootProg can't find STARTUP.BIN, it will print "NF" to the screen. If it +fails to load the file due to a read error, it will print "RE". This is how the +FAT12 and FAT16 versions of BootProg work. The FAT32 version has much less space +for these errors and so in both above cases it will simply print "E". + + +How do I put BootProg on my disk? + +If you have a 1.44MB 3"5 floppy, just format it regularly with FAT12 in DOS or +Windows and then write flp144.bin to the very first sector of the floppy with +whatever tools you find/have for that. After that you can copy STARTUP.BIN to +the floppy and off you go. + +If you want to create an image of a 1.44MB 3"5 floppy, it might be even easier. +Compile the mkimg144.c program contained here with your favorite C compiler +and use it: + + mkimg144 [option(s)] [file(s)] + + Options: + + -bs Specifies the boot sector to use, e.g. "-bs flp144.bin" + + -o Specifies the name of the output file ("floppy.img" is the + default, if this option isn't specified) + + -us Uses the current time to set the volume ID of the FAT to a unique + value (the volume ID is used to distinguish between different + removable disks and detect disk change more accurately) + +E.g: "mkimg144 -bs flp144.bin -o flp144.img -us startup.bin". +Btw, you can rename the supplied file "demo1.com" to "startup.bin" to try it +out. + +For all other cases you'll need to become a little more familiar with FAT and +a little more intimate with disk tools and BootProg's source code. + +You will need to populate the BPB's of boot16.asm and boot32.asm with the +values appropriate to the type and size of the file system that you already have +on a disk or that you intend to create on the disk. +See the source code, these places are marked with question marks, for example: + bpbBytesPerSector DW ? ; 0x0B + +The best is to format your disk with some standard tools (e.g. FORMAT.COM in +DOS), extract the BPB values from the FAT-formatted disk, put them into BootProg +and then write thusly adjusted BootProg over the original boot sector. + +You may find a disk editor handy when manipulating BPB values and/or +reading/writing boot sectors. + + +Limitations and implementation details + +boot12.asm (flp144.asm) and boot16.asm require an i80186/i80188/i80286 or a +better CPU. boot32.asm naturally requires an i80386 or a better CPU. + +boot12.asm (flp144.asm) was not tested on hard disks (but it might work as the +boot sector on FAT12 primary partitions (file system ID 1)). + +boot16.asm was written for and tested on primary FAT16 partitions (file system +IDs 4 and 6). Its expected use is the boot sector of the partition and not the +MBR. The FAT16 version may allocate up to 128KB of RAM for the entire FAT16, +leaving less room for STARTUP.BIN. But ~400KB left should still be plenty of +space for its code, data and stack. + +boot32.asm was written for and tested on primary FAT32 partitions (file system +IDs 0Bh and 0Ch) and for BIOSes supporting function 42h of int 13h (IOW, for +systems supporting HDDs larger than 8GB). Its expected use is the boot sector +of the partition and not the MBR. + +BootProg does not check the size of STARTUP.BIN and reads into memory all of its +clusters, which means that up to 32767 extra bytes may be read from the disk +and written to the memory after the last byte of STARTUP.BIN (max cluster size +is 32KB). It also means that you may append data to your program and it will be +loaded. You may create oversized .COM-style STARTUP.BIN larger than ~64KB, +however, note that the stack will naturally overwrite its contents from offset +65535 of the program segment (offset 65279 of the file) downwards. + +If your PC has the full 640KB of conventional/DOS memory, you should be able to +load program files of size of up to ~400KB. diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth new file mode 100644 index 0000000..386a0b5 --- /dev/null +++ b/8086/pc-baremetal/kernel.fth @@ -0,0 +1,1607 @@ +( ----- 000 ) +\ #### volksFORTH #### cas 11apr21 + volksFORTH designed and developed by + the volksFORTH team + + see https://volksforth.sf.net + https://github.com/forth-ev/VolksForth + + for documentation, updated versions and development + information +( ----- 001 ) +\ MS-DOS volksForth Load Screen ks cas 18jul20 + warning off \ disable warnings during compilation + Onlyforth \needs Transient include meta.fb + 2 loadfrom META.fb + + new FORTH.COM Onlyforth Target definitions + + 4 &111 thru \ Standard 8088-System + warning on + flush \ close FORTH.COM + +cr .( new kernel as "FORTH.COM" written) cr bell +( ----- 002 ) +\\ The use of the 8088/86 register ks 27 oct 86 + +The assembler uses forth style names for the register +Mapping of Forth Registernames to INTEL Register Names: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A and C are free to use + +D <=> DX D- <=> DL D+ <=> DH + the Top of (Data-) Stack (TOS) + +R <=> BX R- <=> RL R+ <=> RH + the Return_stack_pointer +( ----- 003 ) +\\ The use of the 8088/86 register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, free for general use + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + All segment registers are set to the value of code-segment + C: and must be restored to the same if changed in the code +( ----- 004 ) +\ FORTH Preamble and ID ks 11 m„r 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Coldstart values for user variables + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 Version 3.9.3" +( ----- 005 ) +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next is in-line code. All "nexts" are linked into a +\ list with the anchor NEXT-LINK for the debugger + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target +( ----- 006 ) +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code +( ----- 007 ) +\ User variables ks 16 sep 88 + 8 uallot drop \ Space for the multitasker + \ Fields: entry link spare SPsave + \ Length compatible to 68000, 6502 and 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link ( TODO: Why is UDP a user variable? ) + User udp \ points to next free addr in User_area +( ----- 008 ) +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment +( ----- 009 ) +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict +( ----- 010 ) +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; +( ----- 011 ) +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; +( ----- 012 ) +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code +( ----- 013 ) +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; +( ----- 014 ) +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code +( ----- 015 ) +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; +( ----- 016 ) +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; +( ----- 017 ) +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +( ----- 018 ) +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +( ----- 019 ) +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; +( ----- 020 ) +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code +( ----- 021 ) +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; +( ----- 022 ) +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code +( ----- 023 ) +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code +( ----- 024 ) +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; +( ----- 025 ) +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict +( ----- 026 ) +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; +( ----- 027 ) +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; +( ----- 028 ) +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; +( ----- 029 ) +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; +( ----- 030 ) +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; +( ----- 031 ) +\\ min max umax umin extend 10Mar8 + +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; +( ----- 032 ) +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; +( ----- 033 ) +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\\ + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + + : (do ( limit start -- ) over - dodo ; restrict + : (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict +( ----- 034 ) +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code +( ----- 035 ) +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict +( ----- 036 ) +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict +( ----- 038 ) +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | +( ----- 039 ) +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; +( ----- 040 ) +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; +( ----- 041 ) +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; +( ----- 042 ) +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; +( ----- 043 ) +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code +( ----- 044 ) +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; +( ----- 045 ) +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; +( ----- 046 ) +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict +( ----- 047 ) +\ input strings ks 23 dez 87 + + Variable #tib #tib off + Variable >tib here >tib ! $50 allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; +( ----- 048 ) +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code +( ----- 049 ) +\\ scan skip /string ks 29 jul 87 + + : skip ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : /string ( addr0 len0 +n -- addr1 len1 ) + over umin rot over + -rot - ; +( ----- 050 ) +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code +( ----- 051 ) +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\\ high level definition, without umlauts + + : capital ( char -- char') + dup [char] a [ char z 1+ ] Literal + uwithin not ?exit [ char a char A - ] Literal - ; + + : upper ( addr len -- ) + bounds ?DO I c@ capital I c! LOOP ; +( ----- 052 ) +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code +( ----- 053 ) +\ postpone cs 19 apr 21 + + : postpone + ' dup >name c@ $40 and + IF , ELSE [compile] compile compile , THEN ; immediate + +\\ (word +| : (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string r@ skip + over swap r> scan >r rot over swap - r> 0<> - >in ! + over - here dup >r place bl r@ count + c! r> ; + +( ----- 054 ) +\ source word parse name ks 03 aug 87 + + defer source + : (source ( -- addr len ) tib #tib @ ; + ' (source Is source + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; +( ----- 055 ) +\ state char [char] ," "lit (" " cs 19 apr 21 + Variable state state off + : char ( "char" -- c ) bl word 1+ c@ ; + : [char] ( "char" -- ) + char [compile] Literal ; immediate restrict + : ," [char] " parse here over 1+ allot place ; + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + : (" "lit ; restrict + : " compile (" ," align ; immediate restrict +( ----- 056 ) +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( [char] ) parse 2drop ; immediate + : .( [char] ) parse type ; immediate + + : \ >in @ negate c/l mod >in +! ; immediate + : \\ b/blk >in ! ; immediate + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; +( ----- 057 ) +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup [char] 9 > + ( IF [ char A char 9 - 1- ] Literal - dup [char] 9 > and) + IF 7 - dup [char] 9 > and + THEN [char] 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; +( ----- 058 ) +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : nchr ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + [char] , over = swap [char] . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + [char] $ case? IF $10 true exit THEN + [char] H case? IF $10 true exit THEN + [char] & case? IF &10 true exit THEN + [char] % case? IF 2 true exit THEN false ; +( ----- 059 ) +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; +( ----- 060 ) +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum nchr + [char] - case? IF rdrop true >r end? ?nonum nchr THEN + fixbase? IF base ! end? ?nonum nchr THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num nchr digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num nchr + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; +( ----- 061 ) +\ hide reveal immediate restrict ks 18 m„r 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; +( ----- 062 ) +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; +( ----- 063 ) +\ Does> ; ks 18 m„r 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict +( ----- 064 ) +\ ?head | alignments ks 19 m„r 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + \ no alignment required on x86 + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; +( ----- 065 ) +\ Create Variable ks 19 m„r 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; +( ----- 066 ) +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + +\\ + + : nfa? ( thread cfa -- nfa / false ) >r + BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; +( ----- 067 ) +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; +( ----- 068 ) +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code +( ----- 069 ) +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code +( ----- 070 ) +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; +( ----- 071 ) +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; +( ----- 072 ) +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] char capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; +( ----- 073 ) +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code +( ----- 074 ) +\\ -text (find ks 02 okt 87 + + : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) + over bounds + DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + + : (find ( string thread -- str false / NFA +n ) + over c@ $1F and >r @ + BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = + IF dup 1+ r@ 4 pick 1+ -text + 0= IF rdrop -rot drop exit + THEN THEN drop + REPEAT rdrop ; +( ----- 075 ) +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; +( ----- 076 ) +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; +( ----- 077 ) +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; +( ----- 078 ) +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate +( ----- 079 ) +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; +( ----- 080 ) +\ .status push ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + +( ----- 081 ) +\ depth rdepth postpone value to + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + : value create , DOES> @ ; + : TO ( x "name" -- ) + ' >body state @ + IF [compile] Literal ! ELSE ! THEN ; immediate + +( ----- 082 ) +\ prompt quit ks 16 sep 88 + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off + key? IF key drop THEN + 'quit ; + +( ----- 083 ) +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; +( ----- 084 ) +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict +( ----- 085 ) +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; +( ----- 086 ) +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit [char] - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + [char] 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +( ----- 087 ) +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; +( ----- 088 ) +\ c/l l/s + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + +( ----- 089 ) +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT +( ----- 090 ) + +( ----- 091 ) + $10000 Constant limit Variable first + $408 Constant b/buf \ real size of block buffer + $400 Constant b/blk \ bytes/block + + Defer r/w \ low level disk access word + +( ----- 092 ) + +( ----- 093 ) + +( ----- 094 ) + +( ----- 095 ) + +( ----- 096 ) + +( ----- 097 ) + +( ----- 098 ) + +( ----- 099 ) +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; +( ----- 100 ) +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; +( ----- 101 ) +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words + custom-remove heap swap - hallot dp ! last off ; +( ----- 102 ) +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; +( ----- 103 ) +\ save stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; +( ----- 104 ) +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop +( ----- 105 ) +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions +( ----- 106 ) +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys 'cold Onlyforth $80 c@ 0= IF + page logo count type cr THEN (restart ; +( ----- 107 ) +\ (boot ks 11 m„r 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code +( ----- 108 ) +\ restart ks 09 m„r 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code +( ----- 109 ) +\ bye ks 11 m„r 89 + + : bye empty poweroff ; + +( ----- 110 ) +\ cold ks 09 m„r 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + \ #segs # call $41 # R add \ another k for the ints + \ $4A # A+ mov $21 int \ alloc memory + \ CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code +( ----- 111 ) +\ System patchup ks 16 sep 88 + + 1 &11 +thru \ PC-BIOS interface + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved +( ----- 112 ) +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code +( ----- 113 ) +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code +( ----- 114 ) + +( ----- 115 ) +\ APM PC Shutdown - poweroff + + CODE poweroff ( -- ) + \ Connect to APM API + $5301 # A mov R R xor $15 int + \ Try to set APM version (to 1.2) + $530E # A mov R R xor $0102 # C mov $15 int + \ Turn off the system + $5307 # A mov $01 # R mov $03 # C mov $15 int + END-CODE +( ----- 116 ) +\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + A- D- xchg 0 # D+ mov Next end-code + + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + : empty-keys ; + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +( ----- 117 ) +\ (decode expect ks 16 sep 88 + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr $26 Constant #eof + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + #lf case? IF exit THEN + #eof case? IF bye THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop +( ----- 118 ) +\ BIOS character output ks 29 jun 87 + + Code charout ( char -- ) D- A- mov + $E # A+ mov $10 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; +( ----- 119 ) +\ BIOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop + +( ----- 120 ) + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code +( ----- 121 ) +\ zero terminated strings cas 25jan06 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + : asciz ( -- asciz ) name here >asciz ; diff --git a/8086/pc-baremetal/meta.fth b/8086/pc-baremetal/meta.fth new file mode 100644 index 0000000..030ef05 --- /dev/null +++ b/8086/pc-baremetal/meta.fth @@ -0,0 +1,545 @@ +( ----- 001 ) +\ Target compiler loadscr ks cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + 3 &27 thru Onlyforth savesystem meta.com + +cr .( Metacompiler saved as META.COM ) +( ----- 002 ) +\ Predefinitions loadscreen ks 30 apr 88 + + &28 load + +cr .( Predefinitions geladen ...) cr +( ----- 003 ) +\ Target header pointers ks 29 jun 87 + + Variable tfile tfile off \ handle of target file + Variable tdp tdp off \ target dp + Variable displace displace off \ diplacement of code + Variable ?thead ?thead off \ for headerless code + Variable tlast tlast off \ last name in target + Variable glast' glast' off \ acf of latest ghost + Variable tdoes> tdoes> off \ code addr of last does + Variable tdodo tdodo off \ location of dodo + Variable >in: >in: off \ last :-def + Variable tvoc tvoc off \ + Variable tvoc-link tvoc-link off \ voc-link in target + Variable tnext-link tnext-link off \ link for tracer +( ----- 004 ) +\ Target header pointers ks 10 okt 87 + + : there ( -- taddr ) tdp @ ; + + : new pushfile makefile isfile@ tfile ! + tvoc-link off tnext-link off + $100 tdp ! $100 displace ! ; +( ----- 005 ) +\ Ghost-creating ks 07 dez 87 + +0 | Constant 0 | Constant + +| Create gname $21 allot + +| : >heap ( from quan -- ) \ heap over - 1 and + \ align + dup hallot heap swap cmove ; + + : symbolic ( string -- cfa.ghost ) + count dup 1 $1F uwithin not Abort" invalid Gname" + gname place BL gname append align here >r makeview , + state @ IF context ELSE current THEN @ @ dup @ , + gname count under here place 1+ allot align + here r@ - , 0 , 0 , r@ here over - >heap + heap 2+ rot ! r> dp ! heap + ; +( ----- 006 ) +\ ghost words ks 07 dez 87 + + : gfind ( string -- cfa tf / string ff ) + >r 1 r@ c+! r@ find -1 r> c+! ; + + : ghost ( -- cfa ) name gfind ?exit symbolic ; + + : gdoes> ( cfa.ghost -- cfa.does ) + 4 + dup @ IF @ exit THEN + here , 0 , dup 4 >heap + dp ! heap swap ! heap ; +( ----- 007 ) +\ ghost utilities ks 29 jun 87 + + : g' ( -- acf ) name gfind 0= Abort" ?T?" ; + + : '. g' dup @ case? + IF ." forw" ELSE - Abort" ??" ." res" THEN + 2+ dup @ 5 u.r 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - Abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + + ' ' Alias h' +( ----- 008 ) +\ .unresolved ks 29 jun 87 + +| : forward? ( cfa -- cfa / exit&true ) + dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; + +| : unresolved? ( addr -- f ) 2+ + dup count $1F and + 1- c@ bl = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words ( thread -- ) + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + + : .unresolved voc-link @ + BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; +( ----- 009 ) +\ Extending Vocabularys for Target-Compilation ks 29 jun 87 + + Vocabulary Ttools + Vocabulary Defining + + : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + + Vocabulary Transient tvoc off + + Root definitions + + : T Transient ; immediate + : H Forth ; immediate + : D Defining ; immediate + + Forth definitions +( ----- 010 ) +\ Image and byteorder ks 02 jul 87 + +| Code >byte ( 16b -- 8b- 8b+ ) A A xor + D- A- xchg D+ D- xchg A push Next end-code + +| Code byte> ( 8b- 8b+ -- 16b ) + A pop D- D+ mov A- D- xchg Next end-code + +| : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; + + Transient definitions + + : c@ ( addr -- 8b ) [ Dos ] + >target file@ dup 0< Abort" nie abgespeichert" ; + + : c! ( 8b addr -- ) [ Dos ] >target file! ; +( ----- 011 ) +\ Transient primitives ks 09 jul 87 + : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; + : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; + + : cmove ( from.mem to.target quan -- ) [ Dos ] + >r >target fseek ds@ swap r> tfile @ lfputs ; +\ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; + + : here ( -- taddr ) H tdp @ ; + : here! ( taddr -- ) H tdp ! ; + : allot ( n -- ) H tdp +! ; + : c, ( 8b -- ) T here c! 1 allot H ; + : , ( 16b -- ) T here ! 2 allot H ; + : align ( -- ) H ; immediate + : even ( addr1 -- addr2 ) H ; immediate + : halign H ; immediate +( ----- 012 ) +\ Transient primitives ks 29 jun 87 + + : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; + + : ," H here ," here over dp ! + over - T here swap dup allot cmove H ; + + : fill ( addr quan 8b -- ) H + -rot bounds ?DO dup I T c! H LOOP drop ; + : erase ( addr quan -- ) H 0 T fill H ; + : blank ( addr quan -- ) H bl T fill H ; + + : move-threads H tvoc @ tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + Error" some undef. Target-Vocs left" drop ; +( ----- 013 ) +\ Resolving ks 29 jun 87 + Forth definitions + + : resolve ( cfa.ghost cfa.target -- ) over dup @ = + IF space dup >name .name ." exists " ?cr + 2+ ! drop exit THEN >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = Abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + + : resdoes> ( acf.ghost acf.target -- ) swap gdoes> + dup @ = IF 2+ ! exit THEN swap resolve ; + +here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! +here 2+ 0 ] Does> @ T , H ; ' >body ! +( ----- 014 ) +\ compiling names into targ. ks 10 okt 87 + +| : tlatest ( -- addr ) current @ 6 + ; + + : (theader ?thead @ IF 1 ?thead +! exit THEN + >in @ bl word swap >in ! dup count upper + dup c@ 1 $20 uwithin not Abort" inval. Tname" + blk @ $8400 or T align , H + there tlatest @ T , H tlatest ! there tlast ! + there over c@ 1+ dup T allot cmove align H ; + + : theader tlast off + (theader ghost dup glast' ! there resolve ; +( ----- 015 ) +\ prebuild defining words ks 29 jun 87 + +| : (prebuild >in @ Create >in ! + r> dup 2+ >r @ here 2- ! ; + +| : tpfa, there , ; + + : prebuild ( addr check# -- check# ) 0 ?pairs + dup IF compile (prebuild dup , THEN + compile theader ghost gdoes> , + IF compile tpfa, THEN 0 ; immediate + + : dummy 0 ; + + : DO> [compile] Does> here 3 - compile @ 0 ] ; +( ----- 016 ) +\ Constructing defining words in Host kks 07 dez 87 + +| : defcomp ( string -- ) dup ['] Defining search ?dup + IF 0> IF nip execute exit THEN drop dup THEN + find ?dup IF 0< IF nip , exit THEN THEN + drop ['] Forth search ?dup + IF 0< IF , exit THEN execute exit THEN + number? ?dup 0= Abort" ?" + 0> IF swap [compile] Literal THEN [compile] Literal ; + +| : definter ( string -- ) dup ['] Defining search ?dup + IF 0< IF nip execute exit THEN THEN drop + find ?dup IF 1 and 0= Abort" compile only" execute exit + THEN number? 0= Error" ?" ; +( ----- 017 ) +\ Constructing defining words in Host ks 22 dez 87 + +| : (;tcode r> @ tlast @ T count + ! H ; + +Defining definitions + + : ] H ] ['] defcomp Is parser ; + + : [ H [compile] [ ['] definter Is parser ; immediate + + : ; H [compile] ; [compile] \\ ; immediate + + : Does> H compile (;tcode tdoes> @ , + [compile] ; -2 allot [compile] \\ ; immediate +D ' Does> Alias ;Code immediate H +( ----- 018 ) +\ reinterpreting defining words ks 22 dez 87 + Forth definitions + + : ?reinterpret ( f -- ) 0=exit + state @ >r >in @ >r adr parser @ >r + >in: @ >in ! : D ] H interpret + r> Is parser r> >in ! r> state ! ; + + : undefined? ( -- f ) glast' @ 4+ @ 0= ; + +| : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN + dup T c@ rot or swap c! H ; + +| : nfa? ( acf alf -- anf / acf ff ) + BEGIN dup WHILE 2dup 2+ T count $1F and + even H = + IF 2+ nip exit THEN T @ H REPEAT ; +( ----- 019 ) +\ the 8086 Assembler ks 29 jun 87 + +| Create relocate ] T c, , here ! c! H [ + +Transient definitions + + : Assembler H [ Assembler ] relocate >codes ! Assembler ; + + : >label ( 16b -- ) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; + + : Label T here >label Assembler H ; + + : Code H theader T here 2+ , Assembler H ; +( ----- 020 ) +( Transient primitives ks 17 dec 83 ) + +' exit Alias exit ' load Alias load +' / Alias / ' thru Alias thru +' swap Alias swap ' * Alias * +' dup Alias dup ' drop Alias drop +' /mod Alias /mod ' rot Alias rot +' -rot Alias -rot ' over Alias over +' 2* Alias 2* ' + Alias + +' - Alias - ' 1+ Alias 1+ +' 2+ Alias 2+ ' 1- Alias 1- +' 2- Alias 2- ' negate Alias negate +' 2swap Alias 2swap ' 2dup Alias 2dup +( ----- 021 ) +\ Transient primitives kks 29 jun 87 + + ' also Alias also ' words Alias words +' definitions Alias definitions ' hex Alias hex +' decimal Alias decimal ' ( Alias ( immediate + ' \ Alias \ immediate ' \\ Alias \\ immediate + ' .( Alias .( immediate ' [ Alias [ immediate + ' cr Alias cr +' end-code Alias end-code ' Transient Alias Transient + ' +thru Alias +thru ' +load Alias +load + ' .s Alias .s + +Tools ' trace Alias trace immediate +( ----- 022 ) +\ immediate words and branch primitives ks 29 jun 87 + + : >mark ( -- addr ) T here 0 , H ; + : >resolve ( addr -- ) T here over - swap ! H ; + : name ks 29 jun 87 + + : ' ( -- acf ) H g' dup @ - + IF Error" undefined" THEN 2+ @ ; + + : compile H ghost , ; immediate restrict + + : >name ( acf -- anf / ff ) H tvoc + BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN + swap REPEAT nip ; +( ----- 024 ) +\ >name Alias ks 29 jun 87 + + : >body ( acf -- apf ) H 2+ ; + + : Alias ( n -- ) H tlast off + (theader ghost over resolve T , H $20 flag! ; + + : on ( addr -- ) H true swap T ! H ; + : off ( addr -- ) H false swap T ! H ; +( ----- 025 ) +\ Target tools ks 9 sep 86 + Onlyforth + +| : .tfield ( taddr len quan -) >r under Pad swap + bounds ?DO dup T c@ I H c! 1+ LOOP drop + Pad over type r> swap - 0 max spaces ; + + ' view Alias hview + + Ttools also definitions + +| : ?: ( addr -- addr ) dup 4 u.r ." :" ; +| : @? ( addr -- addr ) dup T @ H 6 u.r ; +| : c? ( addr -- addr ) dup T c@ H 3 .r ; +( ----- 026 ) +\ Ttools for decompiling ks 9 sep 86 + + : s ( addr -- addr+ ) ?: space c? 4 spaces + T count 2dup + even -rot 18 .tfield ; + + : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H + ?dup IF T count H ELSE 0 0 THEN + $1F and $18 .tfield 2+ ; + + : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; + + : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; + + : c ( addr -- addr+1 ) 1 d 15 spaces ; +( ----- 027 ) +\ Tools for decompiling ks 29 jun 87 + + : b ( addr -- addr+2 ) ?: @? dup T @ H + over + 6 u.r 2+ 14 spaces ; + + : dump ( addr n -- ) + bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; + + : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; +( ----- 028 ) +\ Predefinitions loadscreen ks 29 jun 87 + Onlyforth + + : clear H true Abort" There are ghosts" ; + + + 1 $B +thru +( ----- 029 ) +\ Literal ['] ?" ." " ks 29 jun 87 + Transient definitions Forth + + : Literal ( n -- ) H dup $FF00 and + IF T compile lit , H exit THEN T compile clit c, H ; + immediate + + : char H bl word 1+ c@ ; + : [char] H char T [compile] Literal H ; immediate + + : ['] T compile lit H ; immediate + : ." T compile (." ," align H ; immediate + : " T compile (" ," align H ; immediate +( ----- 030 ) +\ Target compilation ] ks 07 dez 87 + Forth definitions + +| : tcompile ( string -- ) dup find ?dup + IF 0> IF nip execute exit THEN THEN + drop gfind IF execute exit THEN number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + symbolic execute ; + + Transient definitions + + : ] H ] ['] tcompile Is parser ; +( ----- 031 ) +\ Target conditionals ks 10 sep 86 + + : IF T compile ?branch >mark H 1 ; immediate restrict + : THEN abs 1 ?pairs T >resolve H ; immediate restrict + : ELSE 1 ?pairs T compile branch >mark + swap >resolve H -1 ; immediate restrict + + : BEGIN T mark H -2 2swap ; + immediate restrict + +| : (repeat 2 ?pairs T resolve H REPEAT ; + + : UNTIL T compile ?branch (repeat H ; immediate restrict + : REPEAT T compile branch (repeat H ; immediate restrict +( ----- 032 ) +\ Target conditionals Abort" etc. ks 09 feb 88 + + : DO T compile (do >mark H 3 ; immediate restrict + : ?DO T compile (?do >mark H 3 ; immediate restrict + : LOOP 3 ?pairs T compile (loop + compile endloop >resolve H ; immediate restrict + : +LOOP 3 ?pairs T compile (+loop + compile endloop >resolve H ; immediate restrict + + : Abort" T compile (abort" ," align H ; immediate restrict + : Error" T compile (error" ," align H ; immediate restrict +( ----- 033 ) +\ Target does> ;code ks 29 jun 87 + +| : dodoes> T compile (;code + H glast' @ there resdoes> there tdoes> ! ; + + : Does> H undefined? T dodoes> + $E9 c, H tdodo @ there - 2- T , + H ?reinterpret ; immediate restrict + + : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret + T [compile] [ Assembler H ; immediate restrict +( ----- 034 ) +\ User ks 09 jul 87 + Forth definitions + + Variable torigin torigin off \ cold boot vector + Variable tudp tudp off \ user variable counter + : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; + + Transient definitions Forth + + : origin! ( taddr -- ) H torigin ! tudp off ; + : uallot ( n -- offset ) H tudp @ swap tudp +! ; + + DO> >user ; + : User T prebuild User 2 uallot c, H ; +( ----- 035 ) +\ Variable Constant Create ks 01 okt 87 + + DO> ; + : Variable T prebuild Create 2 allot H ; + + DO> T @ H ; + : Constant T prebuild Constant , H ; + + DO> ; + : Create T prebuild Create H ; + + : Create: T Create ] H end-code 0 ; +( ----- 036 ) +\ Defer Is Vocabulary ks 29 jun 87 + + DO> ; + : Defer T prebuild Defer 2 allot ; + : Is T ' >body H state @ + IF T compile (is , H exit THEN T ! H ; immediate + + dummy + : Vocabulary H >in @ Vocabulary >in ! + T prebuild Vocabulary 0 , 0 , + H there tvoc-link @ T , H tvoc-link ! ; +( ----- 037 ) +\ File ks 19 m„r 88 + Forth definitions + + Variable tfile-link tfile-link off + Variable tfileno tfileno off + &45 Constant tb/fcb + + Transient definitions Forth + + dummy + : File T prebuild File here tb/fcb 0 fill + here H tfile-link @ T , H tfile-link ! + 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , + here dup >r 1+ tb/fcb &13 - allot H tlast @ + T count dup r> c! + H bounds ?DO I T c@ over c! H 1+ LOOP drop ; +( ----- 038 ) +\ : ; compile Host [compile] ks 29 jun 87 + + dummy + : : H >in @ >in: ! T prebuild : ] H end-code 0 ; + + : ; 0 ?pairs T compile unnest + [compile] [ H ; immediate restrict + + : compile T compile compile H ; immediate restrict + + : Host H Onlyforth ; + + : Compiler H Onlyforth Transient also definitions ; + + : [compile] H ghost execute ; immediate restrict +( ----- 039 ) +\ Target ks 29 jun 87 + + Onlyforth + + : Target H vp off Transient also definitions ; + + Transient definitions + + ghost c, drop diff --git a/8086/pc-baremetal/vlist.fth b/8086/pc-baremetal/vlist.fth new file mode 100644 index 0000000..dc1ad72 --- /dev/null +++ b/8086/pc-baremetal/vlist.fth @@ -0,0 +1,18 @@ +: .flags ( cntf -- ) + dup $80 and if [char] R emit else space then + dup $40 and if [char] I emit else space then + $20 and if [char] N emit else space then ; + +: vlist ( -- ) base @ cr + ." Word" &25 spaces ." Flags CFA Length" cr + [compile] char capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF dup .name + dup c@ $F and &20 swap - spaces ( Name ) + dup c@ .flags space ( Count Field ) + dup name> hex u. space ( CFA ) + 2- 2- @ decimal 3 u.r space ( Block ) + cr + ELSE drop THEN + REPEAT drop rdrop base ! ; diff --git a/8086/pc-baremetal/volks4th.com b/8086/pc-baremetal/volks4th.com new file mode 100644 index 0000000..072437c Binary files /dev/null and b/8086/pc-baremetal/volks4th.com differ diff --git a/README.ORG b/README.ORG index de07525..1469113 100644 --- a/README.ORG +++ b/README.ORG @@ -11,9 +11,14 @@ resources. Some modern Forth Systems were influenced by or were derived from VolksForth (GNU-Forth, bigForth). -The current Version of VolksForth is 3.81. Version 3.9.x will be -interim versions on the way to sync all VolksForth targets and move -towards compliance with the 2012 Forth standard. +On most platforms the current version of VolksForth is 3.8x. +Versions 3.9.x are interim versions towards compliance with the +2012 Forth standard, and at the same time towards a unification +(as far as feasible) of the sources of the different platforms. +Also included in 3.9.x versions is the transition from block files +to stream files as primary source format, and an introduction of +make-based build and test automation. +So far the 6502/C64 VolksForth (C64/Plus4/X16) is on a 3.9.x version. Version 3.8.x is based on the Forth 83 standard, Version 4.00 will be based on the current 2012 Standard (https://forth-standard.org). diff --git a/doc/Target-Glossary.org b/doc/Target-Glossary.org index 5120139..fef7fbf 100644 --- a/doc/Target-Glossary.org +++ b/doc/Target-Glossary.org @@ -4,427 +4,441 @@ Comparison of user visible words in each target base kernel image - | Word | C64/C16 | CP/M | MS-DOS | Atari ST | Atari 8bit | Apple 1/2 | PET | py65 | | - |---------------+---------+------+--------+----------+------------+-----------+-----+------+---| - | ASSEMBLER | core | | | | | | | core | | - | FORTH-83 | core | | | | | | | core | | - | (R/W | | | | | | | | core | | - | DRVINIT | core | | | | | | | core | | - | DRV? | core | | | | | | | core | | - | >DRIVE | core | | | | | | | core | | - | DRIVE | core | | | | | | | core | | - | BLK/DRV | core | | | | | | | core | | - | B/BLK | core | | | | | | | core | | - | DISPLAY | core | | | | | | | core | | - | KEYBOARD | core | | | | | | | core | | - | 65TYPE | | | | | | | | | | - | 65AT? | | | | | | | | | | - | 65AT | | | | | | | | | | - | 65PAGE | | | | | | | | | | - | 65DEL | | | | | | | | | | - | 65CR | | | | | | | | | | - | 65EMIT | | | | | | | | | | - | (EMIT | | | | | | | | | | - | 65EXPECT | | | | | | | | | | - | 65DECODE | | | | | | | | | | - | #LF | | | | | | | | core | | - | #ESC | | | | | | | | core | | - | #CR | core | | | | | | | core | | - | #BS | core | | | | | | | core | | - | 65KEY | | | | | | | | | | - | CUROFF | core | | | | | | | core | | - | CURON | core | | | | | | | core | | - | GETKEY | core | | | | | | | core | | - | 65KEY? | | | | | | | | | | - | RESTART | core | | | | | | | core | | - | COLD | core | | | | | | | core | | - | 'RESTART | core | | | | | | | core | | - | 'COLD | core | | | | | | | core | | - | EXPECT | core | | | | | | | core | | - | DECODE | core | | | | | | | core | | - | KEY? | core | | | | | | | core | | - | KEY | core | | | | | | | core | | - | INPUT: | core | | | | | | | core | | - | COL | core | | | | | | | core | | - | ROW | core | | | | | | | core | | - | AT? | core | | | | | | | core | | - | AT | core | | | | | | | core | | - | PAGE | core | | | | | | | core | | - | DEL | core | | | | | | | core | | - | TYPE | core | | | | | | | core | | - | CR | core | | | | | | | core | | - | EMIT | core | | | | | | | core | | - | OUTPUT: | core | | | | | | | core | | - | ?CR | core | | | | | | | core | | - | STOP? | core | | | | | | | core | | - | BYE | core | | | | | | | core | | - | SAVE | core | | | | | | | core | | - | EMPTY | core | | | | | | | core | | - | FORGET | core | | | | | | | core | | - | (FORGET | core | | | | | | | core | | - | CLEAR | core | | | | | | | core | | - | ALL-BUFFERS | core | | | | | | | core | | - | FREEBUFFER | core | | | | | | | core | | - | ALLOTBUFFER | core | | | | | | | core | | - | FIRST | core | | | | | | | core | | - | LIMIT | core | | | | | | | core | | - | CONVEY | core | | | | | | | core | | - | COPY | core | | | | | | | core | | - | BLKMOVE | core | | | | | | | | | - | (COPY | core | | | | | | | | | - | FLUSH | core | | | | | | | core | | - | EMPTY-BUFFERS | core | | | | | | | core | | - | SAVE-BUFFERS | core | | | | | | | core | | - | UPDATE | core | | | | | | | core | | - | BLOCK | core | | | | | | | core | | - | BUFFER | core | | | | | | | core | | - | (BLOCK | core | | | | | | | core | | - | (BUFFER | core | | | | | | | core | | - | CORE? | core | | | | | | | core | | - | R/W | core | | | | | | | core | | - | DISKERR | core | | | | | | | core | | - | (DISKERR | core | | | | | | | core | | - | B/BUF | core | | | | | | | core | | - | BUFFERS | core | | | | | | | | | - | PREV | core | | | | | | | core | | - | FILE | core | | | | | | | core | | - | UNLOCK | core | | | | | | | core | | - | LOCK | core | | | | | | | core | | - | PAUSE | core | | | | | | | core | | - | LIST | core | | | | | | | core | | - | L/S | core | | | | | | | core | | - | C/L | core | | | | | | | core | | - | .S | core | | | | | | | core | | - | U. | core | | | | | | | core | | - | . | core | | | | | | | core | | - | D. | core | | | | | | | core | | - | U.R | core | | | | | | | core | | - | .R | core | | | | | | | core | | - | D.R | core | | | | | | | core | | - | #S | core | | | | | | | core | | - | # | core | | | | | | | core | | - | SIGN | core | | | | | | | core | | - | #> | core | | | | | | | core | | - | <# | core | | | | | | | core | | - | HOLD | core | | | | | | | core | | - | SPACES | core | | | | | | | core | | - | SPACE | core | | | | | | | core | | - | -TRAILING | core | | | | | | | core | | - | BL | core | | | | | | | core | | - | ERROR" | core | | | | | | | core | | - | ABORT" | core | | | | | | | core | | - | (ABORT" | core | | | | | | | core | | - | (ERROR | core | | | | | | | core | | - | R# | core | | | | | | | core | | - | SCR | core | | | | | | | core | | - | ABORT | core | | | | | | | core | | - | 'ABORT | core | | | | | | | core | | - | STANDARDI/O | core | | | | | | | core | | - | QUIT | core | | | | | | | core | | - | 'QUIT | core | | | | | | | core | | - | (QUIT | core | | | | | | | core | | - | DEPTH | core | | | | | | | core | | - | RDEPTH | core | | | | | | | core | | - | --> | core | | | | | | | core | | - | +THRU | core | | | | | | | core | | - | THRU | core | | | | | | | core | | - | +LOAD | core | | | | | | | core | | - | LOAD | core | | | | | | | core | | - | PUSH | core | | | | | | | core | | - | .STATUS | core | | | | | | | core | | - | ?STACK | core | | | | | | | core | | - | IS | core | | | | | | | core | | - | (IS | core | | | | | | | core | | - | DEFER | core | | | | | | | core | | - | ] | core | | | | | | | core | | - | [ | core | | | | | | | core | | - | INTERPRET | core | | | | | | | core | | - | NO.EXTENSIONS | core | | | | | | | core | | - | NOTFOUND | core | | | | | | | core | | - | >INTERPRET | core | | | | | | | core | | - | NULLSTRING? | core | | | | | | | core | | - | ['] | core | | | | | | | core | | - | [COMPILE] | core | | | | | | | core | | - | ' | core | | | | | | | core | | - | FIND | core | | | | | | | core | | - | (FIND | core | | | | | | | core | | - | WORDS | core | | | | | | | core | | - | ORDER | core | | | | | | | core | | - | DEFINITIONS | core | | | | | | | core | | - | ONLYFORTH | core | | | | | | | core | | - | ONLY | core | | | | | | | core | | - | FORTH | core | | | | | | | core | | - | VOCABULARY | core | | | | | | | core | | - | TOSS | core | | | | | | | core | | - | ALSO | core | | | | | | | core | | - | CONTEXT | core | | | | | | | core | | - | CURRENT | core | | | | | | | core | | - | VP | core | | | | | | | core | | - | ALIAS | core | | | | | | | core | | - | USER | core | | | | | | | core | | - | UALLOT | core | | | | | | | core | | - | VARIABLE | core | | | | | | | core | | - | CONSTANT | core | | | | | | | core | | - | ; | core | | | | | | | core | | - | : | core | | | | | | | core | | - | CREATE: | core | | | | | | | | | - | .NAME | core | | | | | | | core | | - | >BODY | core | | | | | | | core | | - | NAME> | core | | | | | | | core | | - | >NAME | core | | | | | | | core | | - | NFA? | core | | | | | | | | | - | CREATE | core | | | | | | | core | | - | WARNING | core | | | | | | | core | | - | \vert | core | | | | | | | core | | - | ?HEAD | core | | | | | | | core | | - | DOES> | core | | | | | | | core | | - | HEAP? | core | | | | | | | core | | - | HEAP | core | | | | | | | core | | - | HALLOT | core | | | | | | | core | | - | CLEARSTACK | core | | | | | | | core | | - | RESTRICT | core | | | | | | | core | | - | IMMEDIATE | core | | | | | | | core | | - | RECURSIVE | core | | | | | | | core | | - | REVEAL | core | | | | | | | core | | - | HIDE | core | | | | | | | core | | - | LAST | core | | | | | | | core | | - | NUMBER | core | | | | | | | core | | - | 'NUMBER? | core | | | | | | | | | - | NUMBER? | core | | | | | | | core | | - | DPL | core | | | | | | | core | | - | PREVIOUS | core | | | | | | | | | - | CHAR | core | | | | | | | | | - | END? | core | | | | | | | | | - | CONVERT | core | | | | | | | core | | - | ACCUMULATE | core | | | | | | | core | | - | DIGIT? | core | | | | | | | core | | - | DECIMAL | core | | | | | | | core | | - | HEX | core | | | | | | | core | | - | \NEEDS | core | | | | | | | core | | - | \\ | core | | | | | | | core | | - | \ | core | | | | | | | core | | - | .( | core | | | | | | | core | | - | ( | core | | | | | | | core | | - | ." | core | | | | | | | core | | - | (." | core | | | | | | | core | | - | " | core | | | | | | | core | | - | (" | core | | | | | | | core | | - | "LIT | core | | | | | | | core | | - | ," | core | | | | | | | core | | - | ASCII | core | | | | | | | core | | - | STATE | core | | | | | | | core | | - | NAME | core | | | | | | | core | | - | PARSE | core | | | | | | | core | | - | WORD | core | | | | | | | core | | - | SOURCE | core | | | | | | | core | | - | CAPITALIZE | core | | | | | | | core | | - | CAPITAL | core | | | | | | | core | | - | /STRING | core | | | | | | | core | | - | SKIP | core | | | | | | | core | | - | SCAN | core | | | | | | | core | | - | QUERY | core | | | | | | | core | | - | TIB | core | | | | | | | core | | - | SPAN | core | | | | | | | core | | - | BLK | core | | | | | | | core | | - | >IN | core | | | | | | | core | | - | >TIB | core | | | | | | | core | | - | #TIB | core | | | | | | | core | | - | COMPILE | core | | | | | | | core | | - | C, | core | | | | | | | core | | - | , | core | | | | | | | core | | - | ALLOT | core | | | | | | | core | | - | PAD | core | | | | | | | core | | - | HERE | core | | | | | | | core | | - | FILL | core | | | | | | | core | | - | ERASE | core | | | | | | | core | | - | COUNT | core | | | | | | | core | | - | PLACE | core | | | | | | | core | | - | MOVE | core | | | | | | | core | | - | CMOVE> | core | | | | | | | core | | - | CMOVE | core | | | | | | | core | | - | UD/MOD | core | | | | | | | core | | - | U/MOD | core | | | | | | | core | | - | */ | core | | | | | | | core | | - | */MOD | core | | | | | | | core | | - | MOD | core | | | | | | | core | | - | / | core | | | | | | | core | | - | /MOD | core | | | | | | | core | | - | 2/ | core | | | | | | | core | | - | M/MOD | core | | | | | | | core | | - | UM/MOD | core | | | | | | | core | | - | 2* | core | | | | | | | core | | - | * | core | | | | | | | core | | - | M* | core | | | | | | | core | | - | UM* | core | | | | | | | core | | - | UNLOOP | core | | | | | | | | | - | LEAVE | core | | | | | | | core | | - | +LOOP | core | | | | | | | core | | - | LOOP | core | | | | | | | core | | - | ?DO | core | | | | | | | core | | - | DO | core | | | | | | | core | | - | UNTIL | core | | | | | | | core | | - | REPEAT | core | | | | | | | core | | - | WHILE | core | | | | | | | core | | - | BEGIN | core | | | | | | | core | | - | ELSE | core | | | | | | | core | | - | THEN | core | | | | | | | core | | - | IF | core | | | | | | | core | | - | CASE? | core | | | | | | | core | | - | ?PAIRS | core | | | | | | | core | | - | RESOLVE | core | | | | | | | core | | - | >MARK | core | | | | | | | core | | - | ?BRANCH | core | | | | | | | core | | - | BRANCH | core | | | | | | | core | | - | J | core | | | | | | | core | | - | I | core | | | | | | | core | | - | (+LOOP | core | | | | | | | core | | - | (LOOP | core | | | | | | | core | | - | ENDLOOP | core | | | | | | | core | | - | BOUNDS | core | | | | | | | core | | - | (?DO | core | | | | | | | core | | - | (DO | core | | | | | | | core | | - | ABS | core | | | | | | | core | | - | DBAS | core | | | | | | | core | | - | EXTEND | core | | | | | | | core | | - | UMIN | core | | | | | | | core | | - | UMAX | core | | | | | | | core | | - | MAX | core | | | | | | | core | | - | MIN | core | | | | | | | core | | - | D< | core | | | | | | | core | | - | D= | core | | | | | | | core | | - | D0= | core | | | | | | | core | | - | = | core | | | | | | | core | | - | U> | core | | | | | | | core | | - | 0<> | core | | | | | | | core | | - | 0> | core | | | | | | | core | | - | > | core | | | | | | | core | | - | U< | core | | | | | | | core | | - | < | core | | | | | | | core | | - | UWITHIN | core | | | | | | | core | | - | 0= | core | | | | | | | core | | - | 0< | core | | | | | | | core | | - | LITERAL | core | | | | | | | core | | - | LIT | core | | | | | | | core | | - | CLIT | core | | | | | | | core | | - | OFF | core | | | | | | | core | | - | ON | core | | | | | | | core | | - | 4 | core | | | | | | | core | | - | 3 | core | | | | | | | core | | - | 2 | core | | | | | | | core | | - | 1 | core | | | | | | | core | | - | 0 | core | | | | | | | core | | - | -1 | core | | | | | | | core | | - | FALSE | core | | | | | | | core | | - | TRUE | core | | | | | | | core | | - | 2- | core | | | | | | | core | | - | 1- | core | | | | | | | core | | - | 4+ | core | | | | | | | | | - | 3+ | core | | | | | | | core | | - | 2+ | core | | | | | | | core | | - | 1+ | core | | | | | | | core | | - | D+ | core | | | | | | | core | | - | DNEGATE | core | | | | | | | core | | - | NEGATE | core | | | | | | | core | | - | NOT | core | | | | | | | core | | - | - | core | | | | | | | core | | - | XOR | core | | | | | | | core | | - | AND | core | | | | | | | core | | - | OR | core | | | | | | | core | | - | + | core | | | | | | | core | | - | 2DUP | core | | | | | | | core | | - | 2DROP | core | | | | | | | core | | - | 2SWAP | core | | | | | | | core | | - | ROLL | core | | | | | | | core | | - | PICK | core | | | | | | | core | | - | UNDER | core | | | | | | | core | | - | NIP | core | | | | | | | core | | - | ROT | core | | | | | | | core | | - | -ROT | core | | | | | | | core | | - | OVER | core | | | | | | | core | | - | ?DUP | core | | | | | | | core | | - | DUP | core | | | | | | | core | | - | SWAP | core | | | | | | | core | | - | DROP | core | | | | | | | core | | - | +! | core | | | | | | | core | | - | ! | core | | | | | | | core | | - | @ | core | | | | | | | core | | - | CTOGGLE | core | | | | | | | core | | - | C! | core | | | | | | | core | | - | C@ | core | | | | | | | core | | - | PERFORM | core | | | | | | | core | | - | EXECUTE | core | | | | | | | core | | - | ?EXIT | core | | | | | | | core | | - | UNNEST | core | | | | | | | | | - | EXIT | core | | | | | | | core | | - | RDROP | core | | | | | | | core | | - | R@ | core | | | | | | | core | | - | R> | core | | | | | | | core | | - | >R | core | | | | | | | core | | - | RP! | core | | | | | | | core | | - | RP@ | core | | | | | | | core | | - | UP! | core | | | | | | | core | | - | UP@ | core | | | | | | | core | | - | SP! | core | | | | | | | core | | - | SP@ | core | | | | | | | core | | - | UDP | core | | | | | | | core | | - | VOC-LINK | core | | | | | | | core | | - | ERRORHANDLER | core | | | | | | | core | | - | INPUT | core | | | | | | | core | | - | OUTPUT | core | | | | | | | core | | - | BASE | core | | | | | | | core | | - | OFFSET | core | | | | | | | core | | - | DP | core | | | | | | | core | | - | R0 | core | | | | | | | core | | - | S0 | core | | | | | | | core | | - | ORIGIN | core | | | | | | | core | | - | NOOP | core | | | | | | | core | | - | RECOVER | core | | | | | | | core | | - | END-TRACE | core | | | | | | | core | | - | LOGO | core | | | | | | | | | - | (64 | core | | | | | | | | | - | C) | core | | | | | | | | | - | (16 | core | | | | | | | | | - | C64INIT | core | | | | | | | | | - | INIT-SYSTEM | core | | | | | | | | | - | INK-POT | core | | | | | | | | | - | FINDEX | core | | | | | | | | | - | INDEX | core | | | | | | | | | - | 1541RW | core | | | | | | | | | - | DISKCLOSE | core | | | | | | | | | - | DISKOPEN | core | | | | | | | | | - | WRITESECTOR | core | | | | | | | | | - | READSECTOR | core | | | | | | | | | - | DERROR? | core | | | | | | | | | - | I/O-STATUS? | core | | | | | | | | | - | BUSINPUT | core | | | | | | | | | - | BUS@ | core | | | | | | | | | - | BUSTYPE | core | | | | | | | | | - | BUS! | core | | | | | | | | | - | BUSIN | core | | | | | | | | | - | (BUSIN | core | | | | | | | | | - | BUSCLOSE | core | | | | | | | | | - | BUSOPEN | core | | | | | | | | | - | BUSOUT | core | | | | | | | | | - | (BUSOUT | core | | | | | | | | | - | ?DEVICE | core | | | | | | | | | - | (?DEVICE | core | | | | | | | | | - | BUSOFF | core | | | | | | | | | - | I/O | core | | | | | | | | | - | (DRV | core | | | | | | | | | - | C64TYPE | core | | | | | | | | | - | C64AT? | core | | | | | | | | | - | C64AT | core | | | | | | | | | - | C64PAGE | core | | | | | | | | | - | C64DEL | core | | | | | | | | | - | C64CR | core | | | | | | | | | - | C64EMIT | core | | | | | | | | | - | PRINTABLE | core | | | | | | | | | - | CON! | core | | | | | | | | | - | C64EXPECT | core | | | | | | | | | - | C64DECODE | core | | | | | | | | | - | C64KEY | core | | | | | | | | | - | C64KEY? | core | | | | | | | | | - | CUSTOM-REMOVE | core | | | | | | | | | - | | | | | | | | | | | + | Word | C64/C16 | CP/M | MS-DOS | Atari ST | Atari 8bit | Apple 1/2 | PET | py65 | 8086bm | Forth2012 | + |---------------+---------+------+--------+----------+------------+-----------+-----+------+--------+-----------| + | ASSEMBLER | core | | | | | | | core | | | + | FORTH-83 | core | | | | | | | core | | | + | (R/W | | | | | | | | core | | | + | DRVINIT | core | | | | | | | core | | | + | DRV? | core | | | | | | | core | | | + | >DRIVE | core | | | | | | | core | | | + | DRIVE | core | | | | | | | core | | | + | BLK/DRV | core | | | | | | | core | | | + | B/BLK | core | | | | | | | core | | | + | DISPLAY | core | | | | | | | core | | | + | KEYBOARD | core | | | | | | | core | | | + | 65TYPE | | | | | | | | | | | + | 65AT? | | | | | | | | | | | + | 65AT | | | | | | | | | | | + | 65PAGE | | | | | | | | | | | + | 65DEL | | | | | | | | | | | + | 65CR | | | | | | | | | | | + | 65EMIT | | | | | | | | | | | + | (EMIT | | | | | | | | | | | + | 65EXPECT | | | | | | | | | | | + | 65DECODE | | | | | | | | | | | + | #LF | | | | | | | | core | | | + | #ESC | | | | | | | | core | | | + | #CR | core | | | | | | | core | | | + | #BS | core | | | | | | | core | | | + | 65KEY | | | | | | | | | | | + | CUROFF | core | | | | | | | core | | | + | CURON | core | | | | | | | core | | | + | GETKEY | core | | | | | | | core | | | + | 65KEY? | | | | | | | | | | | + | RESTART | core | | | | | | | core | | | + | COLD | core | | | | | | | core | | | + | 'RESTART | core | | | | | | | core | | | + | 'COLD | core | | | | | | | core | | | + | EXPECT | core | | | | | | | core | | | + | DECODE | core | | | | | | | core | | | + | KEY? | core | | | | | | | core | | | + | KEY | core | | | | | | | core | | | + | INPUT: | core | | | | | | | core | | | + | COL | core | | | | | | | core | | | + | ROW | core | | | | | | | core | | | + | AT? | core | | | | | | | core | | | + | AT | core | | | | | | | core | | | + | PAGE | core | | | | | | | core | | | + | DEL | core | | | | | | | core | | | + | TYPE | core | | | | | | | core | | | + | CR | core | | | | | | | core | | core | + | EMIT | core | | | | | | | core | | | + | OUTPUT: | core | | | | | | | core | | | + | ?CR | core | | | | | | | core | | | + | STOP? | core | | | | | | | core | | | + | BYE | core | | | | | | | core | | | + | SAVE | core | | | | | | | core | | | + | EMPTY | core | | | | | | | core | | | + | FORGET | core | | | | | | | core | | | + | (FORGET | core | | | | | | | core | | | + | CLEAR | core | | | | | | | core | | | + | ALL-BUFFERS | core | | | | | | | core | | | + | FREEBUFFER | core | | | | | | | core | | | + | ALLOTBUFFER | core | | | | | | | core | | | + | FIRST | core | | | | | | | core | | | + | LIMIT | core | | | | | | | core | | | + | CONVEY | core | | | | | | | core | | | + | COPY | core | | | | | | | core | | | + | BLKMOVE | core | | | | | | | | | | + | (COPY | core | | | | | | | | | | + | FLUSH | core | | | | | | | core | | | + | EMPTY-BUFFERS | core | | | | | | | core | | | + | SAVE-BUFFERS | core | | | | | | | core | | | + | UPDATE | core | | | | | | | core | | | + | BLOCK | core | | | | | | | core | | | + | BUFFER | core | | | | | | | core | | | + | (BLOCK | core | | | | | | | core | | | + | (BUFFER | core | | | | | | | core | | | + | CORE? | core | | | | | | | core | | | + | R/W | core | | | | | | | core | | | + | DISKERR | core | | | | | | | core | | | + | (DISKERR | core | | | | | | | core | | | + | B/BUF | core | | | | | | | core | | | + | BUFFERS | core | | | | | | | | | | + | PREV | core | | | | | | | core | | | + | FILE | core | | | | | | | core | | | + | UNLOCK | core | | | | | | | core | | | + | LOCK | core | | | | | | | core | | | + | PAUSE | core | | | | | | | core | | | + | LIST | core | | | | | | | core | | | + | L/S | core | | | | | | | core | | | + | C/L | core | | | | | | | core | | | + | .S | core | | | | | | | core | | | + | U. | core | | | | | | | core | | | + | . | core | | | | | | | core | | | + | D. | core | | | | | | | core | | | + | U.R | core | | | | | | | core | | | + | .R | core | | | | | | | core | | | + | D.R | core | | | | | | | core | | | + | #S | core | | | | | | | core | | | + | # | core | | | | | | | core | | | + | SIGN | core | | | | | | | core | | | + | #> | core | | | | | | | core | | | + | <# | core | | | | | | | core | | | + | HOLD | core | | | | | | | core | | | + | SPACES | core | | | | | | | core | | | + | SPACE | core | | | | | | | core | | | + | -TRAILING | core | | | | | | | core | | | + | BL | core | | | | | | | core | | core | + | ERROR" | core | | | | | | | core | | | + | ABORT" | core | | | | | | | core | | core | + | (ABORT" | core | | | | | | | core | | | + | (ERROR | core | | | | | | | core | | | + | R# | core | | | | | | | core | | | + | SCR | core | | | | | | | core | | | + | ABORT | core | | | | | | | core | | core | + | 'ABORT | core | | | | | | | core | | | + | STANDARDI/O | core | | | | | | | core | | | + | QUIT | core | | | | | | | core | | | + | 'QUIT | core | | | | | | | core | | | + | (QUIT | core | | | | | | | core | | | + | DEPTH | core | | | | | | | core | | | + | RDEPTH | core | | | | | | | core | | | + | --> | core | | | | | | | core | | | + | +THRU | core | | | | | | | core | | | + | THRU | core | | | | | | | core | | | + | +LOAD | core | | | | | | | core | | | + | LOAD | core | | | | | | | core | | | + | PUSH | core | | | | | | | core | | | + | .STATUS | core | | | | | | | core | | | + | ?STACK | core | | | | | | | core | | | + | IS | core | | | | | | | core | | | + | (IS | core | | | | | | | core | | | + | DEFER | core | | | | | | | core | | | + | ] | core | | | | | | | core | | | + | [ | core | | | | | | | core | | core | + | INTERPRET | core | | | | | | | core | | | + | NO.EXTENSIONS | core | | | | | | | core | | | + | NOTFOUND | core | | | | | | | core | | | + | >INTERPRET | core | | | | | | | core | | | + | NULLSTRING? | core | | | | | | | core | | | + | ['] | core | | | | | | | core | | core | + | [COMPILE] | core | | | | | | | core | | core | + | ' | core | | | | | | | core | | | + | FIND | core | | | | | | | core | | | + | (FIND | core | | | | | | | core | | | + | WORDS | core | | | | | | | core | | | + | ORDER | core | | | | | | | core | | | + | DEFINITIONS | core | | | | | | | core | | | + | ONLYFORTH | core | | | | | | | core | | | + | ONLY | core | | | | | | | core | | | + | FORTH | core | | | | | | | core | | | + | VOCABULARY | core | | | | | | | core | | | + | TOSS | core | | | | | | | core | | | + | ALSO | core | | | | | | | core | | | + | CONTEXT | core | | | | | | | core | | | + | CURRENT | core | | | | | | | core | | | + | VP | core | | | | | | | core | | | + | ALIAS | core | | | | | | | core | | | + | USER | core | | | | | | | core | | | + | UALLOT | core | | | | | | | core | | | + | VARIABLE | core | | | | | | | core | | | + | CONSTANT | core | | | | | | | core | | core | + | ; | core | | | | | | | core | | | + | : | core | | | | | | | core | | | + | CREATE: | core | | | | | | | | | | + | .NAME | core | | | | | | | core | | | + | >BODY | core | | | | | | | core | | | + | NAME> | core | | | | | | | core | | | + | >NAME | core | | | | | | | core | | | + | NFA? | core | | | | | | | | | | + | CREATE | core | | | | | | | core | | core | + | WARNING | core | | | | | | | core | | | + | \vert | core | | | | | | | core | | | + | ?HEAD | core | | | | | | | core | | | + | DOES> | core | | | | | | | core | | | + | HEAP? | core | | | | | | | core | | | + | HEAP | core | | | | | | | core | | | + | HALLOT | core | | | | | | | core | | | + | CLEARSTACK | core | | | | | | | core | | | + | RESTRICT | core | | | | | | | core | | | + | IMMEDIATE | core | | | | | | | core | | | + | RECURSIVE | core | | | | | | | core | | | + | REVEAL | core | | | | | | | core | | | + | HIDE | core | | | | | | | core | | | + | LAST | core | | | | | | | core | | | + | NUMBER | core | | | | | | | core | | | + | 'NUMBER? | core | | | | | | | | | | + | NUMBER? | core | | | | | | | core | | | + | DPL | core | | | | | | | core | | | + | PREVIOUS | core | | | | | | | | | | + | CHAR | core | | | | | | | | | | + | END? | core | | | | | | | | | | + | CONVERT | core | | | | | | | core | | | + | ACCUMULATE | core | | | | | | | core | | | + | DIGIT? | core | | | | | | | core | | | + | DECIMAL | core | | | | | | | core | | | + | HEX | core | | | | | | | core | | | + | \NEEDS | core | | | | | | | core | | | + | \\ | core | | | | | | | core | | | + | \ | core | | | | | | | core | | | + | .( | core | | | | | | | core | | | + | ( | core | | | | | | | core | | | + | ." | core | | | | | | | core | | | + | (." | core | | | | | | | core | | | + | " | core | | | | | | | core | | | + | (" | core | | | | | | | core | | | + | "LIT | core | | | | | | | core | | | + | ," | core | | | | | | | core | | | + | ASCII | core | | | | | | | core | | | + | STATE | core | | | | | | | core | | | + | NAME | core | | | | | | | core | | | + | PARSE | core | | | | | | | core | | | + | WORD | core | | | | | | | core | | | + | SOURCE | core | | | | | | | core | | | + | CAPITALIZE | core | | | | | | | core | | | + | CAPITAL | core | | | | | | | core | | | + | /STRING | core | | | | | | | core | | | + | SKIP | core | | | | | | | core | | | + | SCAN | core | | | | | | | core | | | + | QUERY | core | | | | | | | core | | | + | TIB | core | | | | | | | core | | | + | SPAN | core | | | | | | | core | | | + | BLK | core | | | | | | | core | | | + | >IN | core | | | | | | | core | | | + | >TIB | core | | | | | | | core | | | + | #TIB | core | | | | | | | core | | | + | COMPILE | core | | | | | | | core | | | + | C, | core | | | | | | | core | | core | + | , | core | | | | | | | core | | | + | ALLOT | core | | | | | | | core | | core | + | PAD | core | | | | | | | core | | | + | HERE | core | | | | | | | core | | | + | FILL | core | | | | | | | core | | | + | ERASE | core | | | | | | | core | | | + | COUNT | core | | | | | | | core | | core | + | PLACE | core | | | | | | | core | | | + | MOVE | core | | | | | | | core | | | + | CMOVE> | core | | | | | | | core | | | + | CMOVE | core | | | | | | | core | | | + | UD/MOD | core | | | | | | | core | | | + | U/MOD | core | | | | | | | core | | | + | */ | core | | | | | | | core | | | + | */MOD | core | | | | | | | core | | | + | MOD | core | | | | | | | core | | | + | / | core | | | | | | | core | | | + | /MOD | core | | | | | | | core | | | + | 2/ | core | | | | | | | core | | | + | M/MOD | core | | | | | | | core | | | + | UM/MOD | core | | | | | | | core | | | + | 2* | core | | | | | | | core | | | + | * | core | | | | | | | core | | | + | M* | core | | | | | | | core | | | + | UM* | core | | | | | | | core | | | + | UNLOOP | core | | | | | | | | | | + | LEAVE | core | | | | | | | core | | | + | +LOOP | core | | | | | | | core | | | + | LOOP | core | | | | | | | core | | | + | ?DO | core | | | | | | | core | | | + | DO | core | | | | | | | core | | | + | UNTIL | core | | | | | | | core | | | + | REPEAT | core | | | | | | | core | | | + | WHILE | core | | | | | | | core | | | + | BEGIN | core | | | | | | | core | | core | + | ELSE | core | | | | | | | core | | | + | THEN | core | | | | | | | core | | | + | IF | core | | | | | | | core | | | + | CASE? | core | | | | | | | core | | | + | ?PAIRS | core | | | | | | | core | | | + | RESOLVE | core | | | | | | | core | | | + | >MARK | core | | | | | | | core | | | + | ?BRANCH | core | | | | | | | core | | | + | BRANCH | core | | | | | | | core | | | + | J | core | | | | | | | core | | | + | I | core | | | | | | | core | | | + | (+LOOP | core | | | | | | | core | | | + | (LOOP | core | | | | | | | core | | | + | ENDLOOP | core | | | | | | | core | | | + | BOUNDS | core | | | | | | | core | | | + | (?DO | core | | | | | | | core | | | + | (DO | core | | | | | | | core | | | + | ABS | core | | | | | | | core | | core | + | DBAS | core | | | | | | | core | | | + | EXTEND | core | | | | | | | core | | | + | UMIN | core | | | | | | | core | | | + | UMAX | core | | | | | | | core | | | + | MAX | core | | | | | | | core | | | + | MIN | core | | | | | | | core | | | + | D< | core | | | | | | | core | | | + | D= | core | | | | | | | core | | | + | D0= | core | | | | | | | core | | | + | = | core | | | | | | | core | | | + | U> | core | | | | | | | core | | | + | 0<> | core | | | | | | | core | | | + | 0> | core | | | | | | | core | | | + | > | core | | | | | | | core | | | + | U< | core | | | | | | | core | | | + | < | core | | | | | | | core | | | + | UWITHIN | core | | | | | | | core | | | + | 0= | core | | | | | | | core | | | + | 0< | core | | | | | | | core | | | + | LITERAL | core | | | | | | | core | | | + | LIT | core | | | | | | | core | | | + | CLIT | core | | | | | | | core | | | + | OFF | core | | | | | | | core | | | + | ON | core | | | | | | | core | | | + | 4 | core | | | | | | | core | | | + | 3 | core | | | | | | | core | | | + | 2 | core | | | | | | | core | | | + | 1 | core | | | | | | | core | | | + | 0 | core | | | | | | | core | | | + | -1 | core | | | | | | | core | | | + | FALSE | core | | | | | | | core | | | + | TRUE | core | | | | | | | core | | | + | 2- | core | | | | | | | core | | | + | 1- | core | | | | | | | core | | | + | 4+ | core | | | | | | | | | | + | 3+ | core | | | | | | | core | | | + | 2+ | core | | | | | | | core | | | + | 1+ | core | | | | | | | core | | | + | D+ | core | | | | | | | core | | | + | DNEGATE | core | | | | | | | core | | | + | NEGATE | core | | | | | | | core | | | + | NOT | core | | | | | | | core | | | + | - | core | | | | | | | core | | | + | XOR | core | | | | | | | core | | | + | AND | core | | | | | | | core | | core | + | OR | core | | | | | | | core | | | + | + | core | | | | | | | core | | | + | 2DUP | core | | | | | | | core | | | + | 2DROP | core | | | | | | | core | | | + | 2SWAP | core | | | | | | | core | | | + | ROLL | core | | | | | | | core | | | + | PICK | core | | | | | | | core | | | + | UNDER | core | | | | | | | core | | | + | NIP | core | | | | | | | core | | | + | ROT | core | | | | | | | core | | | + | -ROT | core | | | | | | | core | | | + | OVER | core | | | | | | | core | | | + | ?DUP | core | | | | | | | core | | | + | DUP | core | | | | | | | core | | | + | SWAP | core | | | | | | | core | | | + | DROP | core | | | | | | | core | | | + | +! | core | | | | | | | core | | | + | ! | core | | | | | | | core | | | + | @ | core | | | | | | | core | | | + | CTOGGLE | core | | | | | | | core | | | + | C! | core | | | | | | | core | | core | + | C@ | core | | | | | | | core | | core | + | PERFORM | core | | | | | | | core | | | + | EXECUTE | core | | | | | | | core | | | + | ?EXIT | core | | | | | | | core | | | + | UNNEST | core | | | | | | | | | | + | EXIT | core | | | | | | | core | | | + | RDROP | core | | | | | | | core | | | + | R@ | core | | | | | | | core | | | + | R> | core | | | | | | | core | | | + | >R | core | | | | | | | core | | | + | RP! | core | | | | | | | core | | | + | RP@ | core | | | | | | | core | | | + | UP! | core | | | | | | | core | | | + | UP@ | core | | | | | | | core | | | + | SP! | core | | | | | | | core | | | + | SP@ | core | | | | | | | core | | | + | UDP | core | | | | | | | core | | | + | VOC-LINK | core | | | | | | | core | | | + | ERRORHANDLER | core | | | | | | | core | | | + | INPUT | core | | | | | | | core | | | + | OUTPUT | core | | | | | | | core | | | + | BASE | core | | | | | | | core | | core | + | OFFSET | core | | | | | | | core | | | + | DP | core | | | | | | | core | | | + | R0 | core | | | | | | | core | | | + | S0 | core | | | | | | | core | | | + | ORIGIN | core | | | | | | | core | | | + | NOOP | core | | | | | | | core | | | + | RECOVER | core | | | | | | | core | | | + | END-TRACE | core | | | | | | | core | | | + | LOGO | core | | | | | | | | | | + | (64 | core | | | | | | | | | | + | C) | core | | | | | | | | | | + | (16 | core | | | | | | | | | | + | C64INIT | core | | | | | | | | | | + | INIT-SYSTEM | core | | | | | | | | | | + | INK-POT | core | | | | | | | | | | + | FINDEX | core | | | | | | | | | | + | INDEX | core | | | | | | | | | | + | 1541RW | core | | | | | | | | | | + | DISKCLOSE | core | | | | | | | | | | + | DISKOPEN | core | | | | | | | | | | + | WRITESECTOR | core | | | | | | | | | | + | READSECTOR | core | | | | | | | | | | + | DERROR? | core | | | | | | | | | | + | I/O-STATUS? | core | | | | | | | | | | + | BUSINPUT | core | | | | | | | | | | + | BUS@ | core | | | | | | | | | | + | BUSTYPE | core | | | | | | | | | | + | BUS! | core | | | | | | | | | | + | BUSIN | core | | | | | | | | | | + | (BUSIN | core | | | | | | | | | | + | BUSCLOSE | core | | | | | | | | | | + | BUSOPEN | core | | | | | | | | | | + | BUSOUT | core | | | | | | | | | | + | (BUSOUT | core | | | | | | | | | | + | ?DEVICE | core | | | | | | | | | | + | (?DEVICE | core | | | | | | | | | | + | BUSOFF | core | | | | | | | | | | + | I/O | core | | | | | | | | | | + | (DRV | core | | | | | | | | | | + | C64TYPE | core | | | | | | | | | | + | C64AT? | core | | | | | | | | | | + | C64AT | core | | | | | | | | | | + | C64PAGE | core | | | | | | | | | | + | C64DEL | core | | | | | | | | | | + | C64CR | core | | | | | | | | | | + | C64EMIT | core | | | | | | | | | | + | PRINTABLE | core | | | | | | | | | | + | CON! | core | | | | | | | | | | + | C64EXPECT | core | | | | | | | | | | + | C64DECODE | core | | | | | | | | | | + | C64KEY | core | | | | | | | | | | + | C64KEY? | core | | | | | | | | | | + | CUSTOM-REMOVE | core | | | | | | | | | | + | ACCEPT | | | | | | | | | | core | + | ACTION-OF | | | | | | | | | | core | + | AGAIN | | | | | | | | | | core | + | ALIGN | | | | | | | | | | core | + | ALIGNED | | | | | | | | | | core | + | BUFFER: | | | | | | | | | | core | + | [char] | | | | | | | | | core | core | + | char | | | | | | | | | core | core | + | case | | | | | | | | | | core | + | CELL+ | | | | | | | | | | core | + | CELLS | | | | | | | | | | core | + | CHAR+ | | | | | | | | | | core | + | CHARS | | | | | | | | | | core | + | compile, | | | | | | | | | | core | + | | | | | | | | | | | | diff --git a/doc/cpm/readme.org b/doc/cpm/readme.org new file mode 100644 index 0000000..1323550 --- /dev/null +++ b/doc/cpm/readme.org @@ -0,0 +1,1055 @@ +#+Title: volksFORTH für CP/M 2.2 +#+Author: Ulli Hoffmann, Carsten Strotmann +#+Date: <2022-08-18 Thu> + +Nach den Implementierungen von volksFORTH auf dem 6502 (C64) und dem +68000 (Atari ST), liegt hier nun die dritte Implementierung, die auf +dem 8080/Z80, vor. Sie stützt sich dabei auf das CP/M 2.2 +Betriebssystem, sodaß volksFORTH damit auf einer großen Zahl von +Mikrokomputersystemen zur Verfügung steht. + +Um die Verbreitung von FORTH allgemein kümmert sich die +FORTH-Gesellschaft e.V. In ihrem Vereinsorgan dem Forth-Magazin +(Vierte-Dimension) erscheinen regelmäßig Artikel über Forth. + +Die Adresse der Forth-Gesellschaft e.V. lautet: + + Forth-Gesellschaft e.V. + Postfach 1030 + 48481 Neuenkirchen + E-Mail: secretary@forth-ev.de + Web: https://www.forth-ev.de + +* Wie fange ich an? + +In diesem Text soll der Vorgang der Installation von volksFORTH an ein +CP/M-ComputerSystem (Bildschirm, Tastatur, Drucker) beschrieben +werden. Auf der ausgelieferten Diskette finden sich folgende Dateien: + +| ASS8080 SCR | Der volksFORTH 8080-Assembler | +| ASSTRAN SCR | Zum Laden des Assembler auf den Heap | +| DISASS SCR | Ein Z80-Disassembler fuer volksFORTH | +| DOUBLE SCR | Definitionsn fuer doppeltgenaue Zahlen | +| EDITOR SCR | Der volksFORTH Full-Screen Editor | +| FILEINT SCR | Das volksFORTH Fileinterface zu CP/M 2.2 | +| HASHCASH SCR | Ein schnelles Dictionary-Suchverfahren | +| INSTALL SCR | Der Installer für die Editor-Befehlstasten | +| KERNEL COM | Der volksFORTH Kern (Terminal unabh{ngig) | +| PORT8080 SCR | Definitionen für 8080 Portzugriff | +| PORTZ80 SCR | Definitionen für Z80 Protzugriff | +| PRIMED SCR | Der primitivst Editor zum Installieren | +| PRINTER SCR | Anpassung von volksFORTH an den Drucker | +| RELOCATE SCR | Das Utility-Wort BUFFERS | +| SAVESYS SCR | Das Utility-Wort SAVESYSTEM | +| SEE SCR | Der automatische Decompiler | +| SIMPFILE SCR | Ein einfaches Filesystem für Direktzugriff | +| SOURCE SCR | Der Quelltext des volksFORTH Kerns | +| STARTUP SCR | Load-File, welches aus KERNEL.COM VOLKS4TH.COM erzeugt | +| STRING SCR | Definitionen für Stringoperationen | +| TASKER SCR | Der volksFORTH Multitasker | +| TERMINAL SCR | Definitionen für das installierte Terminal | +| TIMES SCR | Die Utility-Worte OFTEN und TIMES | +| TOOLS SCR | Der manuelle Decompiler, DUMP und der Tracer | +| VOLKS4TH COM | Das volksFORTH Standard-System | + +** Drei wichtige Worte: USE, LIST und LOAD + +VolksForth bearbeitet seine Programmtexte in sogenannten Screen Files +(Dateiendung: .SCR), das sind Files, die in 1 kB große Screens +aufgeteit sind, die wiederum in 16 Zeilen mit je 64 Zeichen +strukturiert sind. Um ein schon existentes File als aktuelles File +anzuwählen wird das Wort USE benutzt. (Beispiel: =USE +TERMINAL.SCR=, wählt =TERMINAL.SCR= als aktuelles File.) Um sich nun +einen bestimmten Screen anzusehen, wird =nn LIST= benutzt. (Beispiel: +=1 LIST=, zeigt Screen 1 des aktuellen Files.) Mit =nn LOAD= wird ein +bestimmter Screen geladen: Die Definitionen in diesem Screen werden in +eine für den Computer ausführbare Form gebracht. (Beispiel: =1 LOAD=, +lädt Screen 1 des aktuellen Files.) Per Konvention soll der Screen +null (0) eines jeden Files eine Erklärung des Inhaltes des Files +enthalten. Wird Screen eins, der sogenannte LOAD-Screen, geladen, so +soll er das Laden der gesamten Definitionen des Files veranlassen. +Zeile Null eines jeden Screens soll Auskunft über den Inhalt des +Screens geben. + +** Die Anpassung von VolksForth an den Computer + +Damit das VolksForth in vollem Umfang benutzt werden kann, ist +zunächst eine Installation erforderlich. Für Schneider-Computer +(Amstrad CPC) ist diese schon von uns vorgenommen worden, sodaß es +gleich richtig losgehen kann. Die Anpassung an einen anderen Computer +beinhaltet: + +*** Anpassung der Bildschirmfunktionen + +In dem File =TERMINAL.SCR= werden die notwendigen Bildschirmfunktionen +definiert. Diese müssen auf den neuen Bildschirm angepaßt werden. Da +der Editor erst nach erfolgreicher Anpassung benutzt werden kann, +müssen diese Screens auf andere Art und Weise geändert werden. Dazu +kann der Primitivst-Editor im File =PRIMED.SCR= benutzt werden. Die +normalerweise zu benutzenden Escape-Sequenzen, sind dem entsprechenden +Terminal-Handbuch zu entnehmen. Mit =USE PRIMED.SCR 1 LOAD= den +primitivst Editor laden. (Screen 0 enthält Anleitung, Screen 2 ein +Beispiel). Dann mit =USE TERMINAL.SCR= dieses File zur Benutzung +anwählen. =PRIMED= arbeitet dann auf diesem File. + +*** Anpassung der Editor-Befehlstasten + +Im File =EDITOR.SCR= gibt es eine Tabelle mit Namen =KEYTABLE=, in der +die Tasten zu den in der Tabelle =ACTIONTABLE= definierten Befehlen +angegeben werden. Durch Ändern der Tabelle =KEYTABLE= können die +Befehlstasten des Editors ver{ndert werden. Zum einfachen Anpassen des +Editors gibt es das File =INSTALL.SCR=, indem interaktiv die neuen +Befehlstasten abgefragt werden. (Achtung!: Der Sourcetext wird nicht +mitgeändert!!) + +** Die Anpassung von VolksForth an den Drucker + +In dem File =PRINTER.SCR= wird die Ansteuerung des Druckers (hier +Epson FX80) definiert. Sollte kein Epson-kompatibler Drucker +vorliegen, müssen auch hier die Escape-Sequenzen geändert +werden.(Siehe Druckerhandbuch!) Dies sollte aber möglichst erst dann +geschehen, wenn die restlichen Anpassungen laufen! + + +* Das Fileinterface + +** Wie geht es los? + +Bevor Sie das Glossar lesen, sollten Sie diese kleine Einf}hrung lesen +und auf einer leeren Diskette die Beispiele ausprobieren. + +** Wie erzeuge ich ein File, in das ich ein Programm eingeben kann? + +Geben Sie bitte folgendes ein: +#+begin_example +MAKEFILE test.scr +#+end_example + +Das File =test.scr= wird auf der Diskette erzeugt, auf dem Sie das +Forth gebootet haben. + +Als nächstes schätzen Sie bitte ab, wie lang Ihr Programm etwa wird. +Beachten Sie dabei bitte, daß der Screen 0 eines Files für Hinweise +zur Handhabung Ihres Programms und der Screen 1 für einen sog. +Loadscreen (das ist ein Screen, der den Rest des File lädt) reserviert +sind. Wollen Sie also z.B. 3 Screens Programm eingeben, so muß das +File 5 Screens lang sein; Sie geben also ein: +#+begin_example +5 MORE +#+end_example + +Fertig! Sie haben jetzt ein File, das die Screens 0..4 enthält. Geben +Sie jetzt +#+begin_example +1 L +#+end_example +ein. Sie editieren jetzt den Screen 1 Ihres neuen Files =test.scr=. +Sie können, falls der Platz nicht ausreicht, Ihr File später einfach +mit =MORE= verlängern. Ein File kann leider nicht verkürzt werden. + +** Wie spreche ich ein bereits auf der Diskette vorhandenes File an? + +Das geht noch einfacher. Geben Sie einfach den Filenamen ein. Reagiert +das System mit der Meldung "Haeh?", so kennt das Forth dieses File +noch nicht. Sie müssen in diesem Fall das Wort =USE= vor dem Filenamen +eingeben, also z.B. +#+begin_example +USE test.scr +#+end_example + +Jetzt können Sie wie oben beschrieben mit =1 L= (oder einer anderen +Zahl) das File editieren, Das Wort =USE= erzeugt übrigens im Forthsystem +das Wort =TEST.SCR=, falls es noch nicht vorhanden war. Wissen Sie also +nicht mehr, ob Sie ein File schon benutzt haben, so können Sie mit +=WORDS= nachsehen oder das Wort =USE= voranstellen. + +** Wie erzeuge ich ein File auf einem vorgegebenem Laufwerk, z.B. A: ? +Durch Voranstellen des Laufwerks etwa: +#+begin_example +MAKEFILE a:test.scr +#+end_example +Oder durch Eingabe von +#+begin_example +A: +#+end_example +Hierbei wird =A:= zum aktuellen Laufwerk gemacht. Files ohne +Laufwerksangabe werden immer auf dem aktuellen Laufwerk erzeugt. + +** Allgemeines + +Im folgenden wird die Benutzung des Fileinterfaces beschrieben. Dieses +Fileinterface benutzt die Files des CP/M. + +Benutzt man ein File von Forth aus, so wird es in Blöcke zu je 1024 +Bytes aufgeteilt, die in gewohnter Wiese anzusprechen sind. Dies +trifft auch für Files zu, die nicht vom Forth aus erzeugt wurden. Als +Konvention wird vorgeschlagen, da~ Files, die Forth-Screens, also +Quelltexte, enthalten, mit =.FB= erweitert werden. Files, die Daten +enthalten, die nicht unmittelbar lesbar sind, sollten auf =.BLK= +enden. + +Zum Umschalten vom Filesystem auf Direktzugriff und umgekehrt gibt es +das Wort: + +=DIRECT ( -- )= "direct" - Schaltet auf Direktzugriff um. Auf den +Filezugriff schalten wir durch das Nennen eines Filenamens. + +** Die Laufwerkswahl + +Files werden immer auf dem aktuellen Laufwerk erzeugt, solange der +Filename nicht ausdrücklich ein anderes Laufwerk vorsieht. Als +Betriebssystemname wird dann der vollständige Filename eingetragen, +also mit eindeutig festgelegtem Laufwerk. + +Zum Ändern des aktuellen Laufwerks stehen die folgenden Worte zur +Verfügung: + +=A: ( -- )= "a-colon" - Macht Diskettenstation =A:= zum aktuellen +Laufwerk entsprechend der Funktion im CCP. Siehe =SETDRIVE=. + +=B: ( -- )= "b-colon" - Macht Diskettenstation =B:= zum aktuellen +Laufwerk entsprechend der Funktion im CCP. Siehe =SETDRIVE=. + +=SETDRIVE ( n -- )= "setdrive" - Macht die Diskettenstation mit der +Nummer n zum aktuellen Laufwerk. Hierbei entspricht n=0 der +Diskstation A, n=1 der Diskstation B usw. + +Um sich den Inhalt einer Diskette anzusehen, gibt es die Worte: + +=FILES ( -- )= "files" - Listet den Inhalt des aktuellen Laufwerks +(siehe =SETDRIVE=) auf dem Bildschirm auf. Dieses Wort, zusammen mit dem +Wort =FILES"= entspricht dem Kommando =DIR= des CCP. In anderen +VolksForth-Filesystemen wird =DIR= benutzt um Direktories umzuschalten +(MS-DOS, GEM-DOS). + +=FILES" ( -- )= "files-quote" - Benutzt in der Form =FILES" cccc"=. +Listet die Files auf, deren Name cccc ist. Der String cccc darf +die bekannten Wildcards ('?','*') sowie eine Laufwerksbezeichnung +enthalten. Wird kein Laufwerk angegeben, so werden die Files des +aktuellen Laufwerks ausgegeben. + +** Files + +Files bestehen aus einem Forthname und einem Betriebssystemnamen, die +nicht übereinstimmen müssen. + +Ist das Forthwort, unter dem ein File zugreifbar ist, gemeint, so wird +im folgenden vom /Forthfile/ gesprochen. Ist das File auf der Diskette +gemeint, das vom CP/M-BDOS verwaltet wird, so wird vom /DOS-File/ +gesprochen. Durch das Nennen des Forthnamens wird das Forthfile (und +das zugehörige DOS-File) zum /aktuellen File/, auf das sich alle +Operationen wir =LIST=, =LOAD=, =CONVEY= usw. beziehen. Beim +Bekanntmachen des Files mit =USE=, =MAKEFILE= und =ASSIGN= u.a. wird das +File auf dem aktuellen Laufwerk gesucht, wenn kein Laufwerk im Namen +angegeben wird. Danach darf das aktuelle Laufwerk beliebig geändert +werden, ohne daß das File dann auf einem anderen Laufwerk gesucht +wird. Mit =FORTHFILES= können die aktuellen Zuordnungen zwischen +Forthfile und DOS-File angezeigt werden. + +=FILE ( -- )= "file" - Wird in der Form: =FILE = benutzt. +Erzeugt ein Forthwort mit Name . Wird später ausgeführt, +so vermerkt es sich als aktuelles File. Ebenso vermerkt es sich als +=FROMFILE=, was für =CONVEY= wichtig ist. Einem Forthfile wird mit +=MAKE= oder =ASSIGN= ein DOS-File zugeordnet. + +=MAKE ( -- )= "make" - Wird in der Form: =MAKE cccc= benutzt. Erzeugt +ein DOS-File mit Namen cccc auf dem aktuellen (oder angegebenem +Laufwerk) und ordnet es dem aktuellen Forthfile zu. Das File wird auch +gleich geöffnet. Es hat die Länge Null (siehe =MORE=). Beispiel: +#+begin_example +FILE ausgabe +ausgabe MAKE test.scr +#+end_example +erzeugt ein Forthwort =AUSGABE= und ein File mit dem Namen +=A:TEST.SCR=. (Angenommen A: ist aktuelles Laufwerk.) Alle Operationen +wie =LOAD=, =LIST= usw. beziehen sich nun auf den entsprechenden +Screen in =A:TEST.SCR=. Beachten Sie bitte, daß dieses File noch leer +ist, und daher eine Fehlerbedingung besteht, wenn Zugriffsoperationen +ausgeführt werden sollen. + +MAKEFILE ( -- ) "makefile" + Wird in der folgender Form benutzt: + MAKEFILE + Erzeugt ein Forthfile mit dem Namen und erzeugt abschlie~end ein + DOS-File mit demselben Namen (und eindeutiger Laufwerksangabe). Die + folgende Sequenz w}rde genau dasselber bewirken: + FILE + MAKE + +SAVEFILE ( addr len -- ) "savefile" + Wird in der folgenden Form benutzt: + SAVEFILE + Schreibt den String, der an der Adresse addr begint und die L{nge len hat + als File mit dem Namen auf die Diskette. + +KILLFILE ( -- ) "killfile" + L|scht das aktuelle File. Unsch|n, da dann das Forthfile noch existiert, + das Dosfile aber gel|scht ist, soda~ es bei dem n{chsten Diskettenzugriff + einen Fehler gibt, wenn nicht ein anderes File angew{hlt wird. +.pa +ASSIGN ( -- ) "assign" + Wird in der Form + ASSIGN cccc + benutzt. Ordnet dem aktuellen File das DOS-File mit Namen cccc (mit + eindeutiger Laufwerksangabe) zu. Eine Fehlerbedingung besteht, wenn das + File nicht gefunden werden kann. + +USE ( -- ) "use" + Dieses Wort ist das wichtigste Wort zum Ausw{hlen von Files. ____________________________________________________________ + + Es wird in der folgenden Form benutzt: + USE + Dieses Wort macht das File mit Namen zum aktuellen File, auf das + sich LOAD, LIST usw. beziehen. Es erzeugt ein Forthfile mit Namen , + falls der Name noch nicht vorhanden war. Anschlie~end wird das File auf + dem aktuellen (oder angegebenem) Laufwerk gesucht. Wird das File nicht + gefunden, so wird eine Fehlermeldung ausgegeben. Das (automatisch) + erzeugte Forthfile verbleibt im Dictionary und mu~ ggf. mit FORGET + vergessen werden. + +CLOSE ( -- ) "close" + Schlie~t das aktuelle File. Dabei wird das Inhaltsverzeichnis (Directory) + der Diskette aktualisiert. Es werden die zu diesem File geh|renden + ge{nderten Bl|cke auf Diskette zur}ckgeschrieben und alle zu diesem File + geh|renden Bl|cke in den Block-Puffern gel|scht. + +OPEN ( -- ) "open" + Offnet das aktuelle File. Eine Fehlerbedingung besteht, wenn das File + nicht gefunden werden kann. Die Benutzung dieses Wortes ist in den + meisten F{llen }berfl}ssig, da Files automatisch bei einem Zugriff + ge|ffnet werden. + +EMPTYFILE ( -- ) "emptyfile" + K}rzt das aktuelle File auf die L{nge null. + +FROM ( -- ) "from" + Wird in der folgenden Form benutzt: + FROM + ist der Name eines Forthfile, aus dem beim Aufruf von CONVEY und + COPY Bl|cke herauskopiert werden sollen. + + Beispiel: filea 1 FROM fileb 3 COPY + + Kopiert den Block 1 aus FILEB auf den Block 3 von FILEA. + Dieses Wort benutzt USE und das File auszuw{hlen. Das bedeutet, da~ FILEB + automatisch als Forthfile angelegt wird, wenn es noch nicht im System + vorhanden ist. +.pa +LOADFROM ( n -- ) "loadfrom" + Wird in der folgenden Form benutzt: + LOADFROM + ist der Name eines Forthfiles, aus dem der Block n geladen wird. + + Beispiel: 15 LOADFROM filea + + L{dt den Block 15 aus FILEA. Dieses Wort ist wichtig, wenn w{hrend des + Ladens eines Files Teile eines anderen Files geladen werden sollen. + Dieses Wort benutzt USE, um FILEA zu selektieren. Das bedeutet, da~ automatisch ein Forthfile mit Namen FILEA erzeugt wird, falls es im System + noch nicht vorhanden war. + Beachten Sie bitte, da~ dieses Wort nichts mit FROM oder FROMFILE zu tun + hat, obwohl es {hnlich hei~t! + +INCLUDE ( -- ) "include" + Wird in der folgenden Form benutzt: + INCLUDE + ist der Name eines Forthfiles, das vollst{ndig geladen wird. Dabei + ist Voraussetzung, da~ auf Screen 1 dieses Files Anweisungen stehen, die + zum Laden aller Screens dieses Files f}hren. Siehe auch LOADFROM. + +CAPACITY ( -- u ) "capacity" + u ist die L{nge des aktuellen Files in Forth-Bl|cken (1024 Bytes). + Beachten Sie bitte, da~ die L{nge des Files um eins gr|~er ist als die + Nummer des letzten Blocks, da der Block 0 mitgez{hlt wird. + +FORTHFILES ( -- ) "forthfiles" + Druckt eine Liste aller Forthfiles, zusammen mit den Namen der zugeh|rigen DOS-Files, deren L{nge und deren Status (ge|ffnet / geschlossen). + +FROMFILE ( -- addr ) "fromfile" + Addr ist die Adresse einer Variablen, die auf das Forth-File zeigt, aus + dem COPY und CONVEY Bl|cke lesen. Siehe auch FROM. Bei Nennen eines + Forthfiles wird diese Variable gesetzt. + +LOADFILE ( -- addr ) "loadfile" + Addr ist die Adresse einer Variablen, die auf das Forthfile zeigt, das + gerade geladen wird. Diese Variable wird bei Aufruf von LOAD, THRU usw. + auf das aktuelle File gesetzt. + +ISFILE ( -- addr ) "isfile" + Addr ist die Adresse einer Variablen, die auf das aktuelle Forthfile + zeigt. Sie wird bei Ausf}hrung eines Forthfiles gesetzt. + +FILE? ( -- ) "file-question" + Druckt den Namen des aktuellen Forthfiles. + +MORE ( n -- ) "more" + Verl{ngert das aktuelle File um n Screens. Die Screens werden hinten + angeh{ngt. Anschlie~end wird das File geschloseen. + +EOF ( -- f) "end-of-file" + f ist ein Flag, das wahr ist, falls }ber das Ende des Files hinausgelesen + wurde. f ist falsch, falls auf den zuletzt gelesenen Block noch weitere + folgen. + +.PA +3) Verschiedenes ________________ + +Beim Vergessen eines Forth-Files mit Hilfe von FORGET, EMPTY usw. werden +automatisch alle Blockpuffer, die aus diesem File stammen, gel|scht, und, +wenn sie ge{ndert waren, auf die Diskette zur}ckgeschrieben. Das File wird +anschlie~end geschlossen. + +Bei Verwendung von FLUSH werden alle Files geschlossen. FLUSH sollte VOR jedem +Diskettenwechsel ausgef}hrt werden, und zwar nicht nur, um die ge{nderten +Bl|cke zur}ckzuschreiebn, sondern auch damit alle Files geschlossen werden. +Sind n{mlich Files gleichen Namens auf der neuen Diskette vorhanden, so wird +sonst eine abweichende L{nge des neuen Files vom Forth nicht erkannt. +Nach dem Diskettenwechsel verlangt CP/M das "einloggen" der neuen Diskette. +Dies geschieht mit DOS RESET. Wenn dies vergessen wird, so erh{lt man nach +einem Schreibversuch auf die neue Diskette "BDOS-ERROR ON xx R/O" und landet +zu allem ]berflu~ im CCP. Warum?? Fragen Sie Digital Research! + +Bei Verwendung von VIEW wird automatisch das richtige File ge|ffnet. + + +.PA +4) CP/M 2.2. interne Worte des Filesystems (Implementation) + + In diesem Abschnitt findet sich das Glossary für die Worte, die zur + Implementation des Filesystems benutzt werden. Da das Filesystem noch + recht neu ist, sind noch fast alle Namen sichtbar. Das kann sich aber + {ndern, wenn klar ist, welche Worte man nicht mehr benutzt. + Im Glossary wird oft von Forth-FCB (File-Control-Block) gesprochen. Das + sind Speicherbereiche, mit denen Files beschrieben werden. Auch CP/M + kennt FCBs. Die CP/M Filefunktionen erwarten alle einen DOS-FCB zur + Beschreibung der Files. Die Worte, die diese Funktionen ausl|sen erwarten + aber einen Forth-FCB, die im VolksForth-Filesystem }bliche Beschreibung + von Files. Wenn die Gefahr der Verwechselung besteht, so wird ausdr}cklich von Forth-FCBs und DOS-FCBs gesprochen. Allgemein ist mit der Angabe + von FCB ein Forth-FCB gemeint. Seine Struktur ist aus dem Quelltext + ersichtlich. (Befehlsfolge: DOS VIEW B/FCB) + +!fcb ( fcb -- ) "store-f-c-b" + Interpretiert das als n{chstes in der Eingabe sthende Wort als Filename + und weist es dem fcb zu. + +!name ( addr len fcb -- ) "store-name" + addr gibt die Anfangsadresse eines Strings an, der die L{nge len hat und + einen Filenamen enth{lt. Dieser Name wird in den fcb eingetragen. + Enth{lt er keine Laufwerksangabe, so wird das aktuelle Laufwerk benutzt + und in den FCB geschrieben. + +(capacity ( forthfcb -- n ) "paren-capacity" + n ist die Filegr|~e des durch forthfcb beschrieben Files in Forth- + Bl|cken. + +(close ( fcb -- ) "paren-close" + Schlie~t das File, das durch fcb beschrieben wird. Schreibt alle + ver{nderten Bl|cke dieses Files auf die Diskette zur}ck und l|scht alle + Bl|cke dieses Files in den Blockpuffern. + +(closefile ( forthfcb -- f ) "paren-closefile" + Schlie~t das durch den Forth-FCB angegebene File. f=$FF bedeutet, da~ das + File nicht gefunden werden konnte. (Siehe CP/M Operating System Manual) + +(createfile ( forthfcb -- f ) "paren-createfile" + Erzeugt ein File, das durch den angegebenen Forth-FCB beschrieben wird. + f=$FF bedeutet, da~ im Inhaltsverzeichnis der Diskette kein Platz mehr + ist. (Siehe CP/M Operating System Manual) + +(dir ( addr len -- ) "paren-dir" + addr ist die Anfangsadresse eines Strings der L{nge len, der ein + Suchmuster enth{lt. (dir zeigt die Files an, die auf dieses suchmuster + passen. Siehe SEARCH0, SEARCHNEXT, FILES, FILES". + +(file-read ( forthfcb -- f ) "paren-file-read" + Liest den im Record-Feld des angegebenen Forth-FCB's bestimten Sektor in + den Sektorpuffer ein. f<>0 bedeutet, da~ Daten fehlen. + (Siehe CP/M Operating System Manual) + +(file-write ( forthfcb -- f ) "paren-file-write" + Schreibt den Sektorpuffer auf den im Record-Feld des angegebenen Forth- + FCB's bestimten Sektor. f<>0 bedeutet, da~ die Diskette voll ist. + (Siehe CP/M Operating System Manual) +.pa +(killfile ( forthfcb -- f ) "paren-killfile" + L|scht das durch den Forth-FCB angegebene File. f=$FF bedeutet, da~ das + File nicht gefunden werden konnte. (Siehe CP/M Operating System Manual) + +(makeview ( -- n ) "paren-make-view" + n ist eine Zahl die aus dem momentanen Block (BLK) und dem aktuellen File + (LOADFILE) berechnet wird. Sie wird in das VIEW-Feld einer neuen + Definition geschrieben, und dient dazu sp{ter mit VIEW den Definitions- + Ort zu bestimmen. + +(open ( fcb -- ) "paren-open" + \ffnet das durch den FCB angegebene File und tr{gt dessen L{nge ein. + Meldet einen Fehler, falls das File nicht gefunden werden konnte. + +(openfile ( forthfcb -- f ) "paren-open-file" + \ffnet das durch den Forth-FCB angegebene File. f=$FF bedeutet, da~ das + File nicht gefunden werden konnte. (Siehe CP/M Operating System Manual) + +(read-seq ( forthfcb -- f ) "paren-read-sequential" + Liest den n{chsten Sektor aus dem durch den Forth-FCB angegebene File in + den Sektorpuffer ein. f<>0 bedeutet, da~ keine Daten mehr zur Verf}gung + stehen. + (Siehe CP/M Operating System Manual) + +(view ( viewblk -- blk' ) "paren-view" + blk' ist die relative Blocknummer zum Anfang des in viewblk enthaltenen + Files. viewblock hat die Form: fffffffbbbbbbbbb. Wobei f Bits für die + Filenummer, b Bits für den Block angeben. Das File wird von (VIEW automatisch ge|ffnet. + +(write-seq ( forthfcb -- f ) "paren-write-sequential" + Schreibt den n{chsten Sektor aus dem Sektorpuffer in das durch den Forth- + FCB angegebene File. f<>0 bedeutet, da~ die Diskette voll ist. + (Siehe CP/M Operating System Manual) + + .buffers ( -- ) "dot-buffers" + Gibt eine Liste der Block-puffer aus, die angibt, welchen Block aus + welchem File die Puffer enthalten, und ob sie als UPDATEd markiert sind. + + .dosfile ( fcb -- ) "dot-dosfile" + Gibt den Dos-Namen des durch fcb angegebenen Files aus. + + .fcb ( fcb -- ) "dot-f-c-b" + Gibt den Forth-Namen, den Dos-Namen, die Filegr|~e und den Status + (ge|ffnet / geschlossen ) des durch fcb angegebenen Files aus. + + .file ( fcb -- ) "dot-file" + Gibt den Forth-Namen des durch fcb angegebenen Files aus. + +b/fcb ( -- n ) "bytes-per-f-c-b" + n gibt an, wieviele Bytes ein Forth-FCB belegt. + +b/rec ( -- n ) "bytes-per-record" + n gibt an, wieviele Bytes in die Sektoren passen, die vom Betriebssystem + benutzt werden. Bei CP/M 2.2 sind dies 128 Bytes. +.pa +bdos ( arg fun# -- res ) "bdos" + Veranla~t einen Sprung ins BDOS. fun# ist der Wert, der ins C-Register + geladen wird, die Nummer der aufzurufenden Funktion. arg ist der Wert, + der ins DE-Register geladen werden soll, und res ist der Wert, der vom + BDOS im A-Register zur}ckgeliefert wird. CP/M BDOS-Aufrufe sind im + Operating System Manual beschrieben. + +createfile ( fcb -- ) "createfile" + Erzeugt ein File, da~ durch den FCB beschrieben wird. Meldet einen + Fehler, falls dies nicht m|glich ist. + +default-buffer ( -- addr ) "default-buffer" + addr ist die Adresse des Standard Sektorpuffers des BDOS. + +Dos ( -- ) "dos" + Das Vocabulary, indem die meisten Definitionen des Filesystems gemacht + werden. + +dos-error? ( n -- f ) "dos-error-question" + f ist TRUE, wenn n=$FF ist, denn das ist das Kennzeichen des BDOS für + einen Fehler. + +drive ( forthfcb -- addr ) "drive" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, unter der das + Laufwerk eingetragen ist. + +extension ( forthfcb -- addr ) "extension" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der die + Extension beginnt. + +fcb0 ( -- addr ) "f-c-b-zero" + addr ist die Adresse, des vom CCP-benutzten Standard-File-Control-Blocks, + so ver{ndert, da~ er einen Forth-FCB halten kann. + +file-link ( -- addr ) "file-link" + addr ist die Adresse einer User-Variablen, die auf den Anfang der Forth- + file-liste zeigt. + +file-r/w ( buffer block fcb r/wf -- f ) "file-r-w" + Liest oder schreibt einen Forth-Block von der / auf die Diskette. + r/wf gibt an, ob gelesen (rw/f<>FALSE) oder geschrieben (rw/f=FALSE) + werden soll. + block ist die Nummer des Blocks, buffer die Adresse des Puffers. + fcb bestimmt, ob ein File benutzt wird (fcb<>0 ist dann die Adresse + eines FCB) oder ob im Direktzugriff gearbeitet werden soll (fcb=0). + f ist TRUE, falls ein Fehler aufgetreten ist. Vergleiche R/W. + +filename ( forthfcb -- addr ) "filename" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der der + Filename beginnt. + +filenamelen ( -- n ) "filenamelen" + n gibt die L{nge der im Betriebssystem benutzten Filenamen an. Bei CP/M + sind dies 11 Zeichen (8 Name + 3 Extension) + +fileno ( forthfcb -- addr ) "file-number" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der die + Filenummer abgelegt ist. +.pa +filesize ( forthfcb -- addr ) "filesize" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der die + Filegr|~e (in Sectoren) abgelegt ist. + +in-range ( block fcb -- ) "in-range" + Testet, ob der Forth-Block block in dem durch fcb angegebenen File liegt, + und gibt eine Fehlermeldung aus, falls dies nicht der Fall ist. + + +opened ( forthfcb -- addr ) "opened" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der das open- + Flag abgelegt ist. + +read-seq ( -- ) "read-sequential" + Liest den n{chsten Sektor aus dem aktuellen File in den Sektorpuffer und + liefert einen Fehler, falls dies nicht m|glich ist. + +rec/blk ( -- n ) "bytes-per-record" + n gibt an, wieviele logische CP/M-Sectoren (128 Bytes) in einen Forth- + Block passen. Nach dem Forth-83 Standard ist ein Forth-Block 1024 Bytes + gro~, B/REC ist dann also 8. + +record ( forthfcb -- addr ) "record" + Berechnet aus der Adresse eines Forth-FCBs die Adresse, an der der + Recordz{hler für Random-Access-Files beginnt. + +reset ( -- ) "reset" + Initialisiert das Diskettensystem des BDOS. Mu~ nach einem Diskettenwechsel benutzt werden! (Siehe CP/M Operating System Manual) + +search0 ( forthfcb -- f ) "search-zero" + Sucht im Inhaltsverzeichnis der Diskette nach dem ersten Vorkommen, des + durch den Forth-FCB angegebenen Files. f=$FF bedeutet, da~ das File nicht + gefunden werden konnte. + (Siehe CP/M Operating System Manual) + +searchnext ( forthfcb -- f ) "serach-next" + Sucht im Inhaltsverzeichnis der Diskette nach dem n{chsten Vorkommen, des + durch den Forth-FCB angegebenen Files. f=$FF bedeutet, da~ das File nicht + gefunden werden konnte. + (Siehe CP/M Operating System Manual) + +setdma ( dma -- ) "set-d-m-a" + dma ist die Adresse des Sektorpuffers, der beim n{chsten Diskettenzugriff + benutzt werden soll (Siehe CP/M Operating System Manual) + +size ( forthfcb -- ) "size" + Berechnet die Filegr|~e in dem durch den Forth-FCB beschriebenen File und + tr{gt sie in das Feld record ein. (Siehe CP/M Operating System Manual) + +tab ( -- ) "tab" + Geht auf die n{chste Tabulatorposition (alle 20 Spalten). + +write-seq ( -- ) "write-sequential" + Schreibt einen Sektor aus dem Sektorpuffer als n{chsten Sektor des + aktuellen Files und meldet einen Fehler, falls dies nicht m|glich ist. + +.HE VolksForth Editor für CP/M 2.2 Implementation Seite # +.OP +Der für die CP/M 2.2 Version von VolksForth benutzte Editor enth{lt im +wesentlichen die gleichen Funktionen wie die des Editors auf dem C64, +beschrieben im Handbuch Seite 147ff. +Im Gegensatz zum C64-Editor benutzt der neue Editor das Forth-Screen- +Standardformat von 16 Zeilen a 64 Zeichen. +Aufgerufen wird der Editor mit: L . +Den zuletzt edititierten Screen erh{lt man mit: V , und mit: +VIEW kann man sich ansehen, wo definiert worden ist. + +Die Tastenbelegung ist neu organisiert. Im folgenden wird die Tastenbelegung +für die allgemeine CP/M-Version und für die Schneider Version beschrieben. Mit +Hilfe des Files INSTALL.SCR k|nnen die Tasten neu angepa~t werden. (Siehe +Installationshinweis: "Wie fange ich an?") + +Tastenbelegung für die allgemeine CP/M Version: + +Komando (siehe Handbuch S. 152ff) Taste _______________________________________________________ + +Cursor up Control E +Cursor left Control S +Cursor down Control X +Cursor right Control D +push-line Control I +push-char Control J +pull-line Control O +pull-char Control K +copy-line Control P +copy-char Control L +backspace Control H +backspace delete +delete-char Control G +insert-char Control T +delete-line Control Y +insert-line Control N +insert-mode-on insert-mode-off Control V +clear-to-right Control Z +new-line return ++tab Control F +-tab Control A +search Control \ = Control \ +undo Control U +update-exit Control Q +flushed-exit escape +shadow-screen Control W +next-screen Control C +back-screen Control R +alter-screen Control [ = Control [ +mark-alter-screen Control B + +.pa +Tastenbelegung für die Schneider CP/M Version: + +Komando (siehe Handbuch S. 152ff) Taste _______________________________________________________ + +Cursor up Pfeil nach oben +Cursor left Pfeil nach links +Cursor down Pfeil nach unten +Cursor right Pfeil nach rechts +push-line shift Pfeil nach oben +push-char shift Pfeil nach links +pull-line shift Pfeil nach unten +pull-char shift Pfeil nach rechts +copy-line Control Q +copy-char Control Z +backspace Control H +backspace delete +delete-char Control P (clr) +insert-char copy +delete-line Control D +insert-line Control T +insert-mode-on Control I +overwrite-mode-on Control O +eraser-line Control C +clear-to-right Control E +new-line return ++tab Control Pfeil nach rechts +-tab Control Pfeil nach links +home Control Pfeil noch oben +to-end Control Pfeil nach unten +search Control F +undo Control U +update-exit Control X +flushed-exit escape +show-load Control L +shadow-screen Control W +next-screen Control N +back-screen Control B +alter-screen Control A +mark-alter-screen Control R + +.HE CP/M 2.2 - spezifische Worte +#bs ( -- n ) "number-backspace" + n ist der Ascii-Wert für Backspace. + +#cr ( -- n ) "number-c-r" + n ist der Ascii-Wert für Carriage-Return. + +#esc ( -- n ) "number-escape" + n ist der Ascii-Wert für Escape. + +#lf ( -- n ) "number-linefeed" + n ist der Ascii-Wert für Linefeed. + +(at ( row col -- ) "paren-at" + Positioniert den Cursor in die Zeile row, Spalte col und setzt OUT. + Benutzt dabei LOCATE. Siehe auch AT. + +(at? ( -- row col ) "paren-at-question" + row ist die aktuelle Zeilennummer, col die aktuelle Spaltennummer. + Vergleiche AT? + +(blk/drv ( drv -- blocks ) "paren-blocks-per-drive" + blocks gibt an wieviele Forth-Bl|cke (1kB) auf dem Laufwerk drv + sind. Ist blocks=0, dann existiert dieses Laufwerk nicht. + Siehe BLK/DRV. + +(cr ( -- ) "paren-c-r" + Setzt den Cursor in die erste Spalte der n{chsten Zeile. PAUSE wird + ausgef}hrt. + +(decode ( addr pos1 key --- addr pos2 ) "paren-decode" + Wertet key aus. key wird in der Speicherzelle addr+pos1 abgelegt und + als Echo auf dem Bildschirm ausgegeben. Die Variable SPAN und pos1 + werden inkrementiert. Folgende Tasten werden besonders behandelt: + Control-S und Control-D beeinflussen nur pos1 und den Cursor. Ctrl-G + l|scht das Zeichen unter dem Cursor und dekrementiert SPAN. + Backspace (Control-H) und Delete ($7F) l|schen das Zeichen links vom + Cursor und dekrementieren pos1 und SPAN. Control T f}gt an der + Cursorposition ein Leerzeichen ein. SPAN wird inkrementiert. Return + positioniert den Cursor auf das letzte Zeichen. + Vergleiche INPUT: und (EXPECT. + +(del ( -- ) "paren-del" + L|scht ein Zeichen links vom Cursor. Benutzt dabei CURLEFT. + Vergleiche auch DEL. + +(emit ( 8b -- ) "paren-emit" + Gib 8b auf dem Bildschirm aus. Ein PAUSE wird ausgef}hrt. Alle Werte + werden als Zeichen ausgegeben. Steuercodes sind nicht m|glich, d.h. + alle Werte < $20 werden als Punkt "." ausgegeben. + Vergleiche CON! und EMIT. + +(expect ( addr len -- ) "paren-expect" + Erwartet len Zeichen vom Eingabeger{t, die ab addr im Speicher + abgelegt werden. Ein Echo der Zeichne wird ausgegeben. Return beendet die Eingabe vorzeitig. Ein abschlie~endes Leerzeichen wird + immer ausgegeben. Die L{nge der Zeichenkette wird in der Variablen + SPAN }bergeben. Vergleiche EXPECT. +.PA +(key ( -- char ) "paren-key" + Wartet auf einen Tastendruck. W{hrend der Wartezeit wird PAUSE + ausgef}hrt. Die untersten 7 Bit von char enthalten den Ascii-Code + der gedr}ckten Taste. Steuerzeichen werden nicht ausgewertet, + sondern unver{ndert abgeliefert. Vergleiche KEY. + +(key? ( -- flag ) "paren-key-question" + flag ist TRUE, wenn eine Taste gedr}ckt wurde, sonst false. + Vergleiche auch KEY?. + +(page ( -- ) "paren-page" + L|scht den Bildschirm, positioniert den Cursor in die linke obere + Ecke und setzt OUT auf null. Siehe auch LOCATE und PAGE. + +(r/w ( adr blk file r/wf -- flag ) "paren-r-w" + Ist r/wf<>FALSE, wird der Forth-Block mit der absoluten Blocknummer + blk von der Diskette gelesen. Ist r/wf=FALSE so wird er geschrieben. + adr gibt die Addresse des Block-Puffers an. file mu~ null sein, da + (r/w den Zugriff auf Files nicht unterst}tzt. flag ist TRUE wenn ein + Diskettenfehler vorlag. + +(type ( addr len -- ) "paren-type" + Gibt den String, der im Speicher bei addr beginnt und die L{nge len + hat, auf dem Blidschirm aus. Genau ein PAUSE wird nach der Ausgabe + ausgf}hrt. Vergleiche TYPE, OUTPUT: und (EMIT. + +/drive ( blk -- blk' drv ) "per-drive" + blk gibt die absolute Nummer eines Forth-Blocks an. /DRIVE + berechnet, auf welchem Laufwerk (drv) dieser Block zu finden ist, + und welche relative Blocknummer (blk') er zum Anfang dieses + Laufwerks hat. Siehe DRV?, >DRIVE. + +>drive ( blk drv -- block' ) "to-drive" + blk gibt die relative Blocknummer eine Forth-Blocks bez}glich des + Anfangs von Laufwerk drv an. >DRIVE berechnet daraus, unter welcher + Blocknummer dieser Block beim momentanen Stand von OFFSET erreicht + werden kann (block'). In gewisser Weise Umkehrung von /DRIVE. + +?drive-error ( f -- ) "question-drive-error" + Ist f=FALSE, so wird "beyond capacity" als Fehlermeldung ausgegeben. + +?drive ( n -- n ) "question-drive" + ]berpr}ft, ob das Laufwerk n existiert, und gibt "beyond capacity" + als Fehlermeldung aus, wenn dies nicht der Fall ist. + +b/blk ( -- b/blk ) "bytes-per-block" + Eine Konstante die angibt, wieviele Bytes in einen Forth-Block + passen. Nach dem Forth-83 Standard ist B/BLK = &1024. + +bios ( -- addr ) "bios" + Adresse eines 8080-Unterprogramms, das einen Sprung ins BIOS ausf}hrt. Das Low-Byte der Einsprungadresse steht dabei in HL. Wird von + con!, (key?, getkey und read/write benutzt. + +blk/drv ( -- #blk ) "blocks-per-drive" + #blk gibt die Kapazit{t des aktuellen Laufwerks (bestimmt durch + OFFSET) in Forth-Bl|cken (1kB) an. Siehe (BLK/DRV. +.PA +con! ( 8b -- ) "con-store" + Gibt 8b auf die CONsole (Bildschirm) aus. Ascii-Werte < $20 werden + als Steuercodes interpretiert. + +curleft ( -- ) "cur-left" + Bewegt den Cursor ein Zeichen nach links. Eine der vordefinierten + Terminalfunktionen. + +curoff ( -- ) "cur-off" + Schaltet den Cursor aus. Eine der vordefinierten Terminalfunktionen. + +curon ( -- ) "cur-on" + Schaltet den Cursor an. Eine der vordefinierten Terminalfunktionen. + +currite ( -- ) "cur-right" + Bewegt den Cursor ein Zeichen nach rechts. Eine der vordefinierten + Terminalfunktionen. + +dark ( -- ) "dark" + L|scht den Bildschirm. Eine der vordefinierten Terminalfunktionen. + +display ( -- ) "display" + Ein mit OUTPUT: definiertes Wort, das den Bildschirm als Ausgabeger{t anw{hlt, wenn es ausgef}hrt wird. Die Worte EMIT, CR, TYPE, + DEL, PAGE, AT, und AT? beziehen sich dann auf das aktuelle Terminal. + Siehe TERMINAL:. + +dma! ( addr -- ) "d-m-a-store" + addr ist die Adresse des Diskettenpuffers, der beim n{chsten Diskettenzugriff verwendet werden soll. + +drive ( n -- ) "drive" + W{hlt n als aktuelles Laufwerk an. [ndert OFFSET entsprechend. + Siehe BLK/DRV. + +drv! ( drv f -- dph ) "drive-store" + drv ist die Nummer des Diskettenlaufwerks, das als n{chstes verwendet werden soll. f=0 gibt an, ob es sich um den erste Zugriff + nach einem CP/M Warmstart handelt. dph ist die Adresse des CP/M + Disk-Parameter-Headders. (Siehe CP/M Operating System Manual) + Ist dph=0, so ist das angesprochene Laufwerk in diesem Computersystem nicht unterst}tzt. + +drv? ( blk -- drv ) "drive-question" + blk gibt die absolute Nummer eines FORTH-Blocks an, DRV? berechnet + daraus das Laufwerk (drv) auf dem er zu finden ist. + Siehe /DRIVE, >DRIVE. + +drv0 ( -- ) "drive-zero" + W{hlt Laufwerk 0 (A) als aktuelles Laufwerk für R/W an. Siehe DRIVE + und >DRIVE. + +drv1 ( -- ) "drive-one" + W{hlt Laufwerk 1 (B) als aktuelles Laufwerk für R/W an. Siehe DRIVE + und >DRIVE. + +drvinit ( -- ) "drive-init" + Initialisiert das VolksForth-Disk-System. + Die im Computer-System vorhandenen Laufwerke werden der Reihe nach + selektiert und deren Kapazit{t berechnet. Dann wird das CP/M + default-Laufwerk selektiert. +dumb ( -- ) "dumb" + Ein mit TERMINAL: definiertes Wort, das ein ignorantes Terminal + anw{hlt, wenn es ausgef}hrt wird. CURON, CUROFF, CURLEFT, CURRITE, + RVSON, RVSOFF, DARK und LOCATE haben dann keine Wirkung. Mit ihnen + auch die sie benutzenden Worte (PAGE, (AT, (DEL. Wenn DISPLAY + eingeschaltet ist, sind also auch PAGE, AT und DEL wirkungslos. + DUMB ist als aktuelles Terminal angew{hlt, bis die Installierung + eines leistungsf{higeren Terminals abgeschlossen ist. + +getkey ( -- char ) "getkey" + die unteren 7 Bit von char enthalten den Ascii-Code des letzten + Tastendrucks. Ist noch keine Taste gedr}ckt, dann wartet getkey. + Siehe auch KEY? und KEY. + +home ( -- ) "home" + Der Kopf des momentan selektierte Diskettenlaufwerks wird auf Spur + null gefahren. Spur null wird als n{chste Spur angew{hlt, die + verwendet werden soll. Siehe TRK!, DRV!. + +index ( from to -- ) "index" + Liest die Blocks from bis to einschlie~lich und gibt deren erste + Zeilen aus. Index kann mit einer beliebigen Taste angehalten werden + und mit RETURN abgebrochen werden. (Siehe STOP?) Die ersten Zeilen + von Screens enthalten typischer Weise Kommentare, die den Inhalt + chararkterisieren. + +keyboard ( -- ) "keyboard" + Ein mit INPUT: definiertes Wort, das die Tastatur als Eingabeger{t + anw{hlt. Die Worte KEY, KEY?, DECODE und EXPECT beziehen sich nun + auf die Tastatur. Siehe (KEY, (KEY? (DECODE, (EXPECT. + +locate ( row col -- ) "locate" + Bewegt den Cursor absolut auf Spalte col, Zeile row. + Eine der vordefinierten Terminalfunktionen. + + +out ( -- addr ) "out" + Adresse einer Variablen, die die Anzahl der ausgegebenen Zeichen + enth{lt. + +read/write ( r/wf sponti -- f ) "read-write" + Bewirkt das physikalische Lesen (r/wf = FALSE) und Schreiben + (r/wf=TRUE) eines Sektors (=128 Bytes) von der/auf die Diskette. Das + Laufwerk, die Spur , der Sektor sowie der Sektor-Puffer sind vorher + mit DRV!, TRK!, SEC! und DMA! gew{hlt worden. + sponti gibt an, ob beim Schreiben unmittelbar auf die Diskette + geschrieben werden soll (sponti=TRUE) oder, ob der geschriebene + Sektor im BIOS zwischengepuffert werden darf (sponti=FALSE). + +rvsoff ( -- ) "reverse-off" + Schaltet die Inversdarstellung aus. Eine der vordefinierten + Terminalfunktionen. + +rvson ( -- ) "reverse-on" + Schaltet die Inversedarstellung ein. Eine der vordefinierten + Terminalfunktionen. + +sec! ( sec -- ) "sec-store" + sec ist der beim n{chsten Diskettenzugriff zu verwendende Sektor. +.PA +Term: ( offset -- offset' ) "term-colon" + Ein definierendes Wort für Terminalfunktionen. Wird benutzt um die + einzelnen Komponenten eines Terminal-Vektors zu definieren. + Vordefinierte Terminalfunktionen sind CURON, CUROFF, CURLEFT, + CURRITE, RVSON, RVSOFF, DARK und LOCATE. Siehe auch TERMINAL: + +Terminal: ( -- ) "terminal-colon" + Ein definierendes Wort für Terminals. Benutzt in der Form: + Terminal: + newCURON newCUROFF newCURLEFT newCURRITE + newRVSON newRVSOFF newDARK newLOACTE ; + TERMINAL: erzeugt einen Kopf für im Dictionary und kompiliert + einen Vektor von Zeigern auf Worte die für die Ausf}hrung von Terminalfunktionen zust{ndig sind. Wird ausgef}hrt, so werden + die Terminalfunktionen von zu den aktuellen Terminalfunktionen gemacht, das Terminal ist damit aktiv. Terminalfunktionen werden von AT, PAGE, DEL ausgef}hrt, wenn die Ausgabe auf + DISPLAY geschaltet ist. Siehe OUTPUT:, DISPLAY, DUMB. + +trk! ( trk -- ) "track-store" + trk ist die beim n{chsten Diskettenzugriff zu verwendende Spur. + +.OP +.HE Der volksForth-8080-Assembler Seite # +Die CP/M-Version von VolksForth ist mit einem Assembler für den Intel 8080 +ausgestattet. Dieser Assembler kann aber auch unter den anderen Versionen +geladen werden und so als Cross-Assembler arbeiten. +Diese Beschreibung enth{lt kein vollst{ndiges Glossar, da die Mnemonics des +Assemblers den meisten Programmierern vertraut sein d}rften. Sie dient als +Erg{nzung der Beschreibung des 6502-Assemblers im UltraForth83-Handbuch Seite +175ff. +Eine genaue Darstellung der Funktionsweise findet sich in dem Artikel von John +J. Cassady in den FORTH-Dimensions (Jahrgang III/6 Seite 180f), an dessen +Implementation sich die VolksForth-Version anlehnt. +Der 8080-Assmebler erlaubt strukturierte Programmierung. Er verwendet die +gleichen Strukturelemente, wie der 6502-Assembler. +Vor den Kontrollstrukturen sind folgende Condition Codes zul{ssig: + + c0= c0<> cs 0= 0<> pe 0< 0>= + +Sie entsprechen den Flags im Processor Status Word des 8080. +Neben den Kontrollstrukturen gibt es auch noch absoluten Spr}nge (jc, jm, jmp, +jnc, jnz, jp, jpe, jpo, jz). + +Beispiele für die Verwendung des 8080-Assemblers: + +VolksForth Intel + +A xra xra A +A L mov mov L,A +0 H mvi mvi H,0 +H pop pop H +vector lxi lxi vektor +D dad dad D + ... ... + + +Die Belegung der Forth-Register sieht folgenderma~en aus: + +IP im BC-Registerpaar + W im DE-Registerpaar +SP im SP +UP im Speicher +RP im Speicher + +Die beiden 8-Bit-H{lften von IP und W k|nnen auch getrennt angesprochen werden +durch (IP und IP', bzw. W und W'). +Zum Ansprechen der 8080-Register d}rfen die FORTH-Namen sowie die Intel Namen +benutzt werden. + +Zus{tzlich enth{lt das System noch mehrere Macros: + + R rpop : Hole das 16-Bit-Register R (R<>H) vom Returnstack. + R rpush : Bringe das 16-Bit-Register R (R<>H) zum Returnstack. + R1 R2 mvx : Kopiere 16-Bit-Register R1 nach R2. + Next : Springe zum Address-Interpreter. + ;c: : Schalte den Assembler ab und den Forth-Compiler an. + +.pa +Vordefinierte Labels sind: + + Hpush : Adresse der Routine, die das H-Register auf den Stack bringt + und dann zu Next springt. + Dpush : Adresse der Routine, die das D- und H-Register auf + den Stack bringt und dann zu Next springt. + >Next : Adresse des Address-Interpreters. + UP : Adresse der Speicherzelle für den User-Pointer + RP : Adresse der Speicherzelle für den Returnstack- + pointer + IPsave : Adresse einer Hilfszelle um den IP zwischenzuspeichern + +Neue Labels k|nnen mit >LABEL und LABEL erzeugt werden, wie im 6502-Assembler. diff --git a/sources/generic/csb.fth b/sources/generic/csb.fth new file mode 100644 index 0000000..974eb2d --- /dev/null +++ b/sources/generic/csb.fth @@ -0,0 +1,35 @@ +( ----- 000 ) +\\ Circular String Buffer cas 27jul20 + Wil Baden, Costa Mesa, California + Forth Dimensions July 1996 +( ----- 001 ) +\ CSB load screen cas 27jul20 + + 1 3 +thru + + + .( Circular Ring Buffer loaded. ) +( ----- 002 ) +\ Get-Buf >PAD cas 27jul20 + +1000 CONSTANT /CSB +CREATE CSB 0 , /CSB ALLOT + + : GET-BUF ( n -- c_addr ) + DUP CSB @ > IF /CSB CSB ! THEN + NEGATE CSB +! + CSB 2+ CSB @ + ; + + : >PAD ( a u -- 'a u ) + DUP GET-BUF SWAP + 2DUP >R >R MOVE R> R> ; +( ----- 003 ) +\ S" cas 27jul20 + + : S" ( "ccc" -- | c_addr u ) + ASCII " PARSE + STATE @ IF + POSTPONE SLITERAL + ELSE + >PAD + THEN ; IMMEDIATE diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 index 0000000..78583ec --- /dev/null +++ b/tools/Makefile @@ -0,0 +1,18 @@ +BLKPACK_TGT = blkpack +BLKUNPACK_TGT = blkunpack +TARGETS = $(BLKUNPACK_TGT) $(BLKPACK_TGT) + +all: $(TARGETS) + +.SUFFIXES: .c .o +.c.o: + $(CC) $(CFLAGS) -c $< -o $@ + +$(BLKPACK_TGT): $(BLKPACK_TGT).c +$(BLKUNPACK_TGT): $(BLKUNPACK_TGT).c +$(TARGETS): + $(CC) $(CFLAGS) $@.c -o $@ + +.PHONY: clean +clean: + rm -f $(TARGETS) $(OBJS) diff --git a/tools/blkpack.c b/tools/blkpack.c new file mode 100644 index 0000000..9ce3dfa --- /dev/null +++ b/tools/blkpack.c @@ -0,0 +1,97 @@ +#include +#include +#include +#include +#include +#include +#include + +static int lineno; + +static void emptylines(int n) +{ + for (int i=0; i<64*n; i++) putchar(0x20); +} + +static int getmarker(char *line) // returns -1 on error, blkid otherwise +{ + int blkid; + int r = sscanf(line, "( ----- %d )\n", &blkid); + if (r == 1) { + return blkid; + } else { + return -1; + } +} + +static int expectmarker(char *line) +{ + int blkid = getmarker(line); + if (blkid < 0) { // could not scan + fprintf( + stderr, "Error at line %d: expecting block marker\n", lineno); + } + return blkid; +} + +static void usage() +{ + fprintf(stderr, "Usage: blkpack < blk.fs > blkfs\n"); +} + +int main(int argc, char *argv[]) +{ + int prevblkid = -1; + int blkid; + char *line = NULL; + if (argc != 1) { + usage(); + return 1; + } + lineno = 1; + size_t n = 0; + ssize_t cnt = getline(&line, &n, stdin); + if (cnt <= 0) { + fprintf(stderr, "No input\n"); + return 1; + } + while (1) { + blkid = expectmarker(line); + if (blkid < 0) return 1; + if (blkid <= prevblkid) { + fprintf( + stderr, + "Wrong blkid (%d) at line %d: blocks must be ordered\n", + blkid, lineno); + return 1; + } + emptylines((blkid-prevblkid-1)*16); + int blkline; + for (blkline=0; blkline<16; blkline++) { + lineno++; + cnt = getline(&line, &n, stdin); + if (cnt <= 0) break; // EOF + if (cnt > 65) { + fprintf(stderr, "Line %d too long (blk %d)\n", lineno, blkid); + return 1; + } + if (getmarker(line) >= 0) break; // we have a marker early + line[cnt-1] = '\0'; // remove newline + printf("%s", line); + // pad line to 64 chars + for (int i=cnt-1; i<64; i++) putchar(0x20); + } + if (blkline == 16) { + lineno++; + cnt = getline(&line, &n, stdin); + } else { + // fill to 16 lines + emptylines(16-blkline); + } + if (cnt <= 0) break; // EOF + prevblkid = blkid; + } + free(line); + return 0; +} + diff --git a/tools/blkunpack.c b/tools/blkunpack.c new file mode 100644 index 0000000..a17b841 --- /dev/null +++ b/tools/blkunpack.c @@ -0,0 +1,64 @@ +#include +#include +#include + +/* Unpacks blkfs into its source form. + * + * If numerical "startat" is specified, blkno start at this number. + * + * Whitespaces at the right of every line are trimmed. + */ +void usage() +{ + fprintf(stderr, "Usage: blkunpack [startat] < blkfs > blk.fs\n"); +} + +int main(int argc, char *argv[]) +{ + char buf[1024]; + int blkid = 0; + if (argc > 2) { + usage(); + return 1; + } + if (argc == 2) { + blkid = strtol(argv[1], NULL, 10); + } + while (fread(buf, 1024, 1, stdin) == 1) { + int linecnt = 0 ; + for (int i=1023; i>=0; i--) { + if (buf[i] > ' ') { + linecnt = (i / 64) + 1; + break; + } + } + if (linecnt) { + // not an empty block + printf("( ----- %03d )\n", blkid); + for (int i=0; i=0; j--) { + if (line[j] > ' ') { + break; + } + } + int len = j+1; + if (len) { + for (; j>=0; j--) { + if (line[j] == '\0') { + line[j] = ' '; + } + } + fwrite(line, len, 1, stdout); + } + fputc('\n', stdout); + } + } + blkid++; + } + return 0; +} diff --git a/tools/echo-tolower.py b/tools/echo-tolower.py new file mode 100755 index 0000000..a46699f --- /dev/null +++ b/tools/echo-tolower.py @@ -0,0 +1,5 @@ +#!/usr/bin/python3 + +import sys + +print(' '.join(a.lower() for a in sys.argv[1:])) diff --git a/tools/echo-toupper.py b/tools/echo-toupper.py new file mode 100755 index 0000000..655fa3e --- /dev/null +++ b/tools/echo-toupper.py @@ -0,0 +1,5 @@ +#!/usr/bin/python3 + +import sys + +print(' '.join(a.upper() for a in sys.argv[1:])) diff --git a/tools/fb2fth.py b/tools/fb2fth.py index 5403cad..5493000 100755 --- a/tools/fb2fth.py +++ b/tools/fb2fth.py @@ -15,7 +15,7 @@ def readToString(inFile): while(offset < len(block)): # sys.stderr.write("block %d offset %d\n" % (blockNo, offset)) line = block[offset:offset+64].decode(encoding="cp437") - result.append(line.rstrip()) + result.append(line.rstrip().replace('\0', '^@')) offset += 64 blockNo += 1 return result