diff --git a/8086/pc-baremetal/Makefile b/8086/pc-baremetal/Makefile new file mode 100644 index 0000000..f2931ce --- /dev/null +++ b/8086/pc-baremetal/Makefile @@ -0,0 +1,16 @@ +TARGET = forth.com +BASE = ../.. +BLKPACK = $(BASE)/tools/blkpack + +.PHONY: all +all: $(TARGET) + +%.fb: %.fth $(BLKPACK) + $(BLKPACK) < $< > $@ + +$(TARGET): kernel.fb meta.fb + emu2 $(BASE)/8086/msdos/volks4th.com "include kernel.fb" + +.PHONY: clean +clean: + rm -f $(TARGET) meta.com *.fb diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth new file mode 100644 index 0000000..f268664 --- /dev/null +++ b/8086/pc-baremetal/kernel.fth @@ -0,0 +1,2145 @@ +( ----- 000 ) +\ #### 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 +( ----- 001 ) +\ 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 bye +( ----- 002 ) +\\ 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 +( ----- 003 ) +\\ 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. +( ----- 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 +\ 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" +( ----- 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 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 +( ----- 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 \ 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 +( ----- 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, 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 ; +( ----- 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 ) +\\ (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> ; +( ----- 054 ) +\ 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 ; +( ----- 055 ) +\ 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 +( ----- 056 ) +\ ." ( .( \ \\ 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 ! ; +( ----- 057 ) +\ 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- ; +( ----- 058 ) +\ 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 ; +( ----- 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 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 ; +( ----- 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 ; + + : 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 ; +( ----- 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] 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 ; +( ----- 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 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 ; +( ----- 081 ) +\ +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/ ; +( ----- 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 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; +( ----- 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 Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 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 ) +\ 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 ; +( ----- 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 ) +\\ 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 ... +( ----- 091 ) +\ 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 +( ----- 092 ) +\ (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 +( ----- 093 ) +\\ (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 ; +( ----- 094 ) +\ 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> ; +( ----- 095 ) +\ 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 ; +( ----- 096 ) +\ 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 ; +( ----- 097 ) +\ 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 ; +( ----- 098 ) +\ 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 ; +( ----- 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 remove-files + 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 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 ; +( ----- 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 init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (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 + + 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 ; +( ----- 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 &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 +( ----- 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 ) +\ 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 +( ----- 115 ) +\ 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 ; +( ----- 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 + + 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. +( ----- 117 ) +\ (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 +( ----- 118 ) +\ 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 ; +( ----- 119 ) +\ 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 +( ----- 120 ) +\ 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 +( ----- 121 ) +\ 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 ; +( ----- 122 ) +\ 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 +( ----- 123 ) +\ 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 +( ----- 124 ) +\ 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 - ; +( ----- 125 ) +\ 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 +( ----- 126 ) +\ 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 ; +( ----- 127 ) +\ 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 +( ----- 128 ) +\ ~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 +( ----- 129 ) +\ ~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 +( ----- 130 ) +\ ~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 +( ----- 131 ) +\ 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 +( ----- 132 ) +\ (.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 ; +( ----- 133 ) +\ (.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 ; +( ----- 134 ) +\ 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 ; +( ----- 135 ) +\ 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 ; +( ----- 136 ) +\ 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 ; +( ----- 137 ) +\ /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* ; +( ----- 138 ) +\ 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 ; +( ----- 139 ) +\ (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 ; +( ----- 140 ) +\ 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" ; +( ----- 141 ) +\ .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 ; +( ----- 142 ) +\ 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 ; +( ----- 143 ) +\ 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: +( ----- 144 ) +\ 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 ; +( ----- 145 ) +\ 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 ; +( ----- 146 ) +\ 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 ! ; +( ----- 147 ) +\ 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@ ; diff --git a/8086/pc-baremetal/meta.fth b/8086/pc-baremetal/meta.fth new file mode 100644 index 0000000..9c31d34 --- /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 + + : 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 +( ----- 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