Screen 0 not modified     
 0 \                                                    28 jun 88  
 1                                                                 
 2 DOS loads higher level file functions which go beyond           
 3 including a screen file. Calls to MS-DOS are implemented        
 4 and used for directory manipulation. These functions may        
 5 not work for versions before MS-DOS 3.0.                        
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 1 not modified     
 0 \ MS-DOS file handli                                 cas 09jun20
 1   Onlyforth   \needs Assembler   2 loadfrom asm.fb              
 2                                                                 
 3   : fswap      isfile@  fromfile @   isfile !  fromfile ! ;     
 4                                                                 
 5   $80 Constant dta                                              
 6                                                                 
 7 | : COMSPEC  ( -- string )   [ dos ]                            
 8      $2C @ ( DOS-environment:seg) 8   ds@ filename   &60 lmove  
 9      filename counted &60 min filename place  filename ;        
10                                                                 
11   1 &12 +thru   .( MS-DOS functions loaed ) cr                  
12                                                                 
13   Onlyforth                                                     
14                                                                 
15                                                                 
Screen 2 not modified     
 0 \ moving blocks                                   ks 04 okt 87  
 1                                                                 
 2 | : full? ( -- flag )  prev  BEGIN @ dup @ 0= UNTIL  6 + @ 0< ; 
 3                                                                 
 4   : used?  ( blk -- f )                                         
 5      block count b/blk 1- swap skip nip 0<> ;                   
 6                                                                 
 7 | : (copy   ( from to -- )                                      
 8      full? IF  save-buffers  THEN   isfile@ fromfile @ -        
 9      IF  dup used? Abort" target block not empty"  THEN         
10      dup isfile@ core? IF  prev @ emptybuf  THEN                
11      isfile@ 0= IF  offset @ +  THEN                            
12      isfile@ rot   fromfile @ (block 6 -   2! update ;          
13                                                                 
14                                                                 
15                                                                 
Screen 3 not modified     
 0 \ moving blocks                                   ks 04 okt 87  
 1                                                                 
 2 | : blkmove ( from to quan -- ) 3 arguments save-buffers        
 3      >r over r@ + over u> >r 2dup u< r> and                     
 4      IF    r@ r@ d+ r> 0 ?DO  -1 -2 d+   2dup (copy  LOOP       
 5      ELSE           r> 0 ?DO  2dup (copy     1 1 d+  LOOP       
 6      THEN  save-buffers 2drop ;                                 
 7                                                                 
 8   : copy    ( from to -- )         1 blkmove ;                  
 9                                                                 
10   : convey  ( blk1 blk2 to.blk -- )                             
11      3 arguments   >r   2dup swap - >r                          
12      fswap dup capacity 1- > isfile@ 0<> and                    
13      fswap r> r@ + capacity 1- > isfile@ 0<> and or >r          
14      1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ;  
15                                                                 
Screen 4 not modified     
 0 \ MORE  extending forth files                     ks 10 okt 87  
 1   Dos also definitions                                          
 2                                                                 
 3 | : addblock   ( blk -- )   dup buffer  dup b/blk blank         
 4      isfile@ f.size dup  2@ b/blk 0 d+  rot 2!                  
 5      swap isfile@ fblock! ;                                     
 6                                                                 
 7   Forth definitions                                             
 8                                                                 
 9   : more   ( n -- )  1 arguments  isfile@                       
10      IF  capacity swap bounds ?DO  I addblock  LOOP  close exit 
11      THEN  drop ;                                               
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 5 not modified     
 0 \ file  eof? create   dta-addressing              ks 03 apr 88  
 1   Dos definitions                                               
 2                                                                 
 3   : ftime  ( -- mm hh )                                         
 4      isfile@ f.time @ $20 u/mod nip $40 u/mod ;                 
 5                                                                 
 6   : fdate  ( -- dd mm yy )                                      
 7      isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;               
 8                                                                 
 9   : .when  base push decimal                                    
10      fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r                  
11      ftime 3 .r ." :" 2 .r ;                                    
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 6 not modified     
 0 \ ks 20mar88                                                    
 1                                                                 
 2   : (.fcb     ( fcb -- )                                        
 3      dup .file ?dup 0=exit  pushfile                            
 4      isfile !  &13 tab ." is"                                   
 5      isfile@ f.handle @ 2 .r                                    
 6      isfile@ f.size 2@ 7 d.r  .when                             
 7      space isfile@ f.name count type ;                          
 8                                                                 
 9   Forth definitions                                             
10                                                                 
11   : files   file-link                                           
12      BEGIN  @ dup WHILE  cr dup (.fcb  stop? UNTIL  drop ;      
13                                                                 
14   : ?file    isfile@ (.fcb ;                                    
15                                                                 
Screen 7 not modified     
 0 \ dir make makefile                               ks 25 okt 87  
 1   Forth definitions                                             
 2                                                                 
 3   : killfile   close                                            
 4      isfile@ f.name filename >asciz ~unlink drop ;              
 5                                                                 
 6   : emptyfile      isfile@ 0=exit                               
 7      isfile@ f.name filename >asciz  0 ~creat ?diskerror        
 8      isfile@ f.handle !    isfile@ f.size 4 erase ;             
 9                                                                 
10   : make      close   name isfile@ fname!   emptyfile ;         
11                                                                 
12   : makefile  File   last @ name> execute   emptyfile ;         
13                                                                 
14                                                                 
15                                                                 
Screen 8 not modified     
 0 \ getpath                                         ks 10 okt 87  
 1   Dos definitions                                               
 2                                                                 
 3 | &40 Constant pathlen                                          
 4 | Create pathes  0 c, pathlen allot                             
 5                                                                 
 6 | : (setpath   ( string -- )   count                            
 7      dup pathlen u> Abort" path too long"  pathes place ;       
 8                                                                 
 9 | : getpath  ( +n -- string / ff )                              
10      >r  0   pathes count   r> 0                                
11      DO  rot drop Ascii ; skip  stash  Ascii ; scan  LOOP       
12      drop over - ?dup                                           
13      IF  here place   here   dup count + 1- c@                  
14          ?" :\" ?exit  Ascii \ here append exit                 
15      THEN  0= ;                                                 
Screen 9 not modified     
 0 \ pathsearch   .path  path                        ks 09 okt 87  
 1                                                                 
 2   : pathsearch  ( string -- asciz *f )   dup >r                 
 3      (fsearch dup 0= IF  rdrop exit  THEN  2drop  0 0           
 4      BEGIN  drop 1+  dup getpath ?dup 0=                        
 5             IF  drop r> filename >asciz 2 exit  THEN            
 6             r@ count 2 pick attach (fsearch                     
 7      0= UNTIL nip rdrop false ;                                 
 8                                                                 
 9   ' pathsearch Is fsearch                                       
10                                                                 
11   Forth  definitions                                            
12                                                                 
13   : .path    pathes count type ;                                
14                                                                 
15   : path     name nullstring? IF  .path exit  THEN  (setpath ;  
Screen 10 not modified     
 0 \ call another executable file                    ks 04 aug 87  
 1   Dos definitions                                               
 2                                                                 
 3 | Create cpb   0 , \ inherit parent environment                 
 4    dta , ds@ , $5C , ds@ , $6C , ds@ ,  Label ssave  0 ,        
 5                                                                 
 6 | Code ~exec  ( asciz -- *f )                                   
 7      I push   R push   U push   S ssave #) mov   cpb # R mov    
 8      $4B00 # A mov   $21 int   C: D mov   D D: mov   D S: mov   
 9      D E: mov   ssave #) S mov  CS not                          
10      ?[  A A xor   A push   $2F # A+ mov   $21 int   E: A mov   
11          A D: mov   C: A mov   A E: mov   R I mov   dta # W mov 
12          $40 # C mov   rep movs   A D: mov   A pop              
13      ]?  A W xchg   dta # D mov   $1A # A+ mov   $21 int        
14      W D mov   U pop   R pop   I pop   Next                     
15   end-code                                                      
Screen 11 not modified     
 0 \ calling MS-DOS thru forth interpreter           ks 19 mr 88   
 1                                                                 
 2 | : execute?  ( extension -- *f )                               
 3      count   filename count Ascii . scan drop swap              
 4      2dup 1+ erase  move   filename 1+ ~exec ;                  
 5                                                                 
 6   : fcall   ( string -- )  count filename place   ds@ cpb 4+ !  
 7      " .EXE" execute? dup IF  drop " .COM" execute?  THEN       
 8      ?diskerror ;                                               
 9                                                                 
10   : fdos  ( string -- )                                         
11      dta $80 erase   " /c " count dta place   count dta attach  
12      status push  status off .status COMSPEC fcall  curat? at ; 
13                                                                 
14                                                                 
15                                                                 
Screen 12 not modified     
 0 \ einige MS-DOS Funktionen  msdos  call           ks 10 okt 87  
 1                                                                 
 2   : dos:  Create ,"  Does> count here place                     
 3      Ascii " parse here attach  here fdos ;                     
 4                                                                 
 5   Forth definitions                                             
 6                                                                 
 7   dos: dir dir "                                                
 8   dos: ren ren "                                                
 9   dos: md md "                                                  
10   dos: cd cd "                                                  
11   dos: rd rd "                                                  
12   dos: fcopy copy "                                             
13   dos: delete del "                                             
14   dos: ftype type "                                             
15                                                                 
Screen 13 not modified     
 0 \ msdos  call                                     ks 23 okt 88  
 1                                                                 
 2   : msdos  savevideo   status push  status off .status          
 3      flush dta off COMSPEC fcall restorevideo ;                 
 4                                                                 
 5   : call    name   source >in @ /string c/l umin                
 6      dta place   dta dta >asciz drop   [compile] \              
 7      status push  status off .status fcall   curat? at ;        
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 14 not modified     
 0 \ time date                                       ks 19 mr 88   
 1   Dos definitions                                               
 2                                                                 
 3   : ftime  ( -- mm hh )                                         
 4      open isfile@ f.time @ $20 u/mod nip $40 u/mod ;            
 5                                                                 
 6   : fdate  ( -- dd mm yy )                                      
 7      open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;          
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 15 not modified     
 0 \ ~lseek  position?                               ks 10 okt 87  
 1   Dos definitions                                               
 2                                                                 
 3   Code ~lseek    ( d handle method -- d' )                      
 4      R W mov   D A mov   R pop   C pop   D pop                  
 5      $42 # A+ mov   $21 int   W R mov   CS not                  
 6      ?[  A push   Next  ]?  A D xchg  ;c: ?diskerror ;          
 7                                                                 
 8   Forth definitions                                             
 9                                                                 
10   : position?   ( -- dfaddr )                                   
11      isfile@ f.handle @ 0= Abort" file not open"                
12      0 0  isfile@ f.handle @  1  ~lseek ;                       
13                                                                 
14                                                                 
15                                                                 
Screen 16 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 17 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
