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 >
Wrap
Text File
|
1995-02-04
|
5KB
|
164 lines
\ This file implements standard Forth BLOCKs
\ The buffer management scheme is based on an LRU (Least Recently Used)
\ replacement policy. This implementation was adapted from the buffer
\ management code in F83; thanks to Mike Perry and Henry Laxen.
decimal
nuser scr
nuser blk
nuser offset 0 offset ! \ Used to bias block numbers
nuser block-fid 0 block-fid ! \ 0 for global blocks, fileid for blocks in files
: >in ( -- adr ) bfcurrent ;
: d= ( n1a n1b n2a n2b -- f )
rot = -rot = and ;
\ Interfaces to the system-dependent code that does the actual I/O
defer read-block (s adr block# fileid -- )
defer write-block (s adr block# fileid -- )
1024 constant b/buf
64 constant c/l
\ The order of >block# and >file# must be preserved, and they
\ must be at the start of the structure. The program accesses
\ them both at once with <header-address> 2@
struct ( buffer-header )
/cell field >file#
/cell field >block#
/cell field >bufadd
/cell field >bufflags \ -1: dirty block 0: clean block 1: no block
constant /bufhdr
\ : /bufhdr* ( u1 -- u2 ) /bufhdr * ;
: /bufhdr* ( u1 -- u2 ) 4 lshift ; \ Optimization for 32-bit machines
\ Some debugging tools
\ : .bh ( buffer-header -- )
\ dup >block# " Block# " @ .
\ dup >file# ." File# " @ .
\ dup >bufadd ." Address " @ .
\ >bufflags ." Flags " @ . ;
\ : .bhs (s -- ) #buffers 1+ 0 do i >header .bh cr loop ;
\
\ : .read ( bufadd file block -- ) ." Read " . . . cr ;
\ : .write ( bufadd file block -- ) ." Write " . . . cr ;
\ ' .read is read-block
\ ' .write is write-block
\ Allocation of data structures
4 value #buffers
#buffers 1+ /bufhdr* buffer: bufhdrs
b/buf #buffers * buffer: first
: >header (s n -- adr ) /bufhdr* bufhdrs + ;
: >update (s -- adr ) 1 >header >bufflags ;
: update (s -- ) >update on ;
: discard (s -- ) 1 >update ! ;
\ Write buffer if it is dirty
: ?write-block ( buf-header -- buf-header )
dup >bufflags @ 0<
if dup >bufadd @ over 2@ write-block
dup >bufflags off
then ;
\ Discard least-recently-used buffer, writing it if necessary,
\ and move it to the head of the list.
: replace-buffer (s -- )
#buffers >header ?write-block ( last-buffer-header )
>bufadd @ bufhdrs >bufadd ! ( ) \ Copy buffer address
bufhdrs dup /bufhdr + #buffers /bufhdr* move ( ) \ Move into position
discard ; \ No assigned block
: file-buffer (s u fileid -- adr )
pause
\ Quick check in case the first buffer in the cache is the one we want
swap offset @ + swap ( u' fileid )
2dup 1 >header 2@ d= 0=
if \ Search the buffer cache ( u fileid )
true #buffers 1+ 2
do drop 2dup i >header 2@ d=
if ( u fileid )
\ Found it; move it to the head of the list
i >header ( u fileid &hdrN)
dup bufhdrs /bufhdr move ( u fileid &hdrN )
>r bufhdrs dup /bufhdr + ( u fileid &hdr0 &hdr1 )
over r> swap - move ( u fileid )
false leave ( u fileid false )
then ( u fileid )
true
loop ( u fileid not-in-cache? )
if 2dup bufhdrs 2! replace-buffer then ( u fileid )
then ( u fileid )
2drop 1 >header >bufadd @ ; ( buffer-adr )
: file-block (s u fileid -- a )
file-buffer >update @ 0>
if \ Contents invalid?
1 >header dup >bufadd @ ( adr hdr buf )
swap 2@ read-block ( adr ) \ Read it in
>update off ( adr )
then ;
: empty-buffers (s -- )
first b/buf #buffers * erase \ Clear buffers
bufhdrs #buffers 1+ /bufhdr* erase \ Clear headers
first ( adr )
1 >header #buffers /bufhdr* bounds
do -1 i >block# ! ( adr ) \ Invalid block#
dup i >bufadd ! ( adr ) \ Point to buffer
b/buf + ( adr' )
/bufhdr +loop drop ;
: save-buffers (s -- )
1 >header #buffers /bufhdr* bounds
do i >block# @ -1 <>
if i ?write-block drop then
/bufhdr +loop ;
: buffer (s n -- a ) block-fid @ file-buffer ;
: block (s n -- a ) block-fid @ file-block ;
: flush (s -- ) save-buffers 0 block drop empty-buffers ;
: block-sizeop (s fid -- n ) drop b/buf ;
: load-file (s block# fileid -- )
blk @ >r over blk ! ( block# fileid )
file-block
get-fd
bfbase @ b/buf move \ Copy in buffer contents
bfbase @ b/buf + dup bftop ! bfend ! \ Set limit pointers
0 modify \ Low-level stream operations
['] block-sizeop ['] noop ['] drop
['] nullseek ['] fakewrite ['] nullread
setupfd
file @ (fload)
r> blk ! ;
: load ( block# -- ) block-fid @ load-file ;
\ Backslash (comment to end of line) for blocks
: \ \ rest-of-line ( -- )
input-file @ file !
sizeop @ ['] block-sizeop =
if bfcurrent @ bfbase @ -
c/l 1- + c/l 1- not and
bfbase @ + bflimit @ umin bfcurrent !
else [compile] \
then ; immediate
: thru (s n1 n2 -- ) 2 ?enough 1+ swap ?do i load loop ;
: +thru (s n1 n2 -- ) blk @ + swap blk @ + swap thru ;
: --> (s -- ) input-file @ fclose blk @ 1+ load ; immediate
: list (s scr# -- )
dup scr ! ." Screen " dup . cr ( scr# )
block b/buf bounds
do i c/l type cr c/l +loop ;
: n (s -- ) 1 scr +! ;
: b (s -- ) -1 scr +! ;
: l (s -- ) scr @ list ;
empty-buffers