\ vandys
\ Block cache code
\ A simple port of routines in Forth-83 for 6809 by Wilson M. Federici
\ Requires a system-dependant disk primitive "RDWT"
\ data-address, block#, flag -- error-code
\ flag: zero=write, nonzero=read
\ error-code: nonzero=error
\ The basis of source screen shadows is found here; a single block
\ of 4k is split into a pair of 80x25 (i.e., full screen) pages.
\ The first is the source screen, the second its shadow. Each page
\ is 2000 bytes, which leaves 96 bytes of "reserved" space at the
\ end of each code block. Source metadata may end up living here.
only
variable dskerr \ error-code from last rdwt
\ vandys
: r/w ( data-addr, blk#, flag -- )
\ flag zero=write, nonzero=read
rdwt dup dskerr ! abort" disk r/w error" ;
BLKSIZ constant BLKSIZ \ Byte of data in a block
BLKCOLS constant BLKCOLS \ Columns in a screen
BLKROWS constant BLKROWS
BLKCOLS BLKROWS * \ Bytes per screen
constant SCRSIZ
SCRSIZ 2* dup constant BASESIZ \ Non-resid block contents
BLKSIZ swap - \ Residual bytes on end of each block
constant BLKRESID
\ vandys
BUFSIZ constant BUFSIZ
\ Size of an in-core disk block buffer:
\ 1 cell link, 1 cell block number,
\ 1 cell update-flag, BLKSIZ bytes data
\ Move from buffer pointer to each of its fields
: (>buflink) ( ptr -- ptr ) ;
: (>bufblock) ( ptr -- ptr' ) cell+ ;
: (>bufflag) ( ptr -- ptr' ) 2 cells + ;
: (>bufbod) ( ptr -- ptr' ) 3 cells + ;
: (bod>buf) ( ptr' -- ptr ) 3 cells - ;
#BUFS constant #BUFS \ # bufs held in memory--at least one
\ Actual buffer cache memory
create (BUFS) #BUFS BUFSIZ * allot align
\ vandys
create PREV 0 , \ Most recently accessed block
\ Set/clear dirty flag, block presence
: (bufmod) ( buf -- buf ) dup (>bufflag) on ;
: (bufclean) ( buf -- buf ) dup (>bufflag) off ;
: (noblock) ( buf -- buf ) -1 over (>bufblock) ! ;
: (bufmod?) ( buf -- n ) (>bufflag) @ ;
\ Write out buffer if dirty
: (sv) ( buffer -- ) dup (bufmod?) if
dup (>bufbod) over (>bufblock) @ 0 r/w (bufclean)
then drop ;
\ Remove the block which follows the argument block from the
\ linked list built from the buffer "link" pointers. The
\ removed block points to the PREV block, and PREV is set to
\ point to this block.
: (lnk) ( link -- buffer )
dup @ dup @ rot ! PREV @ over ! dup PREV ! ;
\ vandys
\ Look up block, return to caller of caller if found--
\ this is an UNSTRUCTURED RETURN!
\ Otherwise return pointer to oldest block in "link"
\ list of blocks (causing this to become the newest
\ block, as it will presumably be immediately used in
\ an I/O request)
: (bk) dup 0= abort" Block 0" pause ( hook for multitasker )
offset @ + PREV @ (>bufblock) @ over = if
drop PREV @ (>bufbod) r> drop ( !!! ) exit then
PREV ( blk# lnkptr ) begin dup @ @ while
@ 2dup @ (>bufblock) @ = if
nip (lnk) (>bufbod) r> drop ( !!! ) exit then
repeat (lnk) ( -- blk# buffer ) ;
\ vandys
\ Get block from cache, or do an I/O to get this block
\ into memory.
: block (bk) ( returns to caller if already present )
( blk# buf ) dup (sv) tuck ( buf blk# buf )
(>bufbod) over 1 r/w ( -- buffer blk# )
over (>bufblock) ! (>bufbod) ;
\ Get block from cache, or else get an uninitialized
\ block which is assigned to this block number.
: buffer ( blk# -- buf )
(bk) ( blk# buf ) dup (sv) tuck (>bufblock) ! (>bufbod) ;
\ Set "block dirty" flag of most recently accessed block
: update PREV @ (bufmod) drop ;
\ vandys
: (buffer?) ( blk# -- buf | 0 ) (BUFS) #BUFS 0 do ( blk# buf )
2dup (>bufblock) @ = if nip unloop exit then
BUFSIZ + loop 2drop 0 ;
: copy ( from-blk#, to-blk# -- ) offset @ + swap
block (bod>buf) (sv) dup (buffer?) ?dup if
(bufclean) (noblock) drop then ( to-blk# )
PREV @ tuck (>bufblock) ! (bufmod) drop ;
: empty-buffers (BUFS) 0 #BUFS 0 do ( buf-addr, link-value )
over BUFSIZ erase over (>buflink) ! (noblock) dup
BUFSIZ + swap loop PREV ! drop ;
: save-buffers PREV begin @ ?dup while dup (sv) repeat ;
: sync save-buffers ;
: flush save-buffers empty-buffers ;
\ vandys
\ Initialize immediately after loading
initialize definitions
: boot-buffers ( bool -- n | )
if empty-buffers \ Init chains
else 900 then
; only
\ vandys
variable scr
: list ( u -- ) cr scr ! BLKROWS 2* 0 do cr
scr @ block i BLKCOLS * + BLKCOLS -trailing
>r pad r@ cmove pad r> type
loop cr ;
\ vandys
\ Discard changes to current block
: discard ( -- ) PREV @ (bufclean) (noblock) drop ;
\ vandys
\ Load source from named block
variable ('endScr)
: (blktib) ( -- ) blk @ ?dup if block else tib0 @ then tib ! ;
: load ( b -- )
dup .
>r blk @ #tib @ >in @
'prompt @ ['] nop 'prompt !
r> blk ! >r >r >r >r (blktib)
BLKROWS 0 do PREV @ blk @ - if (blktib) then
i BLKCOLS * dup >in ! BLKCOLS + #tib ! eval
loop r> r> r> r>
'prompt ! >in ! #tib ! blk ! (blktib) ('endScr) @execute ;
: thru ( l h -- ) 1+ swap do i load loop ;
\ : --> blk @ 1+ load ; Deprecated
\ Block utilities vandys
: copy-blocks ( from to dest -- ) -rot over - 1+ >r swap r> 0 do
." " over . ." -> " dup .
2dup copy 1+ swap 1+ swap loop 2drop sync ;
: clear-blocks ( from to -- ) 1+ swap do
i block dup BLKSIZ blank [char] \ swap c! update loop sync ;
: roundup ( u1 u2 -- u ) 1- dup >r + r> -1 xor and ;
: (write_image) ( ptr blk nblk -- ) 0 do 2dup block BLKSIZ move
update 1+ swap BLKSIZ + swap loop 2drop sync ;
32 constant (aout_size)
: unexec ( blk -- ) up @ user0 #user move (warm?) on
BASEM swap here BASEM - BLKSIZ roundup
dup (aout_size) - BASEM cell+ !
BASEM (aout_size) + 5 cells + here over ! cell+ here swap !
BLKSIZ / (write_image) ;
: (bk) Always hook out to multitasking first
Add offset, quick return if newest block is the one we want
Walk chain, end when we reach last element
If found block with our data...
Move to head of list, and return to caller of caller
: block
Save old contents
Get contents off disk
Update block # for this buffer, return pointer to data
: (buffer?) Return buffer, or 0
: copy Copy contents of one block to another
NOTE: this copies over even the filesystem metadata, if any. Thus, it
will quite likely corrupt your filesystem if used imprudently.
: empty-buffers Clear all buffers
: save-buffers Flush out to disk all dirty buffers
: sync Alias for those of us with checkered pasts...
: flush Save all changes, then clear buffers
Most recently list'ed block
: list List a block (source followed by shadow)
('endScr) Vector invoked at end of parsing of a screen
: (blktib) Point TIB into current block, or TTY buffer
: load Direct input from a block, arranging for proper nesting
So we can see something happening
Save old state
Set prompt to "quiet", saving old prompt
Point input to this block, save old on return stack, set TIB
Iterate across input lines, re-accessing block when needed
Start of next line, process, then advance
Get saved state back from return stack
Restore input state
: thru Load a range of blocks
: --> Chain to next block. Note: consumes stack space, so extensive
use is not recommended.
Massage to walk block range
Progress indicator
Copy, Advance to next block #, drop counters at termination
: clear-blocks Initialize block contents (deprecated by filesystem)
: roundup Round up u1 to an increment of u2 (u2 is a power of two)
: (write_image) Write out an image starting at the given block number
Size of an a.out header
: unexec Copy running user area back to prototype, snapshot restart
Prep call to (write_image), calculate image length in bytes
Write image length (less a.out header) to a.out "textlen"
Write end of memory to multiboot header
Scale image size to 4k block count, write it out