\ *** Block No. 0 Hexblock 0 
\ CP/M 2.2 File-Interface (3.80a)                     UH 05Oct87
                                                                
Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. 
Damit ist Zugriff auf normale CP/M-Files moeglich.              
Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,   
die mit dem Massenspeicher arbeiten, auf dieses File.           
                                                                
Benutzung:                                                      
  USE <name>       \ benutze ein schon existierendes File       
  FILE <name>      \ erzeuge ein Forthfile mit dem Namen <name>.
  MAKE <name>      \ Erzeuge ein File mit <name> und ordne      
                   \ es dem aktuellen Forthfile zu.             
  MAKEFILE <name>  \ Erzeuge ein File mit CP/M und FORTH-Namen  
                     <name>.                                    
  INCLUDE <name>   \ Lade File mit Forthnamen <name> ab Screen 1
  DOS RESET        \ zum Wechsel von Disketten. (Oh! CP/M)      
\ *** Block No. 1 Hexblock 1 
\ CP/M 2.2 File-Interface  load-Screen                UH 18Feb88
OnlyForth                                                       
                                                                
      2 load \ view numbers for this file                       
  3   4 thru \ DOS   File Functions                             
  5 $11 thru \ Forth File Functions                             
$12 $16 thru \ User Interface                                   
                                                                
File source.fb      \  Define already existing Files            
File fileint.fb     File startup.fbr                            
                                                                
' (makeview     Is makeview                                     
' remove-files  Is custom-remove                                
' file-r/w      Is r/w                                          
' noop          Is drvinit                                      
 \      include startup.fb \ load Standard System               
\ *** Block No. 2 Hexblock 2 
\ Build correct view-numbers for this file           UUH 19Nov87
                                                                
| : fileintview ( -- )  $400 blk @ + ;                          
                                                                
' fileintview Is makeview                                       
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 3 Hexblock 3 
\ File Control Blocks                                 UH 18Feb88
Dos definitions also                                            
| : Fcbyte ( n len -- len' )  Create over c, + does> c@ + ;     
&11 Constant filenamelen                                        
0              2 | Fcbyte nextfile  immediate                   
               1   Fcbyte drive    ' drive | Alias >dosfcb      
 filenamelen 3 -   Fcbyte filename                              
               3   Fcbyte extension                             
           &21 + \ ex, s1, s2, rc, d0, ... dn, cr               
               2   Fcbyte record    \  r0, r1                   
              1+ \ r2                                           
               2   Fcbyte opened                                
               2   Fcbyte fileno                                
               2   Fcbyte filesize  \ in 128-Byte-Records       
               4   Fcbyte position                              
Constant b/fcb                                                  
\ *** Block No. 4 Hexblock 4 
\ dos primitives                                      UH 10Oct87
                                                                
' 2-  | Alias body>             ' 2- | Alias dosfcb>            
                                                                
: drive!     ( drv    --      )     $0E bdos ;                  
: search0    ( dosfcb -- dir  )     $11 bdosa ;                 
: searchnext ( dosfcb -- dir  )     $12 bdosa ;                 
: read-seq   ( dosfcb -- f    )     $14 bdosa dos-error? ;      
: write-seq  ( dosfcb -- f    )     $15 bdosa dos-error? ;      
: createfile ( dosfcb -- f    )     $16 bdosa dos-error? ;      
: size       ( dos    -- size ) dup $23 bdos dosfcb> record @ ; 
: drive@     (        -- drv  )   0 $19 bdosa ;                 
: killfile   ( dosfcb --      )     $13 bdos ;                  
                                                                
                                                                
                                                                
\ *** Block No. 5 Hexblock 5 
\ File sizes                                          UH 05Oct87
                                                                
: (capacity  ( fcb -- n )  \ filecapacity in blocks             
    filesize @  rec/blk  u/mod swap 0= ?exit 1+ ;               
                                                                
: in-range ( block fcb -- )                                     
    (capacity u< not Abort" beyond capacity!" ;                 
                                                                
Forth definitions                                               
                                                                
: capacity ( -- n )    isfile@  (capacity ;                     
                                                                
Dos definitions                                                 
                                                                
                                                                
                                                                
\ *** Block No. 6 Hexblock 6 
\ (open                                               UH 18Feb88
                                                                
: (open  ( fcb -- )                                             
    dup opened @ IF drop exit THEN   dup position  0. rot 2!    
    dup >dosfcb openfile  Abort" not found!"  dup opened on     
    dup >dosfcb size  swap filesize ! ;                         
                                                                
: (make  ( fcb -- )                                             
   dup >dosfcb killfile                                         
   dup >dosfcb createfile Abort" directory full!"               
   dup position 0. rot 2!                                       
   dup filesize off   opened on  offset off ;                   
                                                                
: file-r/w  ( buffer block fcb f  -- f )                        
    over 0= Abort" no Direct Disk IO supported! "               
    >r  dup  (open   2dup in-range r> (r/w ;                    
\ *** Block No. 7 Hexblock 7 
\ Print Filenames                                     UH 10Oct87
                                                                
: .file ( fcb -- ) 0 case? IF ." DIRECT"  exit THEN             
         fcb dosfcb> case? IF ." DEFAULT" exit THEN             
         body> >name .name ;                                    
                                                                
: .drive   ( fcb -- ) drive c@ ?dup 0=exit                      
     [ Ascii A 1- ] Literal + emit  Ascii : emit ;              
                                                                
: .dosfile ( fcb -- )  dup filename  8 -trailing type           
    Ascii . emit           extension 3           type ;         
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 8 Hexblock 8 
\ Print Filenames                                     UH 10Oct87
                                                                
: tab ( -- ) col &59 > IF cr exit THEN                          
        &20  col &20 mod  -  0 max  spaces ;                    
                                                                
: .fcb  ( fcb -- )  dup fileno @  3 u.r tab                     
     dup .file tab dup .drive dup .dosfile                      
     tab dup opened @ IF ." opened" ELSE ." closed" THEN        
     3 spaces  base push  decimal   (capacity  3 u.r  ."  kB" ; 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 9 Hexblock 9 
\ Filenames                                           UH 05Oct87
                                                                
: !name ( addr len fcb -- )                                     
     dup >r filename filenamelen bl fill                        
     over 1+ c@  Ascii : =                                      
     IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>        
     ELSE 0 THEN  r@ drive c! r> dup filename 2swap             
     filenamelen 1+ min bounds                                  
     ?DO  I c@ Ascii . =                                        
         IF drop dup  extension ELSE  I c@ over c! 1+ THEN      
     LOOP 2drop ;                                               
                                                                
: !fcb  ( fcb -- )  dup opened off   name count rot !name ;     
                                                                
                                                                
                                                                
\ *** Block No. 10 Hexblock A 
\ Print Directory                                     UH 18Nov87
                                                                
| Create dirbuf  b/rec allot    dirbuf b/rec erase              
| Create fcb0    b/fcb allot    fcb0   b/fcb erase              
                                                                
| : wildchard?  ( f c -- f' )  Ascii * = IF drop Ascii ? THEN ; 
| : (expand ( addr len -- )  false -rot bounds                  
     ?DO  I c@  wildchard? dup ?dup IF I c! THEN  LOOP drop ;   
| : expand ( fcb -- )  \ expand * to ???                        
     dup filename 8 (expand   extension 3 (expand ;             
                                                                
: (dir  ( addr len -- )                                         
    fcb0 !name fcb0 expand  dirbuf dma!  fcb0 >dosfcb search0   
    BEGIN dup dos-error? not                                    
    WHILE  $20 * dirbuf + dosfcb> tab .dosfile                  
           fcb0 >dosfcb searchnext  stop? UNTIL  drop ;         
\ *** Block No. 11 Hexblock B 
\ File List                                           UH 10Oct87
                                                                
User file-link   file-link off                                  
                                                                
| : #file ( -- n )   file-link @ dup IF fileno c@ THEN 1+ ;     
                                                                
                                                                
Forth definitions                                               
                                                                
: forthfiles ( -- )                                             
   file-link @                                                  
   BEGIN dup WHILE  cr  dup .fcb  @ stop? UNTIL drop ;          
                                                                
Dos definitions                                                 
                                                                
                                                                
\ *** Block No. 12 Hexblock C 
\ Close a file                                        UH 10Oct87
                                                                
' save-buffers >body $0C + @ | Alias backup                     
                                                                
| : filebuffer?  ( fcb -- fcb bufaddr/flag )                    
   prev  BEGIN @ dup WHILE  2dup 2+ @ = UNTIL ;                 
                                                                
| : flushfile  ( fcb -- )  \ flush file buffers                 
     BEGIN  filebuffer?  ?dup  WHILE                            
            dup backup  emptybuf  REPEAT  drop ;                
                                                                
: (close  ( fcb -- )  \ close file in fcb                       
   dup flushfile                                                
   dup opened  dup @ 0= IF 2drop exit THEN  off                 
   >dosfcb closefile Abort" not found!" ;                       
                                                                
\ *** Block No. 13 Hexblock D 
\ Create fcbs                                         UH 10Oct87
                                                                
: !files ( fcb -- )  dup  isfile ! fromfile ! ;                 
                                                                
' r@ | Alias newfcb                                             
                                                                
Forth definitions                                               
                                                                
: File  ( -- )                                                  
   Create here >r   b/fcb allot  newfcb b/fcb erase             
          last @ count $1F and  newfcb !name                    
          #file   newfcb fileno !                               
          file-link @  newfcb nextfile !   r> file-link !       
   Does> !files ;                                               
                                                                
: direct     0 !files ;                                         
\ *** Block No. 14 Hexblock E 
\ flush buffers & misc.                  UH 10Oct87   UH 28Nov87
Dos definitions                                                 
                                                                
: save-files  ( -- )  file-link BEGIN  @ ?dup  WHILE            
     dup opened @ IF dup >dosfcb closefile drop THEN  REPEAT ;  
                                                                
' save-files Is save-dos-buffers                                
                                                                
\ : close-files  ( -- )  file-link                              
\     BEGIN  @ ?dup  WHILE  dup (close  REPEAT ;                
                                                                
Forth definitions                                               
                                                                
: file?   isfile@ .file ;  \ print current file                 
                                                                
: list  ( n -- )   3 spaces  file? list ;                       
\ *** Block No. 15 Hexblock F 
\ words for viewing                                   UH 10Oct87
                                                                
Forth definitions                                               
                                                                
| $200 Constant viewoffset \ max. %512 kB files                 
                                                                
: (makeview  ( -- n )  \ calc. view filed for a name            
   blk @ dup  0= ?exit                                          
   loadfile @ ?dup IF fileno @ viewoffset * + THEN ;            
                                                                
: (view      ( blk -- blk' ) \ select file and leave block      
   dup 0=exit                                                   
   viewoffset u/mod  file-link                                  
   BEGIN @ dup WHILE 2dup fileno @ = UNTIL                      
   !files drop ;        \ not found: direct access              
                                                                
\ *** Block No. 16 Hexblock 10 
\ FORGETing files                                     UH 10Oct87
                                                                
| : remove?      ( dic symb addr -- dic symb addr f )           
     dup heap? IF  2dup u> exit THEN 2 pick over 1+ u< ;        
                                                                
                                                                
| : remove-files ( dic symb -- dic symb )  \ flush files !      
     isfile@      remove? nip  IF direct       THEN             
     fromfile @   remove? nip  IF fromfile off THEN             
     file-link                                                  
     BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT       
     file-link remove ;                                         
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 17 Hexblock 11 
\ print a list of all buffers                         UH 20Oct86
                                                                
: .buffers                                                      
   prev BEGIN  @ ?dup WHILE  stop? abort" stopped"              
           cr dup u. dup 2+ @ dup 1+                            
           IF ."    Block: " over 4+ @ 5 .r                     
              ."    File : " [ Dos ] .file                      
              dup 6 + @ 0< IF ."     updated" THEN              
           ELSE ." Buffer empty" drop THEN  REPEAT ;            
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 18 Hexblock 12 
\ File Interface User words                           UH 11Oct87
                                                                
| : same ( addr -- )  >in ! ;                                   
: open      isfile@ (open   offset off ;                        
: close     isfile@ (close ;                                    
: assign    close   isfile@ !fcb  open ;                        
: make      isfile@ dup !fcb   (make ;                          
                                                                
| : isfile?  ( addr -- addr f )    \ is adr a fcb?              
  file-link BEGIN  @ dup 0=exit 2dup body> = UNTIL drop true ;  
                                                                
: use       >in @ name find \ create a fcb if not present       
            IF isfile? IF execute drop  exit THEN THEN drop     
            dup same File   same ' execute  open ;              
                                                                
                                                                
\ *** Block No. 19 Hexblock 13 
\ File Interface User words                           UH 25May88
                                                                
: makefile     >in @   File  dup  same ' execute  same make ;   
: emptyfile    isfile@ >dosfcb createfile ;                     
                                                                
: from         isfile push use ;                                
: loadfrom     ( n -- )                                         
               isfile push  fromfile push  use load   close ;   
: include      1 loadfrom ;                                     
                                                                
: eof ( -- f ) isfile@  dup filesize @ swap record @ = ;        
                                                                
: files        " *.*" count (dir ;                              
: files"       Ascii " word count 2dup upper (dir ;             
                                                                
' files Alias dir     ' files" Alias dir"                       
\ *** Block No. 20 Hexblock 14 
\ extend Files                                        UH 20Nov87
                                                                
| : >fileend   isfile@ >dosfcb size drop ;                      
                                                                
| : addblock  ( n -- )  \ add block n to file                   
     dup buffer under   b/blk  bl fill                          
     isfile@   rec/blk  over filesize +!  false file-r/w        
     IF close Abort" disk full!" THEN ;                         
                                                                
: more ( n -- )   open >fileend                                 
   capacity swap bounds  ?DO I addblock LOOP close              
   open close ;                                                 
                                                                
: Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;           
0   Drive: a:   Drive: b:   Drive: c:   Drive: d:               
5 + Drive: j:  drop                                             
\ *** Block No. 21 Hexblock 15 
\ save memory-image as disk-file                      UH 29Nov86
                                                                
Forth definitions                                               
                                                                
: savefile ( from count -- ) \ filename                         
   isfile push  makefile bounds                                 
   ?DO I dma!  isfile@ >dosfcb write-seq  Abort" disk full!"    
       b/rec +LOOP  close ;                                     
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 22 Hexblock 16 
\ Status                                              UH 10OCt87
                                                                
                                                                
: .blk ( -- )   blk @ ?dup 0=exit                               
   dup 1 = IF cr file? THEN base push hex ."  Blk " . ?cr ;     
                                                                
' .blk Is .status                                               
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 23 Hexblock 17 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 24 Hexblock 18 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 25 Hexblock 19 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 26 Hexblock 1A 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 27 Hexblock 1B 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 28 Hexblock 1C 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 29 Hexblock 1D 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 30 Hexblock 1E 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 31 Hexblock 1F 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
