home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 1 / RISC_DISC_1.iso / pd_share / code / forthmacs / !Forthmacs / lib / blockio < prev    next >
Encoding:
Text File  |  1994-07-24  |  1.6 KB  |  58 lines
  1. \ The low level I/O used to implement standard Forth BLOCKs
  2.  
  3. decimal
  4.  
  5. vocabulary sys
  6. also sys also definitions
  7. 20 constant max#files
  8.  
  9. : open-block-file  ( str -- fid )
  10.    dup read fopen                             ( str fid )
  11.    dup 0=  if                                 ( str fid )
  12.       ." Can't open " drop count type  abort  ( )
  13.       abort
  14.    then                                       ( str fid )
  15.    nip
  16. ;
  17.  
  18. nuser default-block-fid         \ File referenced by block-fid=0
  19. 0 default-block-fid !
  20.  
  21. : map-fid  ( fid -- fid' )
  22.    ?dup  0=  if                         \ Not the default block space
  23.       default-block-fid @  0=  if       \ Open on first access
  24.          p" forth.blk"  open-block-file  default-block-fid !
  25.       then
  26.       default-block-fid @
  27.    then
  28. ;
  29.  
  30. \ Seek to the correct starting address and prepare the arguments
  31. \ to the gem read or write call
  32. : setio  ( address block# fid -- address b/buf fid )
  33.    map-fid                        ( address block# fid' )
  34.    swap b/buf *  over fseek       ( address fid )
  35.    b/buf swap                     ( address b/buf fid )
  36. ;
  37.  
  38. : ?disk-abort  ( #transferred -- )  b/buf <> abort" Disk error"  ;
  39. : (read-block)   ( address block# file -- )  setio fgets  ?disk-abort  ;
  40. : (write-block)  ( address block# file -- )  setio fputs  ;
  41.  
  42. : install-block-io  ( -- )
  43.    ['] (read-block)  is read-block
  44.    ['] (write-block) is write-block
  45.    0 default-block-fid !
  46. ;
  47. install-block-io
  48. : (cold-hook  (cold-hook install-block-io  ;
  49. forth definitions
  50.  
  51.  
  52. \ Seek to end to find size
  53. : file-size  ( fid -- l )  map-fid  fsize  ;
  54.  
  55. : .file  ( fid -- )  drop ." File name unknown"  ;
  56.  
  57. previous previous definitions
  58.