Screen 0 not modified     
 0 \\ volksFORTH CP/M 2.2 rev. 3.80a                        18Nov87
 1                                                                 
 2 Entwicklung des volksFORTH-83 von                               
 3    K. Schleisiek, B. Pennemann,                                 
 4    G. Rehfeld, D. Weineck, U. Hoffmann                          
 5                                                                 
 6 Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann          
 7                                                                 
 8 Dieses File enthaelt den kompletten Sourcetext des Kern-Systems 
 9 fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.
10 Mit Hilfe eines Target-Compilers wird daraus das volksFORTH-    
11 System erzeugt, daher finden sich an einigen Stellen Anweisungen
12 an den Target-Compiler, die fuer das Verstaendnis des Systems   
13 nicht wichtig sind.                                             
14 Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- 
15 besondere die Bdos-Schnittstelle fuer Disk-IO im Kern.          
Screen 1 not modified     
 0 \ CP/M 2.2   volksForth Load Screen                      27Nov87
 1                                                                 
 2 Onlyforth                                                       
 3     $9000 displace !                                            
 4 Target definitions   $100 here!                                 
 5                                                                 
 6                                                                 
 7   1 $74 +thru    \ Standard 8080-System                         
 8                                                                 
 9 cr .( unresolved: )  .unresolved   ( ' .blk is .status )        
10                                                                 
11 save-target  KERNEL.COM                                         
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 2 not modified     
 0 \ FORTH Preamble and ID                            uho 19May2005
 1                                                                 
 2 Assembler                                                       
 3                                                                 
 4 nop  0 jmp   here 2- >label >boot                               
 5 nop  0 jmp   here 2- >label >cold                               
 6 nop  0 jmp   here 2- >label >restart                            
 7                                                                 
 8 here dup origin!                                                
 9 \ Hier beginnen die Kaltstartwerte der Benutzervariablen        
10                                                                 
11 6 rst   0 jmp   end-code  \ for multitasker                     
12                                                                 
13 $100 allot                                                      
14                                                                 
15 | Create logo ," volksFORTH-83 rev. 3.80a"                      
Screen 3 not modified     
 0 \ Assembler Labels Next Forth-Register                   29Jun86
 1                                                                 
 2 Label dpush   D push    Label hpush   H push                    
 3 Label >next                                                     
 4    IP ldax   IP inx   A L mov   IP ldax   IP inx   A H mov      
 5 Label >next1                                                    
 6    M E mov   H inx   M D mov   xchg   pchl                      
 7 end-code                                                        
 8                                                                 
 9 Variable RP                                                     
10 Variable UP                                                     
11 \ IP in BC                                                      
12 \ W  in DE                                                      
13 \ SP in SP                                                      
14 Variable IPsave                                                 
15                                                                 
Screen 4 not modified     
 0 \ Assembler Macros                                       20Oct86
 1 Compiler Assembler also definitions  Forth                      
 2 : Next    T >next jmp [ Forth ]  ;                              
 3 T hpush Forth Constant hpush   T dpush Forth Constant dpush     
 4 T >next Forth Constant >next                                    
 5                                                                 
 6 : rpush ( reg -- )  RP lhld  H dcx  DUP M mov ( high )          
 7    H dcx   1+ M mov ( low )   RP shld  [ Forth ] ;              
 8                                                                 
 9 : rpop  ( reg -- )  RP lhld   M over 1+ mov ( low )  H inx      
10    M swap mov ( high )  H inx   RP shld [ Forth ] ;             
11 \  rpush und rpop gehen nicht mit HL                            
12                                                                 
13 : mvx ( src dest -- )                                           
14    2dup  mov ( high )  1+ swap 1+ swap mov  ( low ) [ Forth ] ; 
15 Target                                                          
Screen 5 not modified     
 0 \ recover ;c: noop                                       20Oct86
 1                                                                 
 2 Create recover   Assembler                                      
 3    W pop   IP rpush   W IP mvx                                  
 4 Next end-code                                                   
 5                                                                 
 6 Compiler Assembler also definitions   Forth                     
 7                                                                 
 8 : ;c:   0 T recover call  end-code   ]  [ Forth ] ;             
 9                                                                 
10 Target                                                          
11                                                                 
12 | Code di   di Next end-code                                    
13 | Code ei   ei Next end-code                                    
14                                                                 
15 Code noop   >next here 2- !   end-code                          
Screen 6 not modified     
 0 \ User variables                                         04Oct87
 1                                                                 
 2 Constant origin   8 uallot drop  \ Multitasker                  
 3      \ Felder: entry  link  spare  SPsave                       
 4      \ Laenge kompatibel zum 68000 und 6502 volksFORTH          
 5 User s0                                                         
 6 User r0                                                         
 7 User dp                                                         
 8 User offset            0 offset !                               
 9 User base              $0A base !                               
10 User output                                                     
11 User input                                                      
12 User errorhandler       \ pointer for Abort" -code              
13 User voc-link                                                   
14 User udp                \ points to next free addr in User      
15                                                                 
Screen 7 not modified     
 0 \ manipulate system pointers                             11Jun86
 1                                                                 
 2 Code sp@  ( -- addr)   0 H lxi   SP dad   hpush jmp   end-code  
 3                                                                 
 4 Code sp!  ( addr --)   H pop   sphl   Next   end-code           
 5                                                                 
 6                                                                 
 7 Code up@  ( -- addr)   UP lhld   hpush jmp   end-code           
 8                                                                 
 9 Code up!  ( addr --)   H pop   UP shld   Next   end-code        
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 8 not modified     
 0 \ manipulate returnstack                                 11Jun86
 1                                                                 
 2 Code rp@ ( -- addr )   RP lhld   hpush jmp   end-code           
 3                                                                 
 4 Code rp! ( addr -- )   H pop   RP shld   Next  end-code         
 5                                                                 
 6                                                                 
 7 Code >r  ( 16b -- )    D pop   D rpush   Next end-code restrict 
 8                                                                 
 9 Code r>  ( -- 16b )    D rpop   D push   Next end-code restrict 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 9 not modified     
 0 \ r@ rdrop  exit unnest ?exit                            07Oct87
 1 Code r@ ( -- 16b )                                              
 2    RP lhld   M E mov   H inx   M D mov   D push   Next  end-code
 3                                                                 
 4 Code rdrop                                                      
 5    RP lhld   H inx   H inx   RP shld   Next end-code   restrict 
 6                                                                 
 7 Code exit    Label >exit   IP rpop   Next  end-code             
 8 Code unnest   >exit  here 2- !                                  
 9                                                                 
10 Code ?exit ( flag -- )                                          
11    H pop   H A mov   L ora   >exit jnz   Next end-code          
12                                                                 
13 Code 0=exit ( flag -- )                                         
14    H pop   H A mov   L ora   >exit jz    Next end-code          
15 \ : ?exit ( flag -- )   IF rdrop THEN ;                         
Screen 10 not modified     
 0 \ execute  perform                             11Jun86   18Nov87
 1                                                                 
 2 Code execute   ( cfa -- )                                       
 3    H pop >Next1 jmp end-code                                    
 4                                                                 
 5 Code perform   ( 'cfa -- )                                      
 6    H pop    M A mov   H inx   M H mov   A L mov  >Next1 jmp     
 7 end-code                                                        
 8                                                                 
 9                                                                 
10 \\                                                              
11 : perform   ( addr -- )      @ execute ;                        
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 11 not modified     
 0 \ c@ c! ctoggle                                          07Oct87
 1                                                                 
 2 Code c@   ( addr -- 8b )                                        
 3    H pop   M L mov   0 H mvi   hpush jmp   end-code             
 4                                                                 
 5 Code c!   ( 16b addr -- )                                       
 6    H pop   D pop    E M mov   Next   end-code                   
 7                                                                 
 8 Code flip ( 16b1 -- 16b2 )                                      
 9    H pop   H A mov   L H mov   A L mov   Hpush jmp   end-code   
10                                                                 
11 Code ctoggle ( 8b addr -- )                                     
12    H pop   D pop   M A mov   E xra   A M mov   Next  end-code   
13                                                                 
14 \\                                                              
15 : ctoggle   ( 8b addr --)      under c@ xor swap c! ;           
Screen 12 not modified     
 0 \ @ ! 2@ 2!                                    11Jun86   18Nov87
 1                                                                 
 2 Code @  ( addr -- 16b )   H pop   Label fetch                   
 3   M E mov   H inx   M D mov   D push   Next   end-code          
 4                                                                 
 5 Code !  ( 16b addr -- )                                         
 6    H pop   D pop   E M mov   H inx   D M mov   Next   end-code  
 7                                                                 
 8 Code 2@   ( addr -- 32b )   H pop   H push                      
 9    H inx  H inx   M E mov   H inx   M D mov   H pop   D push    
10    M E mov   H inx   M D mov  D push    Next   end-code         
11                                                                 
12 Code 2!   ( 32b addr -- )   H pop                               
13    D pop    E M mov   H inx   D M mov   H inx                   
14    D pop    E M mov   H inx   D M mov   Next   end-code         
15                                                                 
Screen 13 not modified     
 0 \ +! drop swap                                 11Jun86   18Nov87
 1                                                                 
 2 Code +! ( 16b addr -- )  H pop                                  
 3    Label +store   D pop                                         
 4      M A mov   E add   A M mov   H inx                          
 5      M A mov   D adc   A M mov    Next   end-code               
 6                                                                 
 7 \  : +!   ( n addr -- )   under @ + swap ! ;                    
 8                                                                 
 9                                                                 
10 Code drop   ( 16b -- )   H pop   Next   end-code                
11                                                                 
12 Code swap   ( 16b1 16b2 -- 16b2 16b1 )                          
13    H pop   xthl   hpush jmp   end-code                          
14                                                                 
15                                                                 
Screen 14 not modified     
 0 \ dup  ?dup                                              16May86
 1                                                                 
 2 Code dup    ( 16b -- 16b 16b )                                  
 3    H pop   H push   hpush jmp   end-code                        
 4                                                                 
 5 Code ?dup ( 16b -- 16b 16b / false)                             
 6    H pop   H A mov   L ora   0<> ?[ H push ]?                   
 7    hpush jmp   end-code                                         
 8                                                                 
 9 \\                                                              
10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ;              
11                                                                 
12 : dup ( 16b -- 16b 16b )    sp@ @ ;                             
13                                                                 
14                                                                 
15                                                                 
Screen 15 not modified     
 0 \ over rot nip under                                     11Jun86
 1                                                                 
 2 Code over   ( 16b1 16b2 - 16b1 16b2 16b1 )                      
 3    D pop   H pop   H push   dpush jmp   end-code                
 4 Code rot    ( 16b1 16b2 16b3 - 16b2 16b3 16b1 )                 
 5    D pop   H pop   xthl   dpush jmp   end-code                  
 6 Code nip ( 16b1 16b2 -- 16b2)                                   
 7    H pop   D pop   hpush jmp   end-code                         
 8 Code under ( 16b1 16b2 -- 16b2 16b1 16b2)                       
 9    H pop   D pop   H push  dpush jmp   end-code                 
10                                                                 
11 \\                                                              
12 : over   >r swap r> swap ;                                      
13 : rot   >r dup r> swap ;                                        
14 : nip   swap drop ;                                             
15 : under swap over ;                                             
Screen 16 not modified     
 0 \ -rot pick roll -roll                                   11Jun86
 1 Code -rot    ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )               
 2    H pop    D pop   xthl   H push   D push   Next   end-code    
 3                                                                 
 4 Code pick    ( n -- 16b.n )                                     
 5    H pop   H dad   SP dad                                       
 6    M E mov   H inx   M D mov   D push   Next   end-code         
 7                                                                 
 8 : roll   ( n -- )                                               
 9    dup >r  pick sp@ dup 2+  r> 1+ 2* cmove> drop ;              
10                                                                 
11 : -roll   ( n -- ) >r dup sp@ dup 2+                            
12    dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ;                       
13 \\                                                              
14 : -rot    ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )   rot rot ;      
15 : pick    ( n -- 16b.n )     1+ 2* sp@ + @ ;                    
Screen 17 not modified     
 0 \ double word stack manipulation                         09May86
 1 Code 2swap ( 32b1 32b2 -- 32b2 32b1)                            
 2    H pop   D pop   xthl   H push                                
 3    5 H lxi   SP dad   M A mov    D M mov   A D mov              
 4    H dcx   M A mov   E M mov   A E mov   H pop   dpush jmp      
 5 end-code                                                        
 6                                                                 
 7 Code 2drop ( 32b -- )   H pop   H pop   Next   end-code         
 8                                                                 
 9 Code 2dup ( 32b -- 32b 32b)                                     
10    H pop   D pop   D push   H push   dpush jmp   end-code       
11                                                                 
12 \\                                                              
13 : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ;               
14 : 2drop ( 32b -- ) drop drop ;                                  
15 : 2dup ( 32b -- 32b 32b) over over ;                            
Screen 18 not modified     
 0 \ + and or xor not                                       09May86
 1 Code +     ( n1 n2 -- n3 )                                      
 2    H pop   D pop   D dad   hpush jmp end-code                   
 3 Code or    ( 16b1 16b2 -- 16b3 )                                
 4    H pop   D pop   H A mov  D ora  A H mov                      
 5    L A mov   E ora   A L mov   hpush jmp end-code               
 6 Code and   ( 16b1 16b2 -- 16b3 )                                
 7    H pop   D pop   H A mov   D ana   A H mov                    
 8    L A mov   E ana   A L mov   hpush jmp   end-code             
 9 Code xor   ( 16b1 16b2 -- 16b3 )                                
10    H pop   D pop   H A mov   D xra   A H mov                    
11    L A mov   E xra   A L mov   hpush jmp   end-code             
12 Code not   ( 16b1 -- 16b2 )  H pop  Label >not                  
13    H A mov   cma    A H mov   L A mov   cma   A L mov           
14    hpush jmp   end-code                                         
15                                                                 
Screen 19 not modified     
 0 \ -  negate                                              16May86
 1                                                                 
 2 Code -    ( n1 n2 -- n3 )                                       
 3    D pop   H pop                                                
 4    L A mov   E sub   A L mov                                    
 5    H A mov   D sbb   A H mov   hpush jmp end-code               
 6                                                                 
 7 Code negate ( n1 -- n2 )                                        
 8    H pop   H dcx   >not jmp   end-code                          
 9                                                                 
10 \\                                                              
11 : -    ( n1 n2 -- n3 )   negate + ;                             
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 20 not modified     
 0 \ dnegate d+                                   10Mar86   18Nov87
 1                                                                 
 2 Code dnegate   ( d1 -- -d1 )  H pop                             
 3    Label >dnegate                                               
 4       D pop   A sub   E sub   A E mov   0 A mvi   D sbb         
 5       A D mov   0 A mvi   L sbb   A L mov   0 A mvi   H sbb     
 6       A H mov   dpush jmp   end-code                            
 7                                                                 
 8 Code d+        ( d1 d2 -- d3)                                   
 9    6 H lxi   SP dad   M E mov   C M mov   H inx                 
10    M D mov   B M mov  B pop   H pop   D dad   xchg              
11    H pop   L A mov   C adc   A L mov   H A mov   B adc          
12    A H mov   B pop   dpush jmp   end-code                       
13                                                                 
14                                                                 
15                                                                 
Screen 21 not modified     
 0 \ 1+ 2+ 3+ 4+ 6+    1- 2- 4-                             27Apr86
 1 Code 1+ ( n1 -- n2 )    H pop   H inx   hpush jmp   end-code    
 2 Code 2+ ( n1 -- n2 )                                            
 3    H pop    H inx   H inx   hpush jmp   end-code                
 4 Code 3+ ( n1 -- n2 )                                            
 5    H pop   H inx   H inx   H inx   hpush jmp   end-code         
 6 Code 4+ ( n1 -- n2 )                                            
 7    H pop   4 D lxi   D dad   hpush jmp   end-code               
 8 | Code  6+ ( n1 -- n2 )                                         
 9    H pop   6 D lxi   D dad   hpush jmp   end-code               
10 Code 1- ( n1 -- n2 )    H pop   H dcx   hpush jmp   end-code    
11 Code 2- ( n1 -- n2 )                                            
12    H pop    H dcx   H dcx   hpush jmp   end-code                
13 Code 4- ( n1 -- n2 )                                            
14    H pop   -4 D lxi   D dad   hpush jmp   end-code              
15                                                                 
Screen 22 not modified     
 0 \ number Constants                                       07Oct87
 1 -1 Constant true      0 Constant false                          
 2                                                                 
 3  0 ( --  0 )   Constant   0                                     
 4  1 ( --  1 )   Constant   1                                     
 5  2 ( --  2 )   Constant   2                                     
 6  3 ( --  3 )   Constant   3                                     
 7  4 ( --  4 )   Constant   4                                     
 8 -1 ( -- -1 )   Constant  -1                                     
 9                                                                 
10 Code on ( addr -- )  H pop   $FF A mvi                          
11  Label set   A M mov   H inx   A M mov   Next                   
12 Code off ( addr -- )   H pop   A xra   set jmp   end-code       
13                                                                 
14 \  : on   ( addr -- )   true  swap ! ;                          
15 \ : off  ( addr -- )   false swap ! ;                           
Screen 23 not modified     
 0 \ words for number literals                              16May86
 1                                                                 
 2 Code lit   ( -- 16b )                                           
 3    IP ldax   A L mov   IP inx   IP ldax   A H mov   IP inx      
 4 hpush jmp end-code                                              
 5                                                                 
 6 Code clit   ( -- 8b )                                           
 7    IP ldax   A L mov   0 H mvi   IP inx   hpush jmp             
 8 end-code                                                        
 9                                                                 
10 : Literal  ( 16b -- )                                           
11    dup $FF00 and   IF  compile lit , exit  THEN                 
12    compile clit c, ; immediate restrict                         
13                                                                 
14                                                                 
15                                                                 
Screen 24 not modified     
 0 \ comparision words                                      18Nov87
 1 Label  (u<  ( HL,DE  ->  HL u< DE  c,z )                        
 2    H A mov   D cmp   rnz   L A mov   E cmp   ret                
 3 Label  (<   ( HL,DE  ->  HL  < DE  c,z )                        
 4    H A mov   D xra   (u< jp    D A mov   H cmp   ret            
 5                                                                 
 6 Label yes  true  H lxi  hpush jmp                               
 7 Code u< ( u1 u2 -- flag )   D pop   H pop                       
 8    Label uless   (u< call   yes jc                              
 9    Label no   false H lxi   hpush jmp                           
10                                                                 
11 Code <     ( n1 n2 -- flag )   D pop   H pop                    
12    Label less    (< call  yes jc  no jmp   end-code             
13                                                                 
14 Code u> ( u1 u2 -- flag )  H pop   D pop  uless jmp   end-code  
15 Code >  ( n1 n2 -- flag )  H pop   D pop   less jmp   end-code  
Screen 25 not modified     
 0 \ comparision words                                      18Nov87
 1 Code 0< ( n1 n2 -- flag )   H pop                               
 2    Label negative   H dad   yes jc   no jmp   end-code          
 3                                                                 
 4 Code 0> ( n -- flag )   H pop   H A mov   A ora   no jm         
 5                         L ora   yes jnz   no jmp   end-code     
 6                                                                 
 7 Code 0= ( n -- flag )   H pop                                   
 8    Label zero=   H A mov   L ora   yes jz    no jmp   end-code  
 9                                                                 
10 Code 0<>  ( n -- flag )                                         
11    H pop   H A mov   L ora   yes jnz   no jmp   end-code        
12                                                                 
13 Code =    ( n1 n2 -- flag )  H pop   D pop                      
14    L A mov   E cmp   no jnz                                     
15    H A mov   D cmp   no jnz   yes jmp   end-code                
Screen 26 not modified     
 0 \\ comparision words high level                          18Nov87
 1 : 0<  ( n1 -- flag )       8000 and 0<> ;                       
 2 : >   ( n1 n2 -- flag )    swap < ;                             
 3 : 0>  ( n -- flag )        negate 0< ;                          
 4 : 0<> ( n -- flag )        0= not ;                             
 5 : u>  ( u1 u2 -- flag )    swap u< ;                            
 6 : =   ( n1 n2 -- flag )    - 0= ;                               
 7 : uwithin  ( u1 [low up[ -- flag )    over - -rot  - u> ;       
 8 | : minimax  ( n1 n2 flag -- n3 )   rdrop IF swap THEN drop ;   
 9 : min  ( n1 n2 -- n3 )              2dup  > minimax ;           
10 : max  ( n1 n2 -- n3 )              2dup  < minimax ;           
11 : umax  ( u1 u2 -- u3 )             2dup u< minimax ;           
12 : umin  ( u1 u2 -- u3 )             2dup u> minimax ;           
13 : extend   ( n -- d )               dup 0< ;                    
14 : dabs  ( d -- ud )                 extend IF dnegate THEN ;    
15 : abs   ( n -- u)                   extend IF  negate THEN ;    
Screen 27 not modified     
 0 \ uwthin double number comparison words                  18Nov87
 1                                                                 
 2 Code uwithin ( u1 [low up[ -- flag )  H pop   D pop   xthl      
 3    (u< call   cs ?[    H pop   no jmp   ]?                      
 4    D pop   (u< call   yes jc   no jmp   end-code                
 5                                                                 
 6 Code d0= ( d -- flag )  H pop                                   
 7    H A mov   L ora   H pop   no jnz   zero= jmp  end-code       
 8                                                                 
 9 : d=  ( d1 d2 -- flag )    rot =  -rot =  and ;                 
10 : d<  ( d1 d2 -- flag )                                         
11     rot 2dup =  IF 2drop u< exit THEN  > nip nip ;              
12                                                                 
13                                                                 
14 \\                                                              
15 : d0= ( d -- flag )        or 0= ;                              
Screen 28 not modified     
 0 \ minimum maximum                                        18Nov87
 1                                                                 
 2 Code umax ( u1 u2 -- u3 )                                       
 3    H pop   D pop   (u< call                                     
 4 Label minimax  cs ?[ xchg ]?  hpush jmp   end-code              
 5                                                                 
 6 Code umin ( u1 u2 -- u3 )                                       
 7    H pop   D pop   (u< call   cmc   minimax jmp   end-code      
 8                                                                 
 9 Code max ( n1 n2 -- n3 )                                        
10    H pop   D pop   (< call   minimax jmp   end-code             
11                                                                 
12 Code min ( n1 n2 -- n3 )                                        
13    H pop   D pop   (< call   cmc   minimax   jmp end-code       
14                                                                 
15                                                                 
Screen 29 not modified     
 0 \ sign extension absolute values                         18Nov87
 1                                                                 
 2 Code extend ( n -- d )  H pop   H push   negative jmp  end-code 
 3                                                                 
 4 Code abs    ( a -- u )  H pop   H A mov  A ora                  
 5    hpush jp   H dcx  >not jmp  end-code                         
 6                                                                 
 7 Code dabs   ( d -- ud )  H pop   H A mov   A ora                
 8    hpush jp   >dnegate jmp   end-code                           
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 30 not modified     
 0 \ branch ?branch                                         20Nov87
 1                                                                 
 2 Code branch ( -- )  Label >branch                               
 3    IP H mvx   M E mov   H inx   M D mov   H dcx                 
 4    D dad   H IP mvx   Next   end-code                           
 5                                                                 
 6 Code ?branch ( fl -- )                                          
 7    H pop   H A mov   L ora  >branch jz                          
 8    IP inx   IP inx  Next   end-code                             
 9                                                                 
10                                                                 
11 \\                                                              
12 : branch r> dup @ + >r ;                                        
13                                                                 
14                                                                 
15                                                                 
Screen 31 not modified     
 0 \ loop primitives                              11Jun86   20Nov87
 1                                                                 
 2 Code bounds ( start count -- limit start )                      
 3    H pop   D pop   D dad    H push   D push   Next   end-code   
 4                                                                 
 5 Code endloop                                                    
 6    RP lhld   6 D lxi   D dad   RP shld   next  end-code restrict
 7                                                                 
 8 \\ dodo puts "index | limit | adr.of.DO" on return-stack        
 9 : bounds ( start count -- limit start )     over + swap ;       
10                                                                 
11 | : dodo              rdrop r> 2+ dup >r rot >r swap >r >r ;    
12                                                                 
13 : (do  ( limit start -- )  over - dodo ;  restrict              
14 : (?do ( limit start -- )  over - ?dup IF dodo THEN             
15                            r> dup  @ +  >r drop ; restrict      
Screen 32 not modified     
 0 \ loop primitives                                        20Nov87
 1                                                                 
 2 Code (do ( limit start -- )  H pop  D pop                       
 3   Label >do                                                     
 4     L A mov   E sub   A L mov                                   
 5     H A mov   D sbb   A H mov                                   
 6     H push   IP inx   IP inx                                    
 7     RP lhld   H dcx  IP M mov   H dcx   IP' M mov               
 8               H dcx   D M mov   H dcx    E  M mov               
 9     D pop     H dcx   D M mov   H dcx    E  M mov   RP shld     
10     Next   end-code   restrict                                  
11                                                                 
12 Code (?do ( limit start -- )  H pop  D pop                      
13     H A mov   D cmp   >do jnz                                   
14     L A mov   E cmp   >do jnz   >branch jmp                     
15 end-code  restrict                                              
Screen 33 not modified     
 0 \ (loop (+loop                                 14May86   20Nov87
 1                                                                 
 2 Code (loop                                                      
 3    RP lhld   M inr   0= ?[ H inx   M inr   >next jz   ]?        
 4 Label doloop   RP lhld    4 D lxi  D dad                        
 5                M IP' mov   H inx   M IP mov   Next              
 6 end-code restrict                                               
 7                                                                 
 8 Code (+loop                                                     
 9    RP lhld   D pop                                              
10    M A mov   E add   A M mov   H inx                            
11    M A mov   D adc   A M mov                                    
12    rar   D xra   doloop jp   Next                               
13 end-code restrict                                               
14                                                                 
15                                                                 
Screen 34 not modified     
 0 \ loop indices                                 06May86   20Nov87
 1                                                                 
 2 Code I ( -- n )                                                 
 3    RP lhld                                                      
 4 Label >I     M E mov   H inx   M D mov   D push                 
 5    H inx     M E mov   H inx   M D mov   H pop   D dad          
 6    hpush jmp                                                    
 7 end-code                                                        
 8                                                                 
 9 Code J ( -- n )                                                 
10    RP lhld   6 D lxi  D dad     >I jmp   end-code               
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 35 not modified     
 0 \ interpretive conditionals                           UH 25Jan88
 1                                                                 
 2 | Create: remove>>  r> rp! ;                                    
 3 | : >>r ( addr len -- addr ) r>  over rp@  under swap - dup rp! 
 4      swap >r remove>> >r swap >r  dup >r swap cmove r> ;        
 5                                                                 
 6 | Variable saved-dp     0 saved-dp !                            
 7                                                                 
 8 | Variable level    0 level !                                   
 9                                                                 
10 | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit 
11       1 level !  here saved-dp ! ] ;                            
12                                                                 
13 | : -level ( -- ) state @ 0= Abort" unstructured"               
14      level @ 0=exit -1 level +!  level @ ?exit  compile unnest  
15      [compile] [  saved-dp @  here over dp !  over -  >>r >r ;  
Screen 36 not modified     
 0 \ resolve loops and branches                          UH 25Jan88
 1                                                                 
 2 : >mark     ( -- addr )           here 0 , ;                    
 3                                                                 
 4 : +>mark    ( acf -- addr )       +level , >mark ;              
 5                                                                 
 6 : >resolve  ( addr -- )           here over - swap !  -level ;  
 7                                                                 
 8 : <mark     ( -- addr )           +level  here ;                
 9                                                                 
10 : <resolve  ( addr -- )           here - , -level ;             
11                                                                 
12 : ?pairs    ( n1 n2 -- )          - Abort" unstructured" ;      
13                                                                 
14                                                                 
15                                                                 
Screen 37 not modified     
 0 \ case?                                                  14May86
 1                                                                 
 2 Code case? ( 16b1 16b2 -- 16b1 false / true )                   
 3    H pop   D pop                                                
 4    H A mov   D cmp   0= ?[   L A mov   E cmp   yes jz ]?        
 5    D push   no jmp   end-code                                   
 6                                                                 
 7 \\                                                              
 8 : case? ( 16b1 16b2 -- 16b1 false / true )                      
 9     over = dup  IF nip THEN ;                                   
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 38 not modified     
 0 \ Branching                                           UH 25Jan88
 1                                                                 
 2 : IF             ['] ?branch +>mark 1 ; immediate               
 3 : THEN           abs 1 ?pairs >resolve ;   immediate            
 4 : ELSE           1 ?pairs  ['] branch +>mark swap               
 5                  >resolve -1 ;             immediate            
 6 : BEGIN          <mark 2 ;                 immediate            
 7 : WHILE          2 ?pairs 2   ['] ?branch +>mark                
 8                  -2 2swap ;                immediate            
 9                                                                 
10 | : (reptil      <resolve                                       
11                  BEGIN dup -2 = WHILE drop >resolve REPEAT ;    
12                                                                 
13 : REPEAT         2 ?pairs compile  branch (reptil ; immediate   
14 : UNTIL          2 ?pairs compile ?branch (reptil ; immediate   
15                                                                 
Screen 39 not modified     
 0 \ Loops                                               UH 25Jan88
 1                                                                 
 2 : DO        ['] (do  +>mark 3 ;       immediate                 
 3 : ?DO       ['] (?do +>mark 3 ;       immediate                 
 4 : LOOP      3 ?pairs compile  (loop compile endloop >resolve ;  
 5                                          immediate              
 6 : +LOOP     3 ?pairs compile (+loop compile endloop >resolve ;  
 7                                          immediate              
 8                                                                 
 9 Code LEAVE                                                      
10    RP lhld   4 D lxi   D dad   M E mov   H inx   M D mov        
11    H inx   RP shld   xchg    H dcx   M D mov   H dcx   M E mov  
12    D dad   H IP mvx   Next   end-code   restrict                
13                                                                 
14 \\ Returnstack: calladr | index limit | adr of DO               
15 : LEAVE     endloop r> 2- dup @ + >r ;             restrict     
Screen 40 not modified     
 0 \ um*                                                    16May86
 1 Label (um*   0 H lxi   ( 0=Teil-Produkt )                       
 2              4 C mvi   ( Schleifen-Zaehler )                    
 3          [[  H dad ( Schiebe HL 24 bits nach links )            
 4              ral cs ?[   D dad   0 aci   ]?                     
 5              H dad   ral   cs ?[   D dad   0 aci   ]?           
 6       C dcr  0= ?]   ret                                        
 7                                                                 
 8 Code um*      ( u1 u2 -- ud )                                   
 9    D pop      H pop     B push   H B mov   L A mov   (um* call  
10    H push   A H mov   B A mov    H B mov             (um* call  
11    D pop    D C mov     B dad      0 aci   L D mov    H L mov   
12    A H mov      B pop     dpush jmp end-code                    
13                                                                 
14                                                                 
15                                                                 
Screen 41 not modified     
 0 \ m* * 2* 2/                                             16May86
 1                                                                 
 2 : m*  ( n1 n2 -- d )    dup 0< dup >r IF negate THEN            
 3                         swap dup 0< IF negate r> not >r THEN    
 4                         um* r> IF dnegate THEN ;                
 5                                                                 
 6 : *  ( n1 n2 - prod )   um* drop ;                              
 7                                                                 
 8 Code 2*  ( n -- 2*n )   H pop   H dad   hpush jmp   end-code    
 9                                                                 
10 Code 2/  ( n -- n/2 )                                           
11    H pop   H A mov   rlc   rrc   rar   A H mov                  
12            L A mov   rar   A L mov   hpush jmp   end-code       
13 \\                                                              
14 : 2*  ( n -- 2*n )   2 * ;                                      
15 : 2/  ( n -- n/2 )   2 / ;                                      
Screen 42 not modified     
 0 \ um/mod                                                 14May86
 1 Label usl0                                                      
 2    A E mov   H A mov   C sub   A H mov   E A mov   B sbb        
 3    cs ?[ H A mov   C add   A H mov   E A mov   D dcr rz         
 4 Label usla                                                      
 5          H dad   ral   usl0 jnc                                 
 6          A E mov   H A mov   C sub   A H mov   E A mov   B sbb  
 7       ]? L inr   D dcr   usla jnz   ret                         
 8 Label usbad     -1 H lxi   B pop   H push   hpush jmp           
 9 Code um/mod   ( d1 n1 -- rem quot )                             
10    IP H mvx     B pop   D pop   xthl   xchg                     
11    L A mov   C sub   H A mov   B sbb   usbad jnc                
12    H A mov   L H mov   D L mov   8 D mvi   D push               
13    usla call   D pop   H push   E L mov   usla call             
14    A D mov   H E mov   B pop   C H mov   B pop                  
15    D push   hpush jmp   end-code                                
Screen 43 not modified     
 0 \ m/mod                                                  16May86
 1                                                                 
 2 : m/mod ( d n -- mod quot)                                      
 3    dup >r  abs over 0< IF  under + swap  THEN                   
 4    um/mod  r@ 0< IF  negate over IF  swap r@ + swap 1-          
 5    THEN THEN rdrop ;                                            
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 44 not modified     
 0 \ /mod / mod */mod */ u/mod  ud/mod                      16May86
 1                                                                 
 2 : /mod   ( n1 n2 -- rem quot )      >r extend r> m/mod ;        
 3                                                                 
 4 : /      ( n1 n2 --     quot )      /mod nip ;                  
 5                                                                 
 6 : mod    ( n1 n2 -- rem )           /mod drop ;                 
 7                                                                 
 8 : */mod  ( n1 n2 n3 -- rem quot )   >r m* r> m/mod ;            
 9                                                                 
10 : */     ( n1 n2 n3 -- quot )       */mod nip ;                 
11                                                                 
12 : u/mod  ( u1 u2 -- urem uquot )    0 swap um/mod ;             
13                                                                 
14 : ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r   
15                                     um/mod r> ;                 
Screen 45 not modified     
 0 \ cmove cmove>                                 16May86   18Nov87
 1                                                                 
 2 Code cmove ( from to count -- )   IP H mvx   IPsave shld        
 3      B pop   D pop   H pop                                      
 4   Label (cmove                                                  
 5      [[ B A mov   C ora   0= not ?[[                            
 6         M A mov   H INX   D stax   D inx  B dcx                 
 7      ]]? IPsave lhld  H IP mvx   Next end-code                  
 8                                                                 
 9 Code cmove>   ( from to count -- )   IP H mvx   IPsave shld     
10      B pop   D pop   H pop                                      
11   Label (cmove>                                                 
12      B dad   H dcx   xchg   B dad   H dcx   xchg                
13      [[ B A mov   C ora   0= not ?[[                            
14         M A mov   H dcx   D stax   D dcx   B dcx                
15      ]]? IPsave lhld  H IP mvx   Next end-code                  
Screen 46 not modified     
 0 \ move place count                             17Oct86   18Nov87
 1                                                                 
 2 Code move  ( from to quan -- )                                  
 3       IP H mvx  Ipsave shld   B pop   D pop   H pop             
 4    Label domove  (u< call   (cmove jnc   (cmove> jmp   end-code 
 5                                                                 
 6 | Code (place ( addr len to -- len to )  IP H mvx  Ipsave shld  
 7     D pop  B pop  H pop                                         
 8     B push  D push   D inx   domove jmp   end-code              
 9                                                                 
10 : place ( addr len to -- )  (place c! ;                         
11                                                                 
12 Code count ( adr -- adr+1 len )   H pop   M E mov   0 D mvi     
13       H inx    H push   D push   Next  end-code                 
14                                                                 
15                                                                 
Screen 47 not modified     
 0 \ fill erase                                             18Nov87
 1                                                                 
 2 Code fill ( addr quan 8b -- )                                   
 3    IP H mvx   IPsave shld   D pop   B pop   H pop               
 4    [[ B A mov   C ora   0<> ?[[                                 
 5       E M mov   H inx   B dcx                                   
 6    ]]?  IPsave lhld   H IP mvx   Next   end-code                
 7                                                                 
 8 : erase   ( addr quan --)            0 fill ;                   
 9                                                                 
10 \\ : fill ( addr quan 8b -- )                                   
11    swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; 
12 : count ( adr -- adr+1 len )  dup 1+ swap c@ ;                  
13 : move   ( from to quan -- )                                    
14    >r  2dup u< IF  r> cmove> exit  THEN  r> cmove ;             
15 : place  ( addr len to --)  over >r  rot over 1+  r> move c! ;  
Screen 48 not modified     
 0 \ here allot , c, pad compile                  11Jun86   18Nov87
 1                                                                 
 2 Code here ( -- addr )  user' dp  D lxi                          
 3    UP lhld   D dad   fetch jmp   end-code                       
 4                                                                 
 5 Code allot ( n -- )    user' dp  D lxi                          
 6    UP lhld   D dad   +store jmp  end-code                       
 7                                                                 
 8 : ,      ( 16b -- )  here  ! 2 allot ;                          
 9 : c,     ( 8b -- )   here c! 1 allot ;                          
10                                                                 
11 : pad    ( -- addr ) here $42 + ;                               
12 : compile            r> dup 2+ >r @ , ; restrict                
13                                                                 
14 \ : here   ( -- addr ) dp @ ;                                   
15 \ : allot  ( n -- )    dp +! ;                                  
Screen 49 not modified     
 0 \ input strings                                          11Jun86
 1                                                                 
 2 Variable #tib     0 #tib !                                      
 3 Variable >tib     here >tib ! $50 allot                         
 4 Variable >in      0 >in !                                       
 5 Variable blk      0 blk !                                       
 6 Variable span     0 span !                                      
 7                                                                 
 8 : tib ( -- addr )  >tib @ ;                                     
 9                                                                 
10 : query ( -- )  tib $50 expect span @ #tib !  >in off blk off ; 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 50 not modified     
 0 \\ scan skip /string                           16May86   18Nov87
 1                                                                 
 2 : scan ( addr0 len0 char -- addr1 len1 ) >r                     
 3    BEGIN dup WHILE  over c@ r@ -  WHILE  1- swap 1+ swap REPEAT 
 4    rdrop ;                                                      
 5                                                                 
 6 : skip ( addr len del -- addr1 len1 ) >r                        
 7    BEGIN dup WHILE  over c@ r@ =  WHILE  1- swap 1+ swap REPEAT 
 8    rdrop ;                                                      
 9                                                                 
10 : /string ( addr0 len0 +n - addr1 len1 )                        
11    over umin rot over + -rot - ;                                
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 51 not modified     
 0 \ skip scan                                              18Nov87
 1 Label done    H push   B push   IPsave lhld   H IP mvx   Next   
 2 Code skip   ( addr len del -- addr1 len1 )                      
 3    IP H mvx   IPsave shld   D pop   B pop   H pop               
 4    [[ B A mov   C ora   done jz                                 
 5       M A mov   E cmp   done jnz   H inx   B dcx  ]] end-code   
 6                                                                 
 7 Code scan   ( addr len chr -- addr1 len1 )                      
 8    IP H mvx   IPsave shld   D pop   B pop   H pop               
 9    [[ B A mov   C ora   done jz                                 
10       M A mov   E cmp   done jz   H inx   B dcx  ]] end-code    
11                                                                 
12 Code /string ( addr0 len0 +n - addr1 len1 )   H pop   D pop     
13    D push  (u< call  cs ?[ xchg ]?   H pop   xthl   D dad   xthl
14    L A mov   E sub   A L mov   H A mov   D sbb   A H mov        
15    Hpush jmp   end-code                                         
Screen 52 not modified     
 0 \ capitalize    ohne Umlaute !!                16May86UH 25Jan88
 1 Variable caps  0 caps !                                         
 2 Label ?capital   caps lda   A ana   rz                          
 3 Label (capital ( e --> A,E )   E A mov  Ascii a cpi   rc        
 4     Ascii z 1+ cpi   rnc   Ascii a Ascii A - sui  A E mov  ret  
 5                                                                 
 6 Code capital ( char -- char')  D pop                            
 7    (capital call    D push   Next  end-code                     
 8 Code upper ( addr len -- )   D pop   E D mov   H pop   D inr    
 9    [[ D dcr >next jz  M E mov  (capital call  E M mov  H inx ]] 
10 end-code                                                        
11                                                                 
12 \\ : capital ( char -- char')                                   
13    dup  Ascii a   [ Ascii z 1+ ] Literal  uwithin not ?exit     
14    [ Ascii a Ascii A - ] Literal - ;                            
15 : upper ( addr len -- )  bounds   ?DO I c@ capital I c! LOOP ;  
Screen 53 not modified     
 0 \ (word                                                  16May86
 1                                                                 
 2 Code (word ( char adr0 len0 -- addr )                           
 3    IP H mvx   IPsave shld   B pop   B dcx  D pop                
 4    >in lhld   D dad   xchg   xthl   xchg   H push   >in lhld    
 5    C A mov   L sub   A L mov   B A mov   H sbb   A H mov        
 6    cs ?[ B inx   C A mov   >in sta   B A mov   >in 1+ sta       
 7                  D pop   H pop   D push                         
 8    ][ H inx   H B mvx   H pop                                   
 9       [[  B A mov   C ora   0<>                                 
10       ?[[  M A mov   E cmp   0=   ?[[  H inx  B dcx ]]? ]?      
11       H push                                                    
12       [[  B A mov  C ora   0<>                                  
13       ?[[  M A mov   E cmp   0<>   ?[[ H inx  B dcx ]]? ]?      
14       xchg    H pop   xthl                                      
15       E A mov   L sub   A L mov   D A mov   H sbb   A H mov     
Screen 54 not modified     
 0 \ (word Part2                                            16May86
 1                                                                 
 2       B A mov  C ora   0<> ?[ H inx ]?   >in shld   ]?          
 3    H pop   E A mov   L sub   A C mov   D A mov   H sbb   A B mov
 4    H push   user' dp D lxi   UP lhld   D dad                    
 5    M A mov   H inx   M H mov  A L mov   D pop   H push          
 6    C M mov   H inx                                              
 7    [[ B A mov  C ora 0<>                                        
 8    ?[[ D ldax  A M mov   H inx  D inx  B dcx ]]?   bl M mvi     
 9    IPsave lhld   H IP mvx   Next   end-code                     
10 \\                                                              
11 : (word  ( char adr0 len0 -- addr )                             
12    rot  >r  over swap   >in @ /string                           
13    r@ skip   over swap   r> scan >r   rot over swap - r> 0<> -  
14    >in !   over - here  dup >r  place  bl r@ count  + c!   r> ; 
15                                                                 
Screen 55 not modified     
 0 \ source word parse name                       20Oct86UH 25Jan88
 1                                                                 
 2 Variable loadfile                                               
 3                                                                 
 4 : source ( -- addr len )   blk @ ?dup                           
 5    IF loadfile @ (block  b/blk   exit  THEN  tib #tib @ ;       
 6                                                                 
 7 : word ( char -- addr )   source (word ;                        
 8                                                                 
 9 : parse ( char -- addr len )                                    
10    >r  source  >in @ /string  over  swap r>  scan >r            
11    over - dup r>  0<> -  >in +! ;                               
12                                                                 
13 : name ( -- addr )   bl word  dup count upper  exit ;           
14                                                                 
15                                                                 
Screen 56 not modified     
 0 \ state Ascii ," "lit ("  "                              18Nov87
 1                                                                 
 2 Variable state   0 state !                                      
 3                                                                 
 4 : Ascii  ( char -- n )                                          
 5    bl word  1+ c@  state @ IF [compile] Literal THEN ; immediate
 6                                                                 
 7 Code "lit   RP lhld   M E mov   H inx   M D mov   H dcx         
 8    D push   D ldax   D inx   E add   A M mov   H inx            
 9    D A mov   0 aci   A M mov   Next  end-code                   
10                                                                 
11 : ,"    Ascii " parse  here over 1+ allot place ;               
12 : ("    "lit ; restrict                                         
13 : "     compile (" ," align ; immediate restrict                
14                                                                 
15 \  : "lit  r> r> under  count + even  >r >r ;   restrict        
Screen 57 not modified     
 0 \ ." ( .( \ \\ hex decimal                               07Oct87
 1                                                                 
 2 : (."      "lit count type ; restrict                           
 3 : ."       compile (." ," align ; immediate restrict            
 4                                                                 
 5 : (        ascii ) parse 2drop ; immediate                      
 6 : .(       ascii ) parse type ; immediate                       
 7                                                                 
 8 : \        >in @ negate  c/l mod  >in +! ; immediate            
 9 : \\       b/blk >in ! ; immediate                              
10 : \needs   name find nip 0=exit [compile] \ ;                   
11                                                                 
12 : hex      $10 base ! ;                                         
13 : decimal  $0A base ! ;                                         
14                                                                 
15                                                                 
Screen 58 not modified     
 0 \ number conversion: digit?                    16May86   18Nov87
 1                                                                 
 2 Code digit?    ( char -- n true : false )                       
 3    user' base D lxi   UP lhld   D dad                           
 4    D pop   E A mov   Ascii 0 sui   no jc                        
 5    $0A cpi   cs not ?[ Ascii A Ascii 0 - cpi   no jc            
 6                       Ascii A Ascii 9 - 1- sui  ]?              
 7    M cmp   no jnc                                               
 8    0 H mvi   A L mov   H push   yes jmp   end-code              
 9                                                                 
10 \\                                                              
11 : digit? ( char -- digit true/ false )  dup Ascii 9 >           
12    IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN 
13    Ascii 0 - dup base @ u< dup ?exit nip ;                      
14                                                                 
15                                                                 
Screen 59 not modified     
 0 \ number conversion:  accumulate  convert                11Jun86
 1                                                                 
 2 | : end?   ( -- flag )                   >in @ 0= ;             
 3 | : char   ( addr0 -- addr1 char )       count -1 >in +! ;      
 4 | : previous   ( addr0 -- addr0 char )   1- count ;             
 5                                                                 
 6 : accumulate ( +d0 adr digit - +d1 adr )                        
 7    swap >r swap  base @  um* drop rot  base @  um* d+ r> ;      
 8                                                                 
 9 : convert ( +d1 addr0 -- +d2 addr2 )                            
10    1+ BEGIN count digit? WHILE accumulate REPEAT 1- ;           
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 60 not modified     
 0 \ number conversion: ?nonum punctuation?                 07Oct87
 1                                                                 
 2 | : ?nonum    ( flag -- exit if true ) 0=exit                   
 3       rdrop 2drop drop rdrop false ;                            
 4                                                                 
 5 | : punctuation?   ( char -- flag )                             
 6      Ascii , over =  swap  Ascii . =  or ;                      
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 61 not modified     
 0 \ number conversion: fixbase?                            07Oct87
 1                                                                 
 2 | : fixbase?  ( char - char false / newbase true )  capital     
 3    Ascii & case? IF $0A true exit  THEN                         
 4    Ascii $ case? IF $10 true exit  THEN                         
 5    Ascii H case? IF $10 true exit  THEN                         
 6    Ascii % case? IF   2 true exit  THEN     false ;             
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 62 not modified     
 0 \ number conversion: ?num ?dpl                           07Oct87
 1                                                                 
 2 Variable dpl      -1 dpl !                                      
 3                                                                 
 4 | : ?num      ( flag -- exit if true )  0=exit                  
 5       rdrop drop r> IF dnegate THEN                             
 6       rot drop dpl @ 1+ ?dup ?exit  drop true ;                 
 7                                                                 
 8 | : ?dpl     dpl @  -1 =  ?exit  1 dpl +! ;                     
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 63 not modified     
 0 \ number conversion: number?  number                     11Jun86
 1                                                                 
 2 : number?   ( string - string false / n 0< / d 0> )             
 3    base push  >in push  dup count >in !  dpl on                 
 4    0 >r ( +sign) 0.0 rot end? ?nonum char                       
 5    Ascii - case?  IF  rdrop true >r end? ?nonum char  THEN      
 6    fixbase?       IF  base !        end? ?nonum char  THEN      
 7    BEGIN digit? 0= ?nonum                                       
 8      BEGIN accumulate ?dpl end? ?num char digit? 0=  UNTIL      
 9      previous  punctuation?  0= ?nonum  dpl off  end? ?num  char
10    REPEAT ;                                                     
11                                                                 
12 : number ( string -- d )                                        
13    number? ?dup 0= Abort" ?"  0< IF extend THEN ;               
14                                                                 
15                                                                 
Screen 64 not modified     
 0 \ hide reveal immediate restrict                         11Jun86
 1                                                                 
 2 Variable last     0 last !                                      
 3 | : last?   ( -- false / acf true)    last @ ?dup ;             
 4 : hide          last?  IF  2- @ current @ !  THEN ;             
 5 : reveal        last?  IF  2-   current @ !  THEN ;             
 6 : Recursive     reveal ; immediate restrict                     
 7                                                                 
 8 | : flag!    ( 8b --)                                           
 9       last?  IF  under c@ or over c!  THEN   drop  ;            
10                                                                 
11 : immediate     $40 flag! ;                                     
12 : restrict      $80 flag! ;                                     
13                                                                 
14                                                                 
15                                                                 
Screen 65 not modified     
 0 \ clearstack hallot heap heap?                           04Sep86
 1                                                                 
 2 Code clearstack                                                 
 3    user' s0 D lxi   UP lhld   D dad   M E mov   H inx   M D mov 
 4    xchg   sphl   Next   end-code                                
 5                                                                 
 6 : hallot ( quan -- )                                            
 7    s0 @  over -  swap    sp@ 2+  dup rot -   dup s0 !           
 8    2 pick  over -    di  move  clearstack  ei   s0 ! ;          
 9                                                                 
10 : heap    ( -- addr )        s0 @ 6 + ;                         
11 : heap?   ( addr -- flag )   heap up@ uwithin ;                 
12                                                                 
13 | : heapmove   ( from -- from )                                 
14      dup  here over -  dup hallot                               
15      heap swap cmove   heap over - last +!  reveal ;            
Screen 66 not modified     
 0 \ Does>  ;                                     11Jun86   20Nov87
 1                                                                 
 2 Label (dodoes>                                                  
 3    IP rpush   IP pop   W inx   W push   Next   end-code         
 4                                                                 
 5 : (;code          r> last @ name> ! ;                           
 6                                                                 
 7 : Does>                                                         
 8    compile (;code      $CD ( 8080-Call ) c,                     
 9    compile (dodoes> ; immediate restrict                        
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 67 not modified     
 0 \ ?head  |  alignments                         20Oct86   18Nov87
 1                                                                 
 2 Variable ?head     0 ?head !                                    
 3                                                                 
 4 : |                ?head @  ?exit  -1 ?head ! ;                 
 5                                                                 
 6 \ machen nichts beim 8080:                                      
 7 : even   ( addr -- addr1 ) ; immediate                          
 8 : align  ( -- )            ; immediate                          
 9 : halign ( -- )            ; immediate                          
10                                                                 
11 Variable warning    0 warning !                                 
12                                                                 
13 | : exists?         warning @  ?exit  last @ current @          
14    (find nip 0=exit  space last @ .name ." exists " ?cr ;       
15                                                                 
Screen 68 not modified     
 0 \ warning   Create                             20Oct86   18Nov87
 1                                                                 
 2 Defer makeview          ' 0 Is makeview                         
 3                                                                 
 4 : (create ( string -- ) align here                              
 5     swap count $1F and here 4+ place makeview ,  current @ @ ,  
 6     here last !  here c@ 1+ allot  align  exists?               
 7     ?head @ IF  1 ?head +!   dup ,    \ Pointer to Code         
 8                 halign  heapmove  $20 flag!  dup dp !           
 9             THEN drop  reveal 0 ,                               
10     ;Code   W inx   W push   Next   end-code                    
11                                                                 
12 : Create   name count 1 $20 uwithin not                         
13            Abort" invalid name" 1- (create ;                    
14                                                                 
15                                                                 
Screen 69 not modified     
 0 \ nfa?                                                   30Jun86
 1                                                                 
 2 Code nfa? ( thread cfa -- nfa / false )                         
 3    D pop   H pop                                                
 4    [[ M A mov   H inx   M H mov   A L mov                       
 5      H ora   Hpush jz   H push   H inx   H inx   H push   D push
 6      M A mov   H inx   $1F ani   A E mov   0 D mvi  D dad       
 7      D pop xthl  M A mov   H pop   $20 ani                      
 8      0<> ?[ M A mov   H inx   M H mov   A L mov ]?              
 9      H A mov   D cmp   0= ?[ L A mov  E cmp ]?                  
10      H pop   0= ?]   H inx  H inx  Hpush jmp                    
11 end-code                                                        
12 \\                                                              
13 : nfa?    ( thread cfa -- nfa / false)                          
14    >r  BEGIN @ dup 0= IF  rdrop exit  THEN  dup 2+ name> r@ =   
15        UNTIL 2+ rdrop ;                                         
Screen 70 not modified     
 0 \ >name name> >body .name                      30Jun86   07Oct87
 1                                                                 
 2 : >name   ( cfa -- nfa / false )        voc-link                
 3    BEGIN @ dup WHILE  2dup 4 - swap nfa?                        
 4       ?dup IF  -rot 2drop exit  THEN   REPEAT nip ;             
 5                                                                 
 6 Code (name>  ( nfa -- cfa )  H pop   M A mov   H inx   $1F ani  
 7    A E mov   0 D mvi   D dad   hpush jmp   end-code             
 8 \ : (name>   ( nfa -- cfa )   count  $1F and + ;                
 9                                                                 
10 : name> ( nfa -- cfa )  dup (name> swap  c@ $20 and  IF @ THEN ;
11                                                                 
12 : >body ( cfa -- pfa )  2+ ;    : body> ( pfa -- cfa )  2- ;    
13                                                                 
14 : .name   ( nfa -- ) ?dup  IF  dup heap?  IF ." |" THEN         
15     count $1F and type  ELSE ." ???"  THEN space ;              
Screen 71 not modified     
 0 \ : ; Constant Variable                                  07Nov87
 1                                                                 
 2 : Create:  Create  hide  current @ context !  0 ] ;             
 3                                                                 
 4 : : Create: ;Code  IP rpush   W inx   W IP mvx   Next end-code  
 5                                                                 
 6 : ;        0 ?pairs   compile unnest   [compile] [   reveal ;   
 7            immediate restrict                                   
 8                                                                 
 9 : Constant ( n -- )   Create , ;Code                            
10    W inx   xchg   M E mov   H inx   M D mov   D push   Next     
11    end-code                                                     
12                                                                 
13 : Variable         Create 0 , ;                                 
14                                                                 
15                                                                 
Screen 72 not modified     
 0 \ uallot User Alias Defer                      11Jun86   18Nov87
 1 : uallot   ( quan -- offset )   even  dup  udp @ +              
 2     $FF u> Abort" Userarea full" udp @ swap udp +! ;            
 3                                                                 
 4 : User   Create 2 uallot c,                                     
 5    ;Code W inx   W ldax   A E mov   0 D mvi                     
 6          UP lhld   D dad   hpush jmp   end-code                 
 7                                                                 
 8 : Alias ( cfa -- )   Create  last  @ dup c@ $20 and             
 9    IF  -2 allot  ELSE  $20 flag!  THEN (name> ! ;               
10                                                                 
11 | : crash           true Abort" crash" ;                        
12                                                                 
13 : Defer   Create ['] crash ,                                    
14     ;Code W inx   xchg   M E mov   H inx   M D mov              
15           xchg   >next1 jmp   end-code                          
Screen 73 not modified     
 0 \ vp current context also toss                           11Jun86
 1                                                                 
 2 Create vp  $10 allot             Variable current               
 3                                                                 
 4 : context   ( -- adr )              vp dup @ + 2+ ;             
 5                                                                 
 6 | : thru.vocstack ( -- from to )    vp 2+ context ;             
 7 \ "Only Forth also Assembler" gives                             
 8 \ vp:  countword = 6 | Only | Forth | Assembler |               
 9                                                                 
10 : also          vp @ $0A > Error" Vocabulary stack full"        
11                 context @  2 vp +! context ! ;                  
12 : toss          vp @ IF  -2 vp +!  THEN  ;                      
13                                                                 
14                                                                 
15                                                                 
Screen 74 not modified     
 0 \ Vocabulary Forth Only Onlyforth              24Nov85   18Nov87
 1                                                                 
 2 : Vocabulary                                                    
 3 Create   0 , 0 ,  here  voc-link @ ,  voc-link !                
 4  Does>   context ! ;                                            
 5 \  | Name | Code | Thread | Coldthread | Voc-link |             
 6                                                                 
 7 Vocabulary Forth                                                
 8 Vocabulary Root                                                 
 9                                                                 
10 : Only   vp off   Root also ;                                   
11                                                                 
12 : Onlyforth Only Forth also definitions ;                       
13                                                                 
14                                                                 
15                                                                 
Screen 75 not modified     
 0 \ definitions order words                      10Oct87   20Nov87
 1                                                                 
 2 | : init-vocabularys        voc-link @                          
 3      BEGIN  dup 2- @ over 4- ! @ ?dup 0= UNTIL ;                
 4                                                                 
 5 : definitions            context @ current ! ;                  
 6                                                                 
 7 | : .voc   ( adr -- )    @ 2- >name .name ;                     
 8                                                                 
 9 : order    vp 4+ context DO I .voc -2 +LOOP                     
10            2 spaces current .voc ;                              
11                                                                 
12 : words          context @                                      
13    BEGIN   @ dup stop? 0= and                                   
14    WHILE   ?cr dup 2+ .name space                               
15    REPEAT  drop ;                                               
Screen 76 not modified     
 0 \ found -text                                            11Jun86
 1 | : found ( nfa -- cfa n )                                      
 2    dup c@ >r   (name> r@ $20 and  IF  @       THEN              
 3                    -1 r@ $80 and  IF  1-      THEN              
 4                       r> $40 and  IF  negate  THEN  ;           
 5                                                                 
 6 \\                                                              
 7 : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1<str2)
 8     over bounds DO   drop 1+ dup 1- c@ I c@ - dup               
 9                    IF dup abs / LEAVE THEN LOOP nip ;           
10 | Variable string        | Variable strlen                      
11 : (find    ( string thread -- str false/NFA true )              
12    >r count $1F and  strlen ! string !                          
13    BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ =    
14     IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN
15       THEN drop   REPEAT  string @ 1- false ;                   
Screen 77 not modified     
 0 \ (find                                                  11Jun86
 1                                                                 
 2 Code (find   ( str thr - str false/ NFA true )                  
 3    H pop   D pop   IP push   D ldax   $1F ani   A C mov   D inx 
 4 Label findloop                                                  
 5    M A mov   H inx   M H mov  A L mov                           
 6    H A mov   L ora   0= ?[  IP pop  D dcx   D push   no jmp ]?  
 7    H push   H inx   H inx   M A mov   $1F ani   C cmp           
 8    0<>   ?[   H pop   findloop jmp   ]?                         
 9    D push   H inx   C B mov   B inr                             
10    [[ B dcr   0<>  ?[[                                          
11       D ldax   M cmp   0<>   ?[ D pop  H pop   findloop jmp ]?  
12       H inx   D inx   ]]?                                       
13    D pop   H pop   H inx   H inx   IP pop   H push   yes jmp    
14 end-code                                                        
15 \\  HL: thread, nfa   DE: string   C: strlen   B: counter       
Screen 78 not modified     
 0 \ find  '  [compile]  [']  nullstring?                   18Nov87
 1                                                                 
 2 : find    ( string -- cfa n / string false )                    
 3    context dup @ over  2- @ = IF  2-  THEN                      
 4    BEGIN  under @ (find  IF  nip found  exit  THEN              
 5      over vp 2+  u> WHILE  swap 2-  REPEAT  nip false ;         
 6                                                                 
 7 : '    ( -- cfa )      name find ?exit Error" ?" ;              
 8                                                                 
 9 : [compile]            ' , ;                 immediate restrict 
10                                                                 
11 : [']                  ' [compile] Literal ; immediate restrict 
12                                                                 
13 : nullstring?   ( string -- string false / true )               
14    dup c@  0= dup 0=exit  nip ;                                 
15                                                                 
Screen 79 not modified     
 0 \ notfound                                     17Oct86UH 25Jan88
 1                                                                 
 2 : no.extensions  ( string -- )                                  
 3     state @ IF Abort" ?" THEN  Error" ?" ;                      
 4                                                                 
 5 Defer notfound                  ' no.extensions Is notfound     
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 80 not modified     
 0 \ interpret interpreter compiler parser               UH 25Jan88
 1 Defer parser                                                    
 2                                                                 
 3 : interpret ( -- )                                              
 4     BEGIN  ?stack  name  nullstring? ?exit  parser REPEAT ;     
 5                                                                 
 6 | : interpreter ( str -- ) find ?dup                            
 7      IF  1 and  IF execute  exit THEN Error" compile only" THEN 
 8      number? ?exit   notfound ;                                 
 9                                                                 
10 ' interpreter Is parser                                         
11                                                                 
12 | : compiler ( str -- ) find  ?dup                              
13      IF  0> IF  execute exit THEN , exit THEN                   
14      number? ?dup IF 0> IF swap [compile] Literal THEN          
15                      [compile] Literal exit THEN  notfound ;    
Screen 81 not modified     
 0 \ [ ]                                                 UH 25Jan88
 1                                                                 
 2 : [      ['] interpreter Is Parser  state off ; immediate       
 3                                                                 
 4 : ]      ['] compiler    Is Parser  state on ;                  
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 82 not modified     
 0 \  Is                                          09May86UH 25Jan88
 1                                                                 
 2 : (is      r> dup 2+ >r @ ! ;                                   
 3                                                                 
 4 | : def?  ( cfa -- )                                            
 5      @  [ ' notfound @ ] Literal  - Abort" not deferred" ;      
 6                                                                 
 7 : Is   ( adr -- )     ' dup def? >body                          
 8    state @ IF  compile (is , exit  THEN  ! ; immediate          
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 83 not modified     
 0 \ ?stack                                                 30Jun86
 1 | : stackfull ( -- )     depth $20 > Abort" tight stack"        
 2     reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN
 3     true Abort" Dictionary full" ;                              
 4                                                                 
 5 Code ?stack                                                     
 6    UP lhld   user' dp D lxi   D dad   M E mov   H inx   M D mov 
 7    0 H lxi  SP dad   L A mov   E sub   H A mov   D sbb          
 8    0= ?[ ;c: stackfull ; Assembler ]?    H push                 
 9    UP lhld   user' s0 D lxi   D dad   M E mov   H inx   M D mov 
10    H pop    D A mov   H cmp  c0= ?[ 0= ?[ E A mov  L cmp ]? ]?  
11    >next jnc  ;c: true abort" Stack empty" ;                    
12 \\                                                              
13 : ?stack     sp@ here - 100 u< IF stackfull THEN                
14                 sp@ s0 @ u> Abort" Stack empty" ;               
15                                                                 
Screen 84 not modified     
 0 \ .status push load                                      20Oct86
 1                                                                 
 2 Defer .status   ' noop Is .status                               
 3                                                                 
 4 | Create: pull  r> r> ! ;                                       
 5                                                                 
 6 : push   ( addr -- )   r> swap dup >r @ >r pull >r >r ;         
 7                        restrict                                 
 8                                                                 
 9 : (load  ( blk offset -- )                                      
10    isfile push  loadfile push  fromfile push  blk push >in push 
11    >in !  blk !  isfile@ loadfile !  .status  interpret ;       
12                                                                 
13 : load   ( blk --)     ?dup 0=exit  0 (load ;                   
14                                                                 
15                                                                 
Screen 85 not modified     
 0 \ +load thru +thru --> rdepth depth                      20Oct86
 1                                                                 
 2 : +load    ( offset --)       blk @ + load ;                    
 3                                                                 
 4 : thru     ( from to --)      1+ swap DO I  load LOOP ;         
 5 : +thru    ( off0 off1 --)    1+ swap DO I +load LOOP ;         
 6                                                                 
 7 : -->        1 blk +! >in off .status ; immediate               
 8                                                                 
 9 : rdepth   ( -- +n)           r0 @ rp@ 2+   - 2/ ;              
10 : depth    ( -- +n)           sp@ s0 @ swap - 2/ ;              
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 86 not modified     
 0 \ quit (quit abort                                    UH 25Jan88
 1                                                                 
 2 : (prompt ( -- )                                                
 3     state @ IF cr ." ] " ELSE ."  ok" cr THEN .status ;         
 4                                                                 
 5 Defer prompt    ' (prompt Is prompt                             
 6                                                                 
 7 : (quit       BEGIN prompt query interpret REPEAT ;             
 8                                                                 
 9 Defer 'quit     ' (quit Is 'quit                                
10 : quit   r0 @ rp!  level off  [compile] [ 'quit ;               
11                                                                 
12 : standardi/o     [ output ] Literal output 4 cmove ;           
13                                                                 
14 Defer 'abort   ' noop Is 'abort                                 
15 : abort      end-trace clearstack 'abort standardi/o quit ;     
Screen 87 not modified     
 0 \ (error Abort" Error"                         20Oct86   18Nov87
 1                                                                 
 2 Variable scr    1 scr !       Variable r#    0 r# !             
 3                                                                 
 4 : (error ( string -- )     standardi/o space here .name         
 5     count type space ?cr                                        
 6     blk @ ?dup IF scr ! >in @ r# ! THEN quit ;                  
 7 ' (error errorhandler !                                         
 8                                                                 
 9 : (abort"     "lit swap IF >r clearstack r>                     
10               errorhandler perform exit THEN drop ; restrict    
11                                                                 
12 | : (err"      "lit swap IF errorhandler perform exit THEN      
13                drop ; restrict                                  
14 : Abort"       compile (abort" ,"  align  ; immediate restrict  
15 : Error"       compile (err"   ,"  align  ; immediate restrict  
Screen 88 not modified     
 0 \ -trailing                                    30Jun86   18Nov87
 1                                                                 
 2 Code -trailing   ( addr n1 -- addr n2 )                         
 3    D pop   H pop   H push                                       
 4    D dad   xchg   D dcx                                         
 5 Label -trail   H A mov   L ora    hpush jz                      
 6    D ldax   BL cpi   hpush jnz                                  
 7    H dcx   D dcx   -trail jmp end-code                          
 8                                                                 
 9 \\                                                              
10 : -trailing ( addr n1 -- addr n2)                               
11     2dup bounds ?DO  2dup + 1- c@ bl - IF LEAVE THEN  1-  LOOP ;
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 89 not modified     
 0 \ space spaces                                           30Jun86
 1                                                                 
 2 $20 Constant bl                                                 
 3                                                                 
 4 : space                      bl emit ;                          
 5 : spaces   ( u --)           0 ?DO space LOOP ;                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 90 not modified     
 0 \ hold <# #> sign # #s                                   17Oct86
 1                                                                 
 2 | : hld   ( -- addr)            pad 2- ;                        
 3                                                                 
 4 : hold    ( char -- )           -1 hld +! hld @ c! ;            
 5                                                                 
 6 : <#                            hld hld ! ;                     
 7                                                                 
 8 : #>      ( 32b -- addr +n )    2drop hld @ hld over - ;        
 9                                                                 
10 : sign    ( n -- )              0< IF Ascii - hold THEN ;       
11                                                                 
12 : #       ( +d1 -- +d2)         base @ ud/mod rot 9 over <      
13    IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ;  
14                                                                 
15 : #s      ( +d -- 0 0 )         BEGIN # 2dup d0= UNTIL ;        
Screen 91 not modified     
 0 \ print numbers                                          24Dec83
 1                                                                 
 2 : d.r      -rot under dabs <# #s rot sign #>                    
 3            rot over max over - spaces type ;                    
 4                                                                 
 5 : .r       swap extend rot d.r ;                                
 6                                                                 
 7 : u.r      0 swap d.r ;                                         
 8                                                                 
 9 : d.       0 d.r space ;                                        
10                                                                 
11 : .        extend d. ;                                          
12                                                                 
13 : u.       0 d. ;                                               
14                                                                 
15                                                                 
Screen 92 not modified     
 0 \ .s list c/l l/s                                        05Oct87
 1                                                                 
 2 : .s    sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ;    
 3                                                                 
 4 $40 Constant c/l        \ Screen line length                    
 5 $10 Constant l/s        \ lines per screen                      
 6                                                                 
 7 : list ( blk -- )                                               
 8    scr ! ." Scr " scr @ u.                                      
 9    l/s 0 DO                                                     
10      cr I 2 .r space scr @ block I c/l * + c/l -trailing type   
11    LOOP cr ;                                                    
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 93 not modified     
 0 \ multitasker primitives                                 20Nov87
 1                                                                 
 2 Code end-trace    \ patch Next to its original state            
 3    $0A A mvi   ( IP ldax )          >next sta                   
 4    $6F03 H lxi ( IP inx   A L mov ) >next 1+ shld  Next end-code
 5                                                                 
 6 Code pause   >next here 2- !  end-code                          
 7                                                                 
 8 : lock ( addr -- )  dup @  up@  = IF  drop exit  THEN           
 9    BEGIN  dup  @ WHILE  pause  REPEAT  up@  swap  ! ;           
10                                                                 
11 : unlock ( addr -- )   dup lock off ;                           
12                                                                 
13 Label wake   H pop   H dcx   UP shld                            
14    6 D lxi   D dad   M A mov   H inx   M H mov  A L mov   sphl  
15    H pop   RP shld   IP pop   Next   end-code                   
Screen 94 not modified     
 0 \ buffer mechanism                             20Oct86   07Oct87
 1                                                                 
 2 User isfile          0 isfile !   \ addr of file control block  
 3 Variable fromfile    0 fromfile !                               
 4 Variable prev        0 prev !     \ Listhead                    
 5 | Variable buffers   0 buffers !  \ Semaphor                    
 6 $408 Constant b/buf               \ physikalische Groesse       
 7 $400 Constant b/blk                                             
 8 \\ Struktur eines Buffers:    0 : link                          
 9                               2 : file                          
10                               4 : blocknummer                   
11                               6 : statusflags                   
12                               8 : Data ... 1 Kb ...             
13 Statusflag bits : 15   1 -> updated                             
14 file :  -1 -> empty buffer,  0 -> no fcb, direct access         
15         else addr of fcb  ( system dependent )                  
Screen 95 not modified     
 0 \ search for blocks in memory                            30Jun86
 1 | Variable pred                                                 
 2 \ DE:blk  BC:file  HL:bufadr                                    
 3                                                                 
 4 Label thisbuffer?   ( Zero = this buffer )                      
 5    H push   H inx   H inx   M A mov   C cmp   0=                
 6    ?[ H inx   M A mov   B cmp   0= ?[ H inx   M A mov   E cmp   
 7       0= ?[ H inx   M A mov   D cmp ]? ]? ]?   H pop   ret      
 8                                                                 
 9 Code (core?  ( blk file -- adr\blk file )                       
10    IP H mvx   Ipsave shld                                       
11    user' offset D lxi   UP lhld   D dad                         
12    M E mov   H inx   M D mov                                    
13    B pop   H pop   H push   B push   D dad   xchg               
14    prev lhld                                                    
15    thisbuffer? call 0= ?[                                       
Screen 96 not modified     
 0 \ search for blocks in memory                            30Jun86
 1                                                                 
 2 Label blockfound                                                
 3    D pop   D pop   8 D lxi   D dad   H push   ' exit @ jmp ]?   
 4    [[ pred shld                                                 
 5       M A mov   H inx   M H mov   A L mov                       
 6       H ora 0= ?[ IPsave lhld   H IP mvx   Next ]?              
 7       thisbuffer? call   0= ?]                                  
 8       xchg   pred lhld   D ldax   A M mov                       
 9       H inx  D inx   D ldax   A M mov   D dcx                   
10       prev lhld    xchg    E M mov  H inx  D M mov              
11       H dcx   prev shld                                         
12    blockfound jmp   end-code                                    
13                                                                 
14                                                                 
15                                                                 
Screen 97 not modified     
 0 \ (core?                                                 29Jun86
 1 \\                                                              
 2                                                                 
 3 | : this? ( blk file bufadr -- flag )                           
 4      dup 4+ @  swap 2+ @  d= ;                                  
 5                                                                 
 6 | : (core? ( blk file -- dataaddr / blk file )                  
 7      BEGIN  over offset @ + over prev @ this?                   
 8         IF  rdrop 2drop prev @ 8 + exit  THEN                   
 9         2dup >r offset @ + >r prev @                            
10         BEGIN dup @ ?dup 0= IF  rdrop rdrop drop exit  THEN     
11               dup r> r> 2dup >r >r rot this?  0=                
12         WHILE nip REPEAT                                        
13         dup @ rot ! prev @ over ! prev ! rdrop rdrop            
14      REPEAT ;                                                   
15                                                                 
Screen 98 not modified     
 0 \ (diskerr                                     29Jul86   07Oct87
 1                                                                 
 2 : (diskerr                                                      
 3    ." error! r to retry "  key $FF and                          
 4    capital Ascii R = not Abort" aborted" ;                      
 5                                                                 
 6 Defer diskerr                                                   
 7 ' (diskerr Is diskerr                                           
 8                                                                 
 9 Defer r/w                                                       
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 99 not modified     
 0 \ backup emptybuf readblk                                20Oct86
 1                                                                 
 2 | : backup ( bufaddr -- )       dup 6+ @ 0<                     
 3      IF 2+ dup @ 1+         \ buffer empty if file = -1         
 4        IF input push output push standardi/o                    
 5          BEGIN  dup 6+ over 2+ @ 2 pick @ 0 r/w                 
 6          WHILE ." write " diskerr                               
 7          REPEAT  THEN  4+ dup @ $7FFF and over ! THEN  drop ;   
 8                                                                 
 9 : emptybuf ( bufaddr -- )      2+ dup on 4+ off ;               
10                                                                 
11 | : readblk ( blk file addr -- blk file addr )                  
12      dup emptybuf                                               
13      input push output push standardi/o >r                      
14      BEGIN  over offset @ + over r@ 8 + -rot 1 r/w              
15      WHILE  ." read " diskerr  REPEAT r>  ;                     
Screen 100 not modified     
 0 \ take mark updates? core?                     10Mar86   19Nov87
 1                                                                 
 2 | : take ( -- bufaddr)    prev                                  
 3      BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL                    
 4      buffers lock   dup backup ;                                
 5                                                                 
 6 | : mark ( blk file bufaddr -- blk file )                       
 7      2+ >r  2dup r@ !  offset @ + r@ 2+ !  r> 4+ off            
 8      buffers unlock ;                                           
 9                                                                 
10 | : updates? ( -- bufaddr / flag)                               
11      prev  BEGIN  @ dup  WHILE dup 6+ @ 0<  UNTIL ;             
12                                                                 
13 : core? ( blk file -- addr /false )   (core? 2drop false ;      
14                                                                 
15                                                                 
Screen 101 not modified     
 0 \ block & buffer manipulation                  20Oct86   18Nov87
 1                                                                 
 2 : (buffer ( blk file -- addr )                                  
 3     BEGIN  (core? take mark  REPEAT ;                           
 4                                                                 
 5 : (block ( blk file -- addr )                                   
 6     BEGIN  (core? take readblk mark  REPEAT ;                   
 7                                                                 
 8 Code isfile@ ( -- addr )  user' isfile  D lxi                   
 9    UP lhld   D dad   fetch jmp   end-code                       
10                                                                 
11 : buffer ( blk -- addr )   isfile@ (buffer ;                    
12                                                                 
13 : block  ( blk -- addr )   isfile@ (block ;                     
14                                                                 
15 \ : isfile@ ( -- addr )    isfile @ ;                           
Screen 102 not modified     
 0 \ block & buffer manipulation                            05Oct87
 1                                                                 
 2 : update          $80 prev @ 6+ 1+ ( Byte-Order! )  c! ;        
 3                                                                 
 4 Defer save-dos-buffers                                          
 5                                                                 
 6 : save-buffers ( -- )   buffers lock                            
 7    BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers     
 8    buffers unlock ;                                             
 9                                                                 
10 : empty-buffers ( -- )   buffers lock prev                      
11    BEGIN @ ?dup  WHILE dup emptybuf REPEAT  buffers unlock ;    
12                                                                 
13 : flush           save-buffers empty-buffers ;                  
14                                                                 
15                                                                 
Screen 103 not modified     
 0 \ Allocating buffers                                     10Oct87
 1 $10000 Constant limit            Variable first                 
 2                                                                 
 3 : allotbuffer ( -- )                                            
 4    first @  r0 @  -  b/buf 2+  u< ?exit                         
 5    b/buf negate first +!  first @ dup emptybuf                  
 6    prev @ over !  prev ! ;                                      
 7                                                                 
 8 : freebuffer ( -- )  first @ limit b/buf - u<                   
 9    IF first @  backup  prev                                     
10      BEGIN dup @  first @ -  WHILE  @  REPEAT                   
11    first @  @ swap !  b/buf first +!  THEN ;                    
12                                                                 
13 : all-buffers  BEGIN  first @ allotbuffer first @ =  UNTIL ;    
14                                                                 
15 | : init-buffers    prev off  limit first ! all-buffers ;       
Screen 104 not modified     
 0 \ endpoints of forget                                    01Jul86
 1                                                                 
 2 | : |? ( nfa -- flag )   c@ $20 and ;                           
 3 | : forget? ( adr nfa -- flag )   \ code in heap or above adr ? 
 4      name>  under  1+ u<  swap  heap?  or ;                     
 5                                                                 
 6 | : endpoints ( addr -- addr symb )                             
 7      heap voc-link @ >r                                         
 8      BEGIN   r> @ ?dup      \ through all Vocabs                
 9      WHILE dup >r 4- >r    \ link on returnstack                
10        BEGIN r> @ >r over 1- dup r@ u<      \ until link or     
11                    swap r@ 2+ name> u< and  \ code under adr    
12        WHILE r@ heap? [ 2dup ] UNTIL   \ search for name in heap
13        r@ 2+ |? IF over r@ 2+ forget?                           
14                IF r@ 2+ (name> 2+ umax THEN   \ then update symb
15        THEN REPEAT rdrop  REPEAT ;                              
Screen 105 not modified     
 0 \ remove, -words, -tasks                                 20Oct86
 1                                                                 
 2 : remove ( dic sym thread - dic sym )                           
 3      BEGIN dup @ ?dup      \ unlink forg. words                 
 4      WHILE dup heap?                                            
 5        IF  2 pick over u>  ELSE  3 pick over 1+ u<  THEN        
 6        IF  @ over ! ( unlink word)  ELSE nip THEN  REPEAT drop ;
 7                                                                 
 8 | : remove-words ( dic sym -- dic sym )                         
 9      voc-link BEGIN  @ ?dup                                     
10               WHILE  dup >r  4- remove  r> REPEAT ;             
11                                                                 
12 | : remove-tasks ( dic -- )       up@                           
13      BEGIN  2+  dup @  up@ -  WHILE  2dup @ swap here uwithin   
14             IF dup @ 2+ @  over ! 2-                            
15             ELSE @ THEN REPEAT 2drop ;                          
Screen 106 not modified     
 0 \ remove-vocs trim                             20Oct86   07Oct87
 1                                                                 
 2 | : remove-vocs ( dic symb -- dic symb )                        
 3      voc-link remove       thru.vocstack                        
 4      DO 2dup I @ -rot uwithin                                   
 5        IF  [ ' Forth 2+ ]  Literal I !  THEN  -2 +LOOP          
 6      2dup  current @  -rot  uwithin                             
 7      IF  [ ' Forth 2+ ] Literal current ! THEN ;                
 8                                                                 
 9 Defer custom-remove     ' noop Is custom-remove                 
10                                                                 
11 | : trim ( dic symb -- )                                        
12      over  remove-tasks remove-vocs remove-words                
13      custom-remove  heap swap - hallot dp ! 0 last ! ;          
14                                                                 
15                                                                 
Screen 107 not modified     
 0 \ deleting words from dict.                    01Jul86   18Nov87
 1                                                                 
 2 : clear        here  dup up@  trim  dp ! ;                      
 3                                                                 
 4 : (forget ( adr --)    dup heap? Abort" is symbol"              
 5                        endpoints  trim ;                        
 6                                                                 
 7 : forget   ' dup [ dp ] Literal @  u< Abort" protected"         
 8             >name  dup  heap?                                   
 9             IF name> ELSE 4- THEN (forget ;                     
10                                                                 
11 : empty   [ dp ] Literal @ up@ trim                             
12           [ udp ] Literal @ udp ! ;                             
13                                                                 
14                                                                 
15                                                                 
Screen 108 not modified     
 0 \ save bye stop? ?cr                                     18Nov87
 1                                                                 
 2 : save    here  up@ trim                                        
 3    voc-link @ BEGIN  dup 4- @ over 2- ! @ ?dup  0= UNTIL        
 4    up@ origin $100 cmove ;                                      
 5                                                                 
 6 : bye       flush empty (bye ;                                  
 7                                                                 
 8 | : end?    key #cr = IF true rdrop THEN ;                      
 9                                                                 
10 : stop? ( -- flag )     key? IF end? end? THEN false ;          
11                                                                 
12 : ?cr                   col c/l u> 0=exit cr ;                  
13                                                                 
14                                                                 
15                                                                 
Screen 109 not modified     
 0 \ in/output structure                                    07Jun86
 1                                                                 
 2 | : Out:   Create dup c, 2+ Does> c@ output @ + perform ;       
 3                                                                 
 4 : Output:  Create:  Does> output ! ;                            
 5 0   Out: emit   Out: cr   Out: type   Out: del                  
 6     Out: page   Out: at   Out: at?    drop                      
 7                                                                 
 8 : row ( -- row)     at? drop ;                                  
 9 : col ( -- col)     at? nip ;                                   
10                                                                 
11 | : In:    Create dup c, 2+ Does> c@ input @ + perform ;        
12                                                                 
13 : Input:   Create:  Does> input ! ;                             
14 0   In: key   In: key?   In: decode   In: expect  drop          
15                                                                 
Screen 110 not modified     
 0 \ Alias  only definitionen                               18Nov87
 1                                                                 
 2 Root definitions Forth                                          
 3                                                                 
 4 : seal  [ ' Root >body ] Literal off ; \ "erase" Root Vocab.    
 5                                                                 
 6 ' Only        Alias Only                                        
 7 ' Forth       Alias Forth                                       
 8 ' words       Alias words                                       
 9 ' also        Alias also                                        
10 ' definitions Alias definitions                                 
11                                                                 
12 Host Target                                                     
13                                                                 
14                                                                 
15                                                                 
Screen 111 not modified     
 0 \ 'restart 'cold                               22Oct86   10Oct87
 1                                                                 
 2 Defer 'restart  ' noop Is 'restart                              
 3                                                                 
 4 | : (restart   ['] (quit Is 'quit drvinit 'restart              
 5      [ errorhandler ] Literal @ errorhandler !                  
 6      ['] noop Is 'abort clearstack                              
 7      standardi/o interpret quit ;                               
 8                                                                 
 9 Defer 'cold    ' noop Is 'cold                                  
10                                                                 
11 | : (cold      origin up@ $100 cmove  $80 count                 
12      $50 umin >r tib r@ move r> #tib ! >in off  blk off         
13      init-vocabularys init-buffers  flush  'cold                
14      Onlyforth page &24 spaces  logo count type cr (restart  ;  
15                                                                 
Screen 112 not modified     
 0 \ cold bootsystem                                        20Oct86
 1                                                                 
 2 Code cold   here >cold !                                        
 3    s0 lhld   6 D lxi   D dad   origin D lxi   $3F C mvi         
 4    [[ D ldax   A M mov  H inx   D inx   C dcr   0= ?]           
 5    ' (cold >body IP lxi                                         
 6 Label bootsystem                                                
 7    s0 lhld   6 D lxi   D dad   UP shld                          
 8    user' s0  D lxi   D dad                                      
 9    M E mov   H inx   M D mov   xchg   sphl                      
10    user' r0 D lxi    UP lhld    D dad                           
11    M E mov   H inx   M D mov    xchg   RP shld                  
12    $C3 ( jmp ) A mvi  $30 sta   wake H lxi  $31 shld ( Tasker ) 
13    Next                                                         
14 end-code                                                        
15                                                                 
Screen 113 not modified     
 0 \ restart boot                                           20Oct86
 1                                                                 
 2 Code restart      here >restart !                               
 3    ' (restart >body IP lxi   bootsystem jmp   end-code          
 4                                                                 
 5 Label boot     here >boot !    \ find link to Main:             
 6    s0 lhld   6 D lxi   D dad   H B mvx    origin D lxi          
 7    [[ [[ xchg   H inx   H inx   M E mov   H inx   M D mov       
 8          D A mov   B cmp 0= ?]   E A mov   C cmp 0= ?]   H B mvx
 9    6 lhld   0 L mvi   ' limit >body shld                        
10   -$1100 D lxi   D dad   r0 shld   \ set initial RP             
11    -$400 D lxi   D dad   s0 shld   \ set initial SP             
12        6 D lxi   D dad   xchg   B H mvx                         
13        D M mov   H dcx   E M mov   \ set link to Maintask       
14   >cold 2- jmp                                                  
15 end-code                                                        
Screen 114 not modified     
 0 \ "search                                                05Mar88
 1                                                                 
 2 Label notfound      H pop   H pop                               
 3    IPsave lhld   H IP mvx   False H lxi   hpush jmp             
 4                                                                 
 5 Code "search ( text tlen buf blen -- addr tf / ff )             
 6    IP H mvx  IPsave shld   D pop    H pop    xthl               
 7    H A mov   L ora  notfound jz                                 
 8    E A mov  L sub  A C mov   D A mov  H sbb  A B mov notfound jc
 9    B inx   D pop   xthl   M A mov  xthl  H push   xchg          
10 Label scanfirst                                                 
11    A E mov  ?capital call  E D mov                              
12    [[  M E mov   H inx   B A mov  C ora   notfound jz   B dcx   
13        ?capital call  E A mov  D cmp  0=  ?]                    
14    B D mvx   B pop   xchg   xthl   xchg   H push  B push  D push
15                                                                 
Screen 115 not modified     
 0 \ "search  part 2                                        27Nov87
 1                                                                 
 2 Label match                                                     
 3    B dcx   B A mov  C ora  0<> ?[                               
 4    D inx   D ldax   D push   A E mov  ?capital call   E D mov   
 5    M E mov  H inx  ?capital call  E A mov   D cmp   D pop       
 6    match jz   H pop   B pop   D pop                             
 7    M A mov   xthl   B push   H B mvx  xchg  scanfirst jmp ]?    
 8    D pop   D pop   H pop   D pop  H dcx  H push                 
 9    IPsave lhld  H IP mvx  True H lxi  hpush jmp                 
10 end-code                                                        
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 116 not modified     
 0 \ Rest of Standard-System                      04Oct87   07Oct87
 1                                                                 
 2 2 +load  \ Operating System                                     
 3                                                                 
 4 Host    ' Transient 8 + @  Transient Forth Context @ 6 + !      
 5                                                                 
 6 Target Forth also definitions                                   
 7                                                                 
 8 Vocabulary Assembler  Assembler definitions                     
 9 Transient Assembler                                             
10 >Next Constant >Next                                            
11 hpush Constant hpush                                            
12 dpush Constant dpush                                            
13                                                                 
14 Target Forth also definitions                                   
15 : forth-83 ;     \ last word in Dictionary                      
Screen 117 not modified     
 0 \ System patchup                                         04Oct87
 1                                                                 
 2 $EF00  r0 !                                                     
 3 $EB00  s0 !                                                     
 4 s0 @ 6 +  origin 2+ !  \ link Maintask to itself                
 5                                                                 
 6 \ s0 und r0 werden beim Booten neu an die Speichergroesse       
 7 \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask      
 8                                                                 
 9 here dp !                                                       
10                                                                 
11 Host  Tudp @       Target  udp !                                
12 Host  Tvoc-link @  Target  voc-link !                           
13 Host move-threads                                               
14                                                                 
15                                                                 
Screen 118 not modified     
 0 \ System dependent Load-Screen                           20Nov87
 1                                                                 
 2 1   +load \ CP/M interface                                      
 3                                                                 
 4 2 4 +thru \ Character IO                                        
 5                                                                 
 6 5 7 +thru \ Default Disk IO                                     
 7                                                                 
 8 8   +load \ Postlude                                            
 9                                                                 
10 \ 9   +load \ Index                                             
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 119 not modified     
 0 \ CP/M-Interface                                         05Oct87
 1 Vocabulary Dos    Dos definitions  also                         
 2 Label >bios   pchl                                              
 3 Code biosa ( arg fun -- res )                                   
 4    1 lhld   D pop   D dcx   D dad   D dad   D dad               
 5    D pop   IP push   D IP mvx   >bios call                      
 6 Label back                                                      
 7    IP pop   0 H mvi   A L mov   Hpush jmp   end-code            
 8                                                                 
 9 Code bdosa ( arg fun -- res )                                   
10    H pop   D pop   IP push   L C mov   5 call  back jmp         
11 end-code                                                        
12                                                                 
13 : bios ( arg fun -- ) biosa drop ;                              
14 : bdos ( arg fun -- ) bdosa drop ;                              
15                                                                 
Screen 120 not modified     
 0 \ Character-IO Constants  Character input                05Oct87
 1                                                                 
 2 Target Dos also                                                 
 3                                                                 
 4 $08 Constant #bs         $0D Constant #cr                       
 5 $0A Constant #lf         $1B Constant #esc                      
 6 $09 Constant #tab        $7F Constant #del                      
 7 $07 Constant #bel        $0C Constant #ff                       
 8                                                                 
 9 : con!   ( c -- )     4 bios ;                                  
10 : (key?  ( -- ? )   0 2 biosa 0= not ;                          
11 : getkey ( -- c )   0 3 biosa ;                                 
12                                                                 
13 : (key   ( -- c )   BEGIN  pause (key?  UNTIL getkey ;          
14                                                                 
15                                                                 
Screen 121 not modified     
 0 \ Character output                           07Oct87  UH 27Feb88
 1                                                                 
 2 | Code ?ctrl ( c -- c' )  H pop   L A mov                       
 3     $20 cpi  cs ?[ $80 ori ]?   A L mov   Hpush jmp   end-code  
 4                                                                 
 5 : (emit ( c -- )  ?ctrl  con!  pause ;                          
 6                                                                 
 7 : (cr     #cr con!  #lf con! ;                                  
 8 : (del    #bs con!  bl  con!  #bs con! ;                        
 9 : (at? ( -- row col )  0 0 ;                                    
10                                                                 
11 : tipp ( addr len -- )   0 ?DO count emit LOOP drop ;           
12                                                                 
13 Output: display    [ here output ! ]                            
14    (emit (cr tipp (del noop 2drop (at? ;                        
15                                                                 
Screen 122 not modified     
 0 \ Line input                                             04Oct87
 1                                                                 
 2 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ;   
 3                                                                 
 4 : (decode ( addr pos1 key -- addr pos2 )                        
 5      #bs  case? IF backspace         exit THEN                  
 6      #del case? IF backspace         exit THEN                  
 7      #cr  case? IF dup span !  space exit THEN                  
 8      dup emit >r  2dup +  r> swap c!  1+ ;                      
 9                                                                 
10 : (expect   ( addr len -- )  span ! 0                           
11     BEGIN  span @ over u>  WHILE  key decode  REPEAT  2drop ;   
12                                                                 
13 Input:  keyboard    [ here input ! ]                            
14      (key  (key?  (decode  (expect ;                            
15                                                                 
Screen 123 not modified     
 0 \ Default Disk Interface: Constants and Primitives       18Nov87
 1                                                                 
 2  $80 Constant b/rec              b/blk b/rec / Constant rec/blk 
 3                                                                 
 4 Dos definitions                                                 
 5 ' 2- | Alias dosfcb>         ' 2+ | Alias >dosfcb               
 6                                                                 
 7 : dos-error? ( n -- f )   $FF = ;                               
 8                                                                 
 9 $5C Constant fcb                                                
10 : reset     (   --     )  0 &13 bdos ;                          
11 : openfile  ( fcb -- f )    &15 bdosa dos-error? ;              
12 : closefile ( fcb -- f )    &16 bdosa dos-error? ;              
13 : dma!      ( dma --   )    &26 bdos  ;                         
14 : rec@      ( fcb -- f )    &33 bdosa ;                         
15 : rec!      ( fcb -- f )    &34 bdosa ;                         
Screen 124 not modified     
 0 \ Default Disk Interface: open and close                 20Nov87
 1                                                                 
 2 Target Dos also     Defer drvinit       Dos definitions         
 3                                                                 
 4 | Variable  opened                                              
 5 : default  ( -- )  opened off                                   
 6    fcb 1+ c@ bl = ?exit   $80 count here place   #tib off       
 7    fcb dup  dosfcb> dup  isfile ! fromfile !                    
 8    openfile Abort" default file not found!"  opened on  ;       
 9 ' default Is drvinit                                            
10                                                                 
11 : close-default ( -- ) opened @ not ?exit                       
12     fcb closefile Abort" can't close default-file!" ;           
13 ' close-default Is save-dos-buffers                             
14                                                                 
15                                                                 
Screen 125 not modified     
 0 \ Default Disk Interface: read/write                     14Feb88
 1                                                                 
 2 Target Dos also                                                 
 3                                                                 
 4 | : rec# ( 'dosfcb -- 'rec# )  &33 + ;                          
 5                                                                 
 6 : (r/w  ( adr blk file r/wf -- flag )  >r                       
 7     dup 0= Abort" no Direct Disk IO supported! " >dosfcb        
 8     swap rec/blk *  over rec#   0 over 2+ c!   !                
 9     r> rot  b/blk bounds                                        
10     DO I dma!  2dup IF rec@ drop                                
11        ELSE rec! IF 2drop true endloop exit THEN THEN           
12        over rec#   0 over 2+ c!  1 swap +!                      
13     b/rec +LOOP  2drop false ;                                  
14                                                                 
15 ' (r/w Is r/w                                                   
Screen 126 not modified     
 0 \ Postlude                                               20Nov87
 1                                                                 
 2 Defer postlude                                                  
 3                                                                 
 4 | : (bye ( -- )   postlude 0 0 bdos ;                           
 5                                                                 
 6 | : #pages ( -- n ) here $100 -  $100 u/mod swap 0=exit 1+ ;    
 7                                                                 
 8 : .size ( -- ) base push  decimal                               
 9      cr ." Size: &" #pages u. ." Pages" ;                       
10                                                                 
11 ' .size Is postlude                                             
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 127 not modified     
 0 \  index findex                                          20Nov87
 1                                                                 
 2 | : range  ( from to -- to+1 from )                             
 3      2dup > IF swap THEN 1+ swap ;                              
 4                                                                 
 5 : index ( from to --)                                           
 6    range DO  cr I 4 .r I space block  c/l type                  
 7              stop? IF LEAVE THEN LOOP ;                         
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
