home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 18 / forthsup / blockio.fth < prev    next >
Encoding:
Text File  |  1986-09-18  |  1.3 KB  |  54 lines
  1. \ The low level I/O used to implement standard Forth BLOCKs
  2.  
  3. decimal
  4. variable disk-error
  5.  
  6. vocabulary sys  sys definitions
  7. 20 constant max#files
  8. 64 constant /filename
  9.  
  10. create filenames  max#files /filename * allot
  11. filenames max#files /filename * erase
  12.  
  13. \ Seek to the correct starting address and prepare the arguments
  14. \ to the gem read or write call
  15. : seek ( position file -- )
  16.   swap 0 -rot f_lseek drop    \ 0 means seek from beginning of file
  17. ;
  18. : gem-setio ( address file block -- address b/buf file )
  19.   b/buf *  over  seek       ( address file )
  20.   b/buf swap
  21. ;
  22. : ?disk-abort ( #transferred -- )
  23.   b/buf <> dup disk-error !
  24.   if   ." disk-error " cr abort     then
  25. ;
  26. : gem-read ( address file block -- )
  27.   gem-setio f_read    ( #read )  ?disk-abort
  28. ;
  29. : gem-write ( address file block -- )
  30.   gem-setio f_write   ( #read )  ?disk-abort
  31. ;
  32. : file-io
  33.   ['] gem-read  is read-block
  34.   ['] gem-write is write-block
  35. ;
  36. : open-file ( str -- file )
  37.   2 ( read/write ) over f_open  ( str fd )
  38.   dup 0<
  39.   if   ." Can't open " swap count type
  40.   else tuck ( fd  str fd )  /filename * filenames + "copy
  41.   then
  42. ;
  43. : file-size ( file -- l )    \ Seek to end of file to find size
  44.   2 swap 0 rot f_lseek
  45. ;
  46. : file#blocks ( file -- n )
  47.   file-size b/buf um/mod nip
  48. ;
  49. forth definitions
  50. : .file ( file -- )
  51.   [ sys ] /filename * filenames + count type
  52. ;
  53.  
  54.