\ < 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  ;
\needs d=	: d=	( d1 d2 -- 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 * ;

\ < 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	postpone \
	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
