home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 5 / DATAFILE_PDCD5.iso / utilities / f / forthmac / !Forthmacs / lib / block < prev    next >
Encoding:
Text File  |  1997-04-17  |  4.9 KB  |  162 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. nuser offset    0 offset !    \ Used to bias block numbers
  11. nuser block-fid    0 block-fid !    \ 0 for global blocks, fileid for blocks in files
  12. : >in    ( -- adr )    bfcurrent  ;
  13. \needs d=    : d=    ( d1 d2 -- f )    rot = -rot = and  ;
  14.  
  15. \ Interfaces to the system-dependent code that does the actual I/O
  16.  
  17. defer read-block    (s adr block# fileid -- )
  18. defer write-block    (s adr block# fileid -- )
  19.  
  20. 1024 constant b/buf
  21.   64 constant c/l
  22.  
  23. \ The order of >block# and >file# must be preserved, and they
  24. \ must be at the start of the structure.  The program accesses
  25. \ them both at once with    <header-address> 2@
  26.  
  27. struct ( buffer-header )
  28.  /cell field >file#
  29.  /cell field >block#
  30.  /cell field >bufadd
  31.  /cell field >bufflags    \ -1 dirty block  0 clean block  1 no block
  32. constant /bufhdr
  33.  
  34. : /bufhdr*    ( u1 -- u2 )    /bufhdr * ;
  35.  
  36. \ < Some debugging tools
  37. \ : .bh    ( buffer-header -- )
  38. \    dup >block#    " Block# "    @ .
  39. \    dup >file#    ."   File# "    @ .
  40. \    dup >bufadd    ."   Address "    @ .
  41. \    >bufflags    ."   Flags "    @ . ;
  42. \ : .bhs    (s -- )    #buffers 1+ 0  do  i >header .bh  cr  loop  ;
  43. \ 
  44. \ : .read    ( bufadd file block -- )    ." Read "  . . . cr ;
  45. \ : .write    ( bufadd file block -- )    ." Write " . . . cr ;
  46. \  ' .read  is read-block
  47. \  ' .write is write-block
  48.  
  49. \ > Allocation of data structures
  50.  
  51. 4 value #buffers
  52.  
  53. #buffers 1+ /bufhdr*  buffer: bufhdrs
  54. b/buf #buffers *      buffer: first
  55.  
  56. : >header    (s n -- adr )    /bufhdr* bufhdrs +   ;
  57. : >update    (s -- adr )    1 >header >bufflags  ;
  58. : update    (s -- )        >update on   ;
  59. : discard    (s -- )        1 >update !  ;
  60.  
  61. \ Write buffer if it is dirty
  62. : ?write-block    ( buf-header -- buf-header )
  63.     dup >bufflags @ 0<
  64.     if    dup >bufadd @ over 2@ write-block
  65.         dup >bufflags off
  66.     then ;
  67.  
  68. \ Discard least-recently-used buffer, writing it if necessary,
  69. \ and move it to the head of the list.
  70. : replace-buffer    (s -- )
  71.     #buffers >header  ?write-block            ( last-buffer-header )
  72.     >bufadd @  bufhdrs >bufadd !            ( ) \ Copy buffer address
  73.     bufhdrs dup /bufhdr + #buffers /bufhdr*  move    ( ) \ Move into position
  74.     discard ;                        \ No assigned block
  75.  
  76. : file-buffer    (s u fileid -- adr )
  77.     pause
  78.     \ Quick check in case the first buffer in the cache is the one we want
  79.     swap  offset @ +  swap            ( u' fileid )
  80.     2dup   1 >header 2@  d= 0=
  81.     if    \ Search the buffer cache    ( u fileid )
  82.         true #buffers 1+ 2
  83.         do    drop  2dup i >header 2@ d=
  84.            if    ( u fileid )
  85.             \ Found it; move it to the head of the list
  86.             i >header        ( u fileid &hdrN)
  87.             dup bufhdrs /bufhdr move    ( u fileid &hdrN )
  88.             >r  bufhdrs dup /bufhdr +    ( u fileid &hdr0 &hdr1 )
  89.             over r> swap  -  move        ( u fileid )
  90.             false leave            ( u fileid false )
  91.            then                    ( u fileid )
  92.            true
  93.         loop                    ( u fileid not-in-cache? )
  94.         if 2dup bufhdrs 2!  replace-buffer then    ( u fileid )
  95.     then    ( u fileid )
  96.     2drop  1 >header >bufadd @ ;            ( buffer-adr )
  97.  
  98. : file-block    (s u fileid -- a )
  99.     file-buffer  >update @ 0>
  100.     if            \ Contents invalid?
  101.         1 >header  dup >bufadd @    ( adr hdr buf )
  102.         swap 2@  read-block        ( adr )    \ Read it in
  103.         >update off            ( adr )
  104.     then ;
  105.  
  106. : empty-buffers    (s -- )
  107.     first    b/buf #buffers *      erase    \ Clear buffers
  108.     bufhdrs  #buffers 1+ /bufhdr*  erase    \ Clear headers
  109.     first                    ( adr )
  110.     1 >header  #buffers /bufhdr*  bounds
  111.     do    -1  i >block# !            ( adr )    \ Invalid block#
  112.         dup i >bufadd !            ( adr )    \ Point to buffer
  113.         b/buf +                ( adr' )
  114.     /bufhdr +loop  drop ;
  115.  
  116. : save-buffers    (s -- )
  117.     1 >header  #buffers /bufhdr*  bounds
  118.     do    i >block# @  -1 <>
  119.         if i ?write-block drop then
  120.     /bufhdr +loop ;
  121.  
  122. : buffer    (s n -- a )    block-fid @ file-buffer  ;
  123. : block        (s n -- a )    block-fid @ file-block   ;
  124. : flush        (s -- )        save-buffers  0 block drop  empty-buffers  ;
  125. : block-sizeop    (s fid -- n )    drop b/buf  ;
  126. : load-file    (s block# fileid -- )
  127.     blk @ >r  over blk !  ( block# fileid )
  128.     file-block
  129.     get-fd
  130.     bfbase @  b/buf  move            \ Copy in buffer contents
  131.     bfbase @  b/buf +  dup bftop !  bfend !    \ Set limit pointers
  132.     0 modify                \ Low-level stream operations
  133.     ['] block-sizeop  ['] noop       ['] drop
  134.     ['] nullseek      ['] fakewrite  ['] nullread
  135.     setupfd
  136.     file @ (fload)
  137.     r> blk ! ;
  138. : load    ( block# -- )    block-fid @ load-file  ;
  139.  
  140. \ Backslash (comment to end of line) for blocks
  141. : \    \ rest-of-line  ( -- )
  142.     input-file @ file !
  143.     sizeop @  ['] block-sizeop  =
  144.     if    bfcurrent @  bfbase @ -
  145.         c/l 1- +   c/l 1- not  and
  146.         bfbase @ +  bflimit @  umin  bfcurrent !
  147.     else    postpone \
  148.     then ; immediate
  149.  
  150. : thru    (s n1 n2 -- )    2 ?enough   1+ swap ?do   i load   loop   ;
  151. : +thru    (s n1 n2 -- )    blk @ + swap   blk @ + swap   thru   ;
  152. : -->    (s -- )        input-file @ fclose  blk @ 1+ load  ;   immediate
  153. : list    (s scr# -- )
  154.     dup scr !  ." Screen " dup .  cr  ( scr# )
  155.     block  b/buf  bounds
  156.     do   i  c/l  type  cr  c/l +loop ;
  157. : n    (s -- )        1 scr +!  ;
  158. : b    (s -- )        -1 scr +!  ;
  159. : l    (s -- )        scr @ list  ;
  160.  
  161. empty-buffers
  162.