home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 1 / RISC_DISC_1.iso / pd_share / code / forthmacs / !Forthmacs / lib / block < prev    next >
Encoding:
Text File  |  1994-07-24  |  6.3 KB  |  191 lines
  1. \ This file implements standard Forth BLOCKs
  2. \ The buffer management scheme is based on an LRU (Least Recently Used)
  3. \ replacement policy.  This implementation was adapted from the buffer
  4. \ management code in F83; thanks to Mike Perry and Henry Laxen.
  5.  
  6. decimal
  7.  
  8. nuser scr
  9. nuser blk
  10. : >in  ( -- adr )  bfcurrent  ;
  11.  
  12. nuser offset            \ Used to bias block numbers
  13. 0 offset !
  14.  
  15. nuser block-fid         \ 0 for global blocks, fileid for blocks in files
  16. 0 block-fid !
  17.  
  18. : d=  ( n1a n1b n2a n2b -- f )  rot =  -rot =  and  ;
  19.  
  20. \ Interfaces to the system-dependent code that does the actual I/O
  21.  
  22. defer read-block    (s adr block# fileid -- )
  23. defer write-block   (s adr block# fileid -- )
  24.  
  25. 1024 constant b/buf
  26.   64 constant c/l
  27.  
  28. \ The order of >block# and >file# must be preserved, and they
  29. \ must be at the start of the structure.  The program accesses
  30. \ them both at once with    <header-address> 2@
  31.  
  32. struct ( buffer-header )
  33.    /n field >file#
  34.    /n field >block#
  35.    /n field >bufadd
  36.    /n field >bufflags   \ -1: dirty block  0: clean block  1: no block
  37. constant /bufhdr
  38.  
  39. \ : /bufhdr*  ( u1 -- u2 )  /bufhdr *  ;
  40. : /bufhdr*  ( u1 -- u2 )  4 <<  ;       \ Optimization for 32-bit machines
  41.  
  42. \ Some debugging tools
  43. \ : .bh ( buffer-header -- )
  44. \    dup >block#      ." Block# "     @ .
  45. \    dup >file#       ."   File# "    @ .
  46. \    dup >bufadd      ."   Address "  @ .
  47. \        >bufflags    ."   Flags "    @ .
  48. \ ;
  49. \ : .bhs (s -- )  #buffers 1+ 0  do  i >header .bh  cr  loop  ;
  50. \ 
  51. \ : .read  ( bufadd file block -- )  ." Read "  . . . cr ;
  52. \ : .write ( bufadd file block -- )  ." Write " . . . cr ;
  53. \ ' .read  is read-block
  54. \ ' .write is write-block
  55.  
  56. \ Allocation of data structures
  57.  
  58. 4 value #buffers
  59.  
  60. #buffers 1+ /bufhdr*  buffer: bufhdrs
  61. b/buf #buffers *   buffer: first
  62.  
  63. : >header    (s n -- adr )   /bufhdr* bufhdrs +   ;
  64. : >update    (s -- adr )   1 >header >bufflags  ;
  65.  
  66. : update   (s -- )  >update on   ;
  67. : discard  (s -- )  1 >update !  ;
  68.  
  69. \ Write buffer if it is dirty
  70. : ?write-block  ( buf-header -- buf-header )
  71.    dup >bufflags @ 0<  if
  72.       dup >bufadd @ over 2@ write-block
  73.       dup >bufflags off
  74.    then
  75. ;
  76.  
  77. \ Discard least-recently-used buffer, writing it if necessary,
  78. \ and move it to the head of the list.
  79. : replace-buffer   (s -- )
  80.    #buffers >header  ?write-block                    ( last-buffer-header )
  81.    >bufadd @  bufhdrs >bufadd !                      ( ) \ Copy buffer address
  82.    bufhdrs  dup /bufhdr +  #buffers /bufhdr*  move   ( ) \ Move into position
  83.    discard                                               \ No assigned block
  84. ;
  85.  
  86. : file-buffer   (s u fileid -- adr )
  87.    pause
  88.  
  89.    \ Quick check in case the first buffer in the cache is the one we want
  90.    swap  offset @ +  swap                   ( u' fileid )
  91.    2dup   1 >header 2@   d=  0=  if         ( u fileid )
  92.  
  93.       \ Search the buffer cache
  94.       true   #buffers 1+ 2  do              ( u fileid true)
  95.          drop  2dup i >header 2@ d=  if     ( u fileid )
  96.             \ Found it; move it to the head of the list
  97.             i >header                       ( u fileid &hdrN)
  98.             dup bufhdrs /bufhdr move        ( u fileid &hdrN )  \ temp slot
  99.             >r  bufhdrs dup /bufhdr +       ( u fileid &hdr0 &hdr1 )
  100.             over r> swap  -  move           ( u fileid )
  101.             false leave                     ( u fileid false )
  102.          then                               ( u fileid )
  103.          true                               ( u fileid true )
  104.       loop                                  ( u fileid not-in-cache? )
  105.  
  106.       if  2dup bufhdrs 2!  replace-buffer  then    ( u fileid )
  107.    then                                     ( u fileid )
  108.    2drop
  109.    1 >header >bufadd @                      ( buffer-adr )
  110. ;
  111.  
  112. : file-block    (s u fileid -- a )
  113.    file-buffer                  ( adr )
  114.    >update @ 0>  if             ( adr )           \ Contents invalid?
  115.       1 >header  dup >bufadd @  ( adr hdr buf )
  116.       swap 2@  read-block       ( adr )           \ Read it in
  117.       >update off               ( adr )           \ block is clean
  118.    then                         ( adr )
  119. ;
  120.  
  121. : empty-buffers   (s -- )
  122.    first    b/buf #buffers *      erase         \ Clear buffers
  123.    bufhdrs  #buffers 1+ /bufhdr*  erase         \ Clear headers
  124.    first                                       ( adr )
  125.    1 >header  #buffers /bufhdr*  bounds  do    ( adr )
  126.       -1  i >block# !                          ( adr )  \ Invalid block#
  127.       dup i >bufadd !                          ( adr )  \ Point to buffer
  128.       b/buf +                                  ( adr' )
  129.    /bufhdr +loop                               ( adr' )
  130.    drop
  131. ;
  132.  
  133. : save-buffers   (s -- )
  134.    1 >header  #buffers /bufhdr*  bounds  do    ( )
  135.       i >block# @  -1 <>  if                    \ Flush valid blocks
  136.          i ?write-block drop
  137.       then
  138.    /bufhdr +loop
  139. ;
  140.  
  141. : buffer  (s n -- a )   block-fid @ file-buffer  ;
  142. : block   (s n -- a )   block-fid @ file-block   ;
  143. : flush   (s -- )  save-buffers  0 block drop  empty-buffers  ;
  144.  
  145. : block-sizeop  ( fid -- n )  drop b/buf  ;
  146. : load-file  ( block# fileid -- )
  147.    blk @ >r  over blk !  ( block# fileid )
  148.    file-block
  149.  
  150.    \ Create a stream descriptor
  151.    get-fd                                       \ Get a descriptor
  152.  
  153.    bfbase @  b/buf  move                        \ Copy in buffer contents
  154.    bfbase @  b/buf +  dup bftop !  bfend !      \ Set limit pointers
  155.  
  156.    0 modify                                     \ Low-level stream operations
  157.    ['] block-sizeop  ['] noop       ['] drop
  158.    ['] nullseek      ['] fakewrite  ['] nullread
  159.    setupfd
  160.  
  161.    file @ (fload)
  162.    r> blk !
  163. ;
  164. : load  ( block# -- )  block-fid @ load-file  ;
  165.  
  166. \ Backslash (comment to end of line) for blocks
  167. : \  \ rest-of-line  ( -- )
  168.    input-file @ file !
  169.    sizeop @  ['] block-sizeop  =  if
  170.       bfcurrent @  bfbase @ -                   ( offset-into-buffer )
  171.       c/l 1- +   c/l 1- not  and                ( offset-of-next-line )
  172.       bfbase @ +  bflimit @  umin  bfcurrent !  ( )
  173.    else
  174.       [compile] \
  175.    then
  176. ; immediate
  177.  
  178. : thru   (s n1 n2 -- )  2 ?enough   1+ swap ?do   i load   loop   ;
  179. : +thru  (s n1 n2 -- )  blk @ + swap   blk @ + swap   thru   ;
  180. : -->    (s -- )  input-file @ fclose  blk @ 1+ load  ;   immediate
  181.  
  182. : list  ( scr# -- )
  183.    dup scr !  ." Screen " dup .  cr  ( scr# )
  184.    block  b/buf  bounds  do   i  c/l  type  cr  c/l +loop
  185. ;
  186. : n  ( -- )   1 scr +!  ;
  187. : b  ( -- )  -1 scr +!  ;
  188. : l  ( -- )  scr @ list  ;
  189.  
  190. empty-buffers
  191.