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