Quick file handling

I needed to do a quick file hack and came up with this.  It's a
cut down version of the library I use when writing applications.
It will require customizing for other forths.


\ FILEHACK.F
\
\ Simplified file handling (see example below)
\
\ N.B. This was written for DX-Forth and will require modification
\ for others.  E.g. SYS SYSTEM APPLICATION BEHEAD '$FF AND' etc can
\ be omitted and the codes in ?DERR adjusted to match your system.
\
\ Public domain

sys @  base @

forth definitions decimal

system
\ Create file handle - holds file-id and filename
: HANDLE  create  -1 ,  max-path 1+ allot ;
application

: !FNAME ( a u handle -- )  >r  max-path min  r> cell+ place ;
: @FNAME ( handle -- a u )  cell+ count ;

: ?derr ( ior -- )  ?dup if
    space  $FF and  case
      2  of  ." file not found"  endof
      3  of  ." path not found"  endof
      4  of  ." too many open files"  endof
      5  of  ." access denied"  endof
      6  of  ." invalid handle"  endof
      dup . ." DOS"
    endcase  ."  error"  abort
  then ;

\ General functions using file-id
: FREAD ( a u fid -- a u' )  2>r dup 2r> read-file ?derr ;
: FREADLN ( a u fid -- a u' n )  2>r dup 2r> read-line ?derr ;
: FWRITE ( a u fid -- )  write-file ?derr ;
: FWRITELN ( a u fid -- )  write-line ?derr ;
: FSEEK ( ud fid -- )  reposition-file ?derr ;
: FPOS ( fid -- ud )  file-position ?derr ;
: FCLOSE ( fid -- )  close-file drop ;

\ Functions using handles

handle IFILE  \ Input handle
handle OFILE  \ Output handle

\ Get file-id from handle
aka @ >FID ( handle -- fid )

: IFID ( -- fid )  ifile >fid ;
: OFID ( -- fid )  ofile >fid ;

\ Open filename a/u for input
: OPENIN ( a u fam -- )
  >r 2dup r> open-file ?derr ifile tuck ! !fname ;

\ Create filename a/u for output
: MAKEOUT ( a u fam -- )
  >r 2dup r> create-file ?derr ofile tuck ! !fname ;

: CLOSEIN ( -- )  ifid fclose  -1 ifile ! ;
: CLOSEOUT ( -- )  ofid fclose  -1 ofile ! ;

\ Reposition IFILE
: SEEKIN ( ud -- )  ifid fseek ;

\ Reposition OFILE
: SEEKOUT ( ud -- )  ofid fseek ;

\ Get IFILE position
: INPOS ( -- ud )  ifid fpos ;

\ Get OFILE position
: OUTPOS ( -- ud )  ofid fpos ;

\ Read binary from IFILE
: READ ( a u -- a u2 )  ifid fread ;

\ Write binary to OFILE
: WRITE ( a u -- )  ofid fwrite ;

\ Read text from IFILE
: READLN ( a u -- a u2 flag )  ifid freadln ;

\ Write text to OFILE
: WRITELN ( a u -- )  ofid fwriteln ;

defer CLOSEFILES ( -- )
:noname  closein closeout ; is closefiles

base !  sys !

behead ?derr ?derr

0 [if]

  : fcopy ( -- )  \ file copy
    begin  pad 64 read  dup while  write  repeat 2drop ;

  s" infile.dat" r/o openin  s" outfile.dat" w/o makeout
  fcopy
  closefiles

[then]

\ End