mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-06 09:29:28 +00:00
1 line
160 KiB
Plaintext
1 line
160 KiB
Plaintext
\ #### volksFORTH #### ks 11 mai 88 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck Zuerst f<>r den 6502 von B.Pennemann und K.Schleisiek Anpassung f<>r C64 "ultraFORTH" von G.Rehfeld Anpassung f<>r 68000 und TOS von D.Weineck und B.Pennemann Anpassung f<>r 8080 und CP/M von U.Hoffmann jul 86 Anpassung f<>r C16 "ultraFORTH" von C.Vogt Anpassung f<>r 8088/86 und MS-DOS von K.Schleisiek dez 87 Diese Version 3.80 steht auf den aufgef<65>hrten Rechnern in identischen Versionen zur Verf<72>gung. Das Fileinterface ist unausgereift und wird in der Version 3.90 entscheidend ver- bessert sein. \ MS-DOS volksForth Load Screen ks cas 09jun20 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 .( 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 gewaehltDabei 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 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" \ 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 \ 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 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 \ resolve loops and branches ks 02 okt 87 : >mark ( -- addr ) here 0 , ; : >resolve ( addr -- ) here over - swap ! ; : <mark ( -- addr ) here ; : <resolve ( addr -- ) here - , ; : ?pairs ( n1 n2 -- ) - Abort" unstructured" ; \ Branching ks 17 jul 87 : IF compile ?branch >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 ; immediate restrict : WHILE 2 ?pairs 2 compile ?branch >mark -2 2swap ; immediate restrict | : (repeat 2 ?pairs <resolve BEGIN dup -2 = WHILE drop >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> ]? $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 ( <name> -- 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 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! ; \ 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 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 \ ?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 ; \ 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 , ; \ 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 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 ; \ 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 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 \ 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 \ 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 ; \ 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 \ 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 cas 27jul20\ 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 kscas 27jul20 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 cas 27jul20 Code xkey ( -- 16b) D push A+ A+ xor $16 int A D xchg 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 ) xkey $FF and ; : (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 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 \ MS-dos disk handlers direct access ks 09 aug 87 | : ?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 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 \ MS-DOS disk errors ks 18 m„r 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 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 \ (.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 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 ; \ 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 ; \ 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 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 ; \ (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 ; \ 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" ; \ .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 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 ; \ 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: \ 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 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 ; \ 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 csa 27jul20 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@ ; |