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 ( -- addr ) here ;
: <resolve ( addr -- ) here - , ;
: ?pairs ( n1 n2 -- ) - Abort" unstructured" ;
\ Branching ks uho 02apr05
: 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 # 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 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