home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / block.seq < prev    next >
Text File  |  1988-12-01  |  10KB  |  230 lines
  1. \ BLOCK.SEQ     Tom's Forth virtual block system.       by Tom Zimmer
  2.  
  3. comment:
  4.  
  5.   Here is an impementation of a virtual block system.  The constants below,
  6. B/BUF, and #BUFFERS control the record or block size, and the number of
  7. buffers the system uses.  These are defaulted to 1024 byte blocks, and
  8. 4 buffers.  A true LRU (least recently used) buffer allocation mechanism
  9. is used, implemented as a bubble up buffer stack.  The least recently used
  10. buffer is always on the bottom of the stack.  As buffers are used or
  11. re-used, they are bubbled immediately up to the top of the stack, destined
  12. to settle to the bottom of the stack if the same record is not accessed
  13. again. This arraingment has been tested with up to 175 buffers and does not
  14. degrade record access performance at or below this value on a 286 machine.
  15.  
  16. comment;
  17.  
  18. needs scan.seq
  19.  
  20. prefix          \ Prefix assembler
  21.  
  22. only forth also definitions
  23.  
  24.         \ if b/buf is already defined, then don't define B/BUF,
  25.         \ #BUFFERS or BLOCKHANDLE
  26.  
  27.  
  28. defined b/buf nip 0=
  29. #if
  30.  
  31.         1024 constant b/buf             \ length of each block
  32.            4 constant #buffers          \ number of virtual buffers
  33.     ' seqhandle alias blockhandle       \ just use normal file stuff
  34.  
  35. #endif
  36.  
  37. variable blk                       \ current block number
  38.  
  39. only forth also hidden also definitions
  40.  
  41. variable cur_buffer#                    \ current buffer # of current block
  42.  
  43. #buffers 2* constant buflen
  44.  
  45. variable rec_array b/buf #buffers  * allot      \ an array of blocks
  46. variable rec#s            buflen     allot      \ block # array
  47. variable rec#updt         buflen     allot      \ Update flags
  48. variable rec#use          buflen     allot      \ block bubbleup stack
  49. variable rec#fil          buflen     allot      \ hcb for each block
  50.  
  51.                                         \ n1 = buffer number
  52.                                         \ a1 = address of buffer
  53. code buf#>bufaddr ( n1 --- a1 )         \ Calculate address a1 of buffer n1.
  54.                 pop ax
  55.                 mov bx, # b/buf
  56.                 mul bx
  57.                 add ax, # rec_array
  58.                 1push
  59.                 end-code
  60.  
  61.                                         \ n1 = buffer number
  62.                                         \ a1 = buffer address
  63. code >rec#s     ( n1 --- a1 )           \ return the buffer n1's record addr
  64.                 pop ax
  65.                 shl ax, # 1
  66.                 add ax, # rec#s
  67.                 1push
  68.                 end-code
  69.  
  70.                                         \ n1 = buffer number
  71.                                         \ a1 = buffer address
  72. code >rec#updt  ( n1 --- a1 )           \ return the buffer n1's update addr
  73.                 pop ax
  74.                 shl ax, # 1
  75.                 add ax, # rec#updt
  76.                 1push
  77.                 end-code
  78.  
  79.                                         \ n1 = buffer number
  80.                                         \ a1 = buffer address
  81. code >rec#fil   ( n1 --- a1 )           \ return the buffer n1's file addr
  82.                 pop ax
  83.                 shl ax, # 1
  84.                 add ax, # rec#fil
  85.                 1push
  86.                 end-code
  87.  
  88.                                         \ n1 = buffer number to check
  89.                                         \ n2 = is file NOT the same as
  90.                                         \      current, and is n1 <> zero
  91. code chkfil     ( n1 --- n1 n2 )        \ verify file in bufer n1 is current
  92.                 pop ax
  93.                 push ax
  94.                 or ax, ax
  95.             0= if
  96.                         1push           \ can't possibly match, don't try
  97.                         next            \ just push a zero
  98.                 then
  99.                 shl ax, # 1
  100.                 mov bx, # buflen
  101.                 sub bx, ax
  102.                 add bx, # rec#fil
  103.                 mov ax, 0 [bx]
  104.                 cmp ax, ' blockhandle >body \ compare blocks hcb with current hcb
  105.              0= if                      \ if zero flag true then they match.
  106.                     mov ax, # false     \ return a false to force a leave
  107.                     1push               \ from BEGIN WHILE REPEAT loop
  108.                 then
  109.                 mov ax, # true          \ no match, so we need to try again
  110.                 1push                   \ return true so we will.
  111.                 end-code
  112.  
  113. : bubbleup      ( n1 --- )              \ move buffer # n1 to end of list
  114.                 >r rec#use #buffers r@ scanw dup 0=
  115.                 abort" Buffer# number not in buffer list"
  116.                 1- 2* >r dup 2+ swap r> cmove   \ move list down except first
  117.                 r> rec#use buflen + 2- ! ;      \ stuff first at end of list.
  118.  
  119.                                         \ n1 = block we are looking for
  120.                                         \ n2 = buffer #
  121.                                         \ f1 = do we have it?, true if we do
  122. : ?gotrec       ( n1 --- <n2> f1 )      \ Do we have block n1 in memory?
  123.                 >r rec#s   #buffers
  124.                 begin   r@ scanw        \ look for the block
  125.                         chkfil          \ verify the file hcb is the same
  126.                 while   2 -1 d+         \ else look for next possibility
  127.                 repeat  r> drop
  128.                 if      rec#s - 2/ true
  129.                 else    drop false
  130.                 then    ;
  131.  
  132.                                         \ n1 = block to positon to
  133. : pos_block    ( n1 --- )               \ Set file pointer to block pos n1
  134.                 0 max b/buf *d blockhandle movepointer ;
  135.  
  136.                                         \ a1 = destination address of read
  137.                                         \ n1 = block number to read
  138. : read_block    ( a1 n1 --- )           \ read block n1 to address a1
  139.                 pos_block
  140.                 b/buf blockhandle hread b/buf <>
  141.                 abort" Error reading block" ;
  142.  
  143.                                         \ n1 = buffer number
  144.                                         \ n2 = block number to write
  145. : write_block  ( n1 n2 --- )            \ write block n1 to disk
  146.                 pos_block
  147.                 dup buf#>bufaddr
  148.                 b/buf rot >rec#fil @ hwrite b/buf <>
  149.                 abort" Error writing block, probably out of disk space." ;
  150.  
  151. only forth also forth definitions hidden also
  152.  
  153.                                         \ n1 = block #
  154.                                         \ a1 = bufadr
  155. : buffer        ( n1 --- a1 )           \ Assign least used buffer to rec n1
  156.                 rec#use @ >r                    \ find a buffer
  157.                 r@ bubbleup                     \ bump to highest priority
  158.                 r@ cur_buffer# !                \ set current buffer var
  159.                 r@ >rec#updt dup @              \ check update flag
  160.                 if      off                     \ clear update flag
  161.                         r@ dup >rec#s @         \ get block #
  162.                         write_block             \ write it
  163.                 else    drop                    \ discard, already cleared
  164.                 then    r@ >rec#s   !           \ set block #
  165.                 blockhandle r@ >rec#fil !           \ set the file hcb
  166.                 r> buf#>bufaddr ;               \ calc buffer addr
  167.  
  168. : empty-buffers ( --- )                 \ clean out the virtual buffers
  169.                 rec_array b/buf #buffers * erase
  170.                 rec#s    buflen -1 fill
  171.                 rec#updt buflen erase
  172.                 rec#fil  buflen erase
  173.                 rec#use  #buffers 0
  174.                 do      i over ! 2+     \ initialize the bubbleup stack
  175.                 loop    drop ;
  176.  
  177. : flush         ( --- )                 \ Write any updated buffers to disk
  178.                 #buffers 0
  179.                 do      -1 buffer drop
  180.                 loop    ;
  181.  
  182. : update        ( --- )                 \ mark the current block as updated
  183.                 cur_buffer# @ >rec#updt on ;
  184.  
  185.                                         \ n1 = block # to get
  186.                                         \ a1 is address of block # n1
  187. : block         ( n1 --- a1 )           \ Get block n1 into memory
  188.                 dup ?gotrec
  189.                 if      nip dup >r buf#>bufaddr
  190.                         r@ cur_buffer# ! r> bubbleup
  191.                 else    blockhandle >hndle @ 0< abort" No file open"
  192.                         dup buffer dup rot read_block
  193.                 then    ;
  194.  
  195. empty-buffers           \ Initialize the virtual memory arrays
  196.  
  197. : virtual_init  ( --- )
  198.                 defers initstuff
  199.                 empty-buffers ;
  200.  
  201. ' virtual_init is initstuff
  202.  
  203. : .blocks       ( --- )
  204.                 cr              ." Record #  "
  205.                 rec#s buflen bounds
  206.                 do      i @ 5 .r ?cr
  207.              2 +loop    cr      ." Update bit"
  208.                 rec#updt buflen bounds
  209.                 do      i @ 5 .r ?cr
  210.              2 +loop    cr      ." File HCB  "
  211.                 rec#fil buflen bounds
  212.                 do      i @ 5 .r ?cr
  213.              2 +loop    cr cr   ." Bubble stk"
  214.                 rec#use buflen bounds
  215.                 do      i @ 5 .r ?cr
  216.              2 +loop    cr ;
  217.  
  218. \s              *** stop loading here ***
  219.  
  220. : tt            ( n1 --- )
  221.                 30 08 at
  222.                 block drop
  223.                 .blocks ;
  224.  
  225. : ty            ( n1 --- )
  226.                 0
  227.                 do      i tt update .blocks
  228.                 loop    ;
  229.  
  230.