Forth-eV Wiki

Diese Seite ist nicht editierbar. Sie können den Quelltext sehen, jedoch nicht verändern. Kontaktieren Sie den Administrator, wenn Sie glauben, dass hier ein Fehler vorliegt.
====== Volksforth Kernel 3.80 ======

Der code wurde unverändert komplett eingestellt um durchsuchbar zu sein, in der Hoffnung hilfreich und anregend zu sein beim Entwurf eigener Systeme. Der code ist so wie er ist natürlich nicht ladbar auf einen der angegebenen Zielrechner, sondern war Quelle für den Metacompiler Prozess, und setzt auch den ebenfalls in Forth vorliegenden Assembler für die genannten Prozessoren voraus.

Der code wurde freundlicher Weise bereit gestellt von U.Hoffmann.

<code>

\  ####  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

</code>