====== Volksforth Kernel 3.80 ====== Der code wurde unverändert komplett eingestellt um durchsuchbar zu sein, in der Hoffnung hilfreich und anregend zu sein beim Entwurf eigener Systeme. Der code ist so wie er ist natürlich nicht ladbar auf einen der angegebenen Zielrechner, sondern war Quelle für den Metacompiler Prozess, und setzt auch den ebenfalls in Forth vorliegenden Assembler für die genannten Prozessoren voraus. Der code wurde freundlicher Weise bereit gestellt von U.Hoffmann. \ #### volksFORTH #### ks 11 mai 88 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck Zuerst fuer den 6502 von B.Pennemann und K.Schleisiek Anpassung fuer C64 "ultraFORTH" von G.Rehfeld Anpassung fuer 68000 und TOS von D.Weineck und B.Pennemann Anpassung fuer 8080 und CP/M von U.Hoffmann jul 86 Anpassung fuer C16 "ultraFORTH" von C.Vogt Anpassung fuer 8088/86 und MS-DOS von K.Schleisiek dez 87 Diese Version 3.80 steht auf den aufgefuehrten Rechnern in identischen Versionen zur Verfuegung. Das Fileinterface ist unausgereift und wird in der Version 3.90 entscheidend ver- bessert sein. \ MS-DOS volksForth Load Screen ks 03 apr 88 Onlyforth \needs Transient include meta.scr 2 loadfrom META.SCR new FORTH.COM Onlyforth Target definitions 4 &111 thru \ Standard 8088-System flush \ close FORTH.COM cr .( neuer Kern als FORTH.COM erzeugt) cr bell \\ 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 \\ 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. \ FORTH Preamble and ID ks 11 mar 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.8" \ Next ks uho 02apr05 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 \ 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 \ 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 \ 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 \ 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 \ 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 ; \ 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 ; \ 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 \ @ ! 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+ ! ; \ +! 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 \ 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 ; \ 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 ; \ -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@ + @ ; \ 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* + ! ; \ 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 ; \ 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 \ + - 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 + ; \ 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 \ 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 \ 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 ! ; \ 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 \ 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< ; \ 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<> ; \ 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 ; \ 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< ; \ 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 ; \\ 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 ; \ (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 ; \ (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 \ 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 \ branch ?branch uho 02apr05 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 Code branch2 ' branch @ here 2- ! end-code Code ?branch2 ' ?branch @ here 2- ! end-code : compile-branch compile branch2 ; : compile-?branch compile ?branch2 ; \ 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 \ 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 | \ 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 + ; \ 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 ; \ /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 / ; \ / 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> ; \ 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 \ 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@ ; \ 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 ; \ 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 \ 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 ; \ 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 \\ 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 - ; \ 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 \ 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 ; \ (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 \\ (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> ; \ 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 ; \ 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 \ ." ( .( \ \\ 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 ! ; \ 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- ; \ 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 ; \ 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 +! ; \ 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 ; \ hide reveal immediate restrict ks 18 mar 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! ; \ 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 ; \ Does> ; ks 18 mar 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 \ ?head | alignments ks 19 mar 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 ; \ Create Variable ks 19 mar 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 , ; \ 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 ; \ >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 ; \ : ; 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 \ 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 \ 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 +! ; \ 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 ! ; \ 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 ; \ (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 \\ -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 ; \ 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 ; \ 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 ; \ 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 ; \ 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 \ ?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" ; \ .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 ; \ +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/ ; \ 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> " ; \ 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 ; \ (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 \ -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 ; \ 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 ; \ 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 ; \ list c/l l/s ks 19 mar 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 ; \ 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 \\ 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 ... \ 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 \ (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 \\ (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 ; \ 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> ; \ 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 & 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 & 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 ; \ 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 ; \ 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 ; \ 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 ; \ 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 ; \ 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 ! ; \ 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 ; \ 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 \ 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 \ '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 ; \ (boot ks 11 mar 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 \ restart ks 09 mar 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 \ bye ks 11 mar 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 ; \ cold ks 09 mar 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 \ 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 \ 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 \ 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 \ 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 \ 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 ; \\ 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. \ (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 \ 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 ; \ 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 \ 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 \ 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 ; \ 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 \\ MS-dos disk handlers direct access uho 16mai05 | 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 \\ MS-dos disk handlers direct access ksuho 16mai05 | : ?drive ( +n -- +n ) dup #drives u< ?exit Error" jenseits der Platte" ; : /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 - ; \ MS-DOS file access ks 18 mar 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 \ MS-DOS disk errors ks 18 mar 88 | : .error# ." fehler # " 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 ; \ MS-DOS disk errors ks 04 okt 87 : (diskerror ( *f -- ) ?dup 0=exit fcb @ IF error# ! .ferrors exit THEN input push output push standardi/o 1- IF ." Lese" ELSE ." Schreib" THEN .error# ." wiederholen? (j/n)" key cr capital Ascii J = not Abort" aborted" ; ' (diskerror Is ?diskerror \ ~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 \ ~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 \ ~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 \ MS-DOS file control block ks 19 mar 88 | : 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 \ (.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 ; \ (.file fname fname! ks 18 mar 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 ; \ freset fseek ks 19 mar 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 ; \ 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 ; \ 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 *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* ; \ fblock@ fblock! ks 19 mar 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 ; \ (r/w flush ks uho 16mai05 Forth definitions : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! IF fblock@ false exit THEN fblock! false ; ' (r/w Is r/w | : setfiles ( fcb -- ) isfile@ prevfile ! dup isfile ! fromfile ! ; \ File >file ks uho 16mai05 : 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 -- ) body> >name .name ; \ .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 ; \ use from loadfrom include ks 18 mar 88 : use >in @ name find 0= IF swap >in ! File last' THEN nip dup @ [fcb] - Abort" not a file" execute open ; : from isfile push use ; : loadfrom ( n -- ) pushfile use load close ; : include 1 loadfrom ; \ drive drv capacity drivenames ks uho 16mai05 : drive ( n -- ) ~select ; : drv ( -- n ) ~disk? ; : capacity ( -- n ) isfile@ dup f.handle @ 0= IF dup freset THEN f.size 2@ /block swap 0<> - ; | : 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: \ 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 ; \ viewing ks 19 mar 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 ; \ 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 ! ; \ 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@ ; \ finis