--- gforth/blocks.fs	1995/09/06 21:00:10	1.6
+++ gforth/blocks.fs	1999/02/03 00:10:19	1.21
@@ -1,6 +1,25 @@
 \ A less simple implementation of the blocks wordset. 
 
-\ An more efficient implementation would use mmap on OSs that
+\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+\ This file is part of Gforth.
+
+\ Gforth is free software; you can redistribute it and/or
+\ modify it under the terms of the GNU General Public License
+\ as published by the Free Software Foundation; either version 2
+\ of the License, or (at your option) any later version.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+\ GNU General Public License for more details.
+
+\ You should have received a copy of the GNU General Public License
+\ along with this program; if not, write to the Free Software
+\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+\ A more efficient implementation would use mmap on OSs that
 \ provide it and many buffers on OSs that do not provide mmap.
 
 \ Now, the replacement algorithm is "direct mapped"; change to LRU
@@ -13,11 +32,11 @@
 require struct.fs
 
 struct
-    1           cells: field buffer-block   \ the block number
-    1           cells: field buffer-fid     \ the block's fid
-    1           cells: field buffer-dirty   \ the block dirty flag
-    chars/block chars: field block-buffer   \ the data
-    0           cells: field next-buffer
+    cell%		field buffer-block   \ the block number
+    cell%		field buffer-fid     \ the block's fid
+    cell%		field buffer-dirty   \ the block dirty flag
+    char% chars/block * field block-buffer   \ the data
+    cell% 0 *		field next-buffer
 end-struct buffer-struct
 
 Variable block-buffers
@@ -27,44 +46,51 @@ $20 Value buffers
 
 User block-fid
 
-: block-cold
-    defers 'cold  block-fid off  last-block off
-    buffers buffer-struct drop * allocate throw dup block-buffers !
-    buffers buffer-struct drop * erase ;
+: block-cold ( -- )
+    block-fid off  last-block off
+    buffer-struct buffers * %alloc dup block-buffers ! ( addr )
+    buffer-struct %size buffers * erase ;
 
-' block-cold IS 'cold
+' block-cold INIT8 chained
 
 block-cold
 
-Defer flush-file
+Defer flush-blocks
 
-: use-file ( addr u -- )
-    2dup r/w bin open-file 0<>
+: open-blocks ( addr u -- ) \ gforth
+    \g use the file, whose name is given by @var{addr u}, as blocks file 
+    2dup open-fpath-file 0<>
     if
-	drop r/w bin create-file throw
+	r/w bin create-file throw
     else
-	nip nip
+	rot close-file throw  2dup file-status throw bin open-file throw
+	>r 2drop r>
     then
-    block-fid @ IF  flush-file block-fid @ close-file throw  THEN
+    block-fid @ IF  flush-blocks block-fid @ close-file throw  THEN
     block-fid ! ;
 
+: use ( "file" -- ) \ gforth
+    \g use @var{file} as blocks file
+    name open-blocks ;
+
 \ the file is opened as binary file, since it either will contain text
 \ without newlines or binary data
-: get-block-fid ( -- fid )
+: get-block-fid ( -- fid ) \ gforth
     block-fid @ 0=
     if
-	s" blocks.fb" use-file
+	s" blocks.fb" open-blocks
     then
     block-fid @ ;
 
-: block-position ( u -- )
-    \ positions the block file to the start of block u
+: block-position ( u -- ) \ block
+    \G Position the block file to the start of block u.
     1- chars/block chars um* get-block-fid reposition-file throw ;
 
-: update ( -- )
+: update ( -- ) \ block
     last-block @ ?dup IF  buffer-dirty on  THEN ;
 
-: save-buffer ( buffer -- ) >r
+: save-buffer ( buffer -- ) \ gforth
+    >r
     r@ buffer-dirty @ r@ buffer-block @ 0<> and
     if
 	r@ buffer-block @ block-position
@@ -73,29 +99,34 @@ Defer flush-file
     endif
     rdrop ;
 
-: empty-buffer ( buffer -- )
+: empty-buffer ( buffer -- ) \ gforth
     buffer-block off ;
 
-: save-buffers  ( -- )    block-buffers @
+: save-buffers  ( -- ) \ block
+    block-buffers @
     buffers 0 ?DO  dup save-buffer  next-buffer  LOOP  drop ;
 
-: empty-buffers ( -- )    block-buffers @
+: empty-buffers ( -- ) \ block
+    block-buffers @
     buffers 0 ?DO  dup empty-buffer  next-buffer  LOOP  drop ;
 
-: flush ( -- )
+: flush ( -- ) \ block
     save-buffers
     empty-buffers ;
 
-' flush IS flush-file
+' flush IS flush-blocks
 
-: get-buffer ( n -- a-addr )
-    buffers mod buffer-struct drop * block-buffers @ + ;
+: get-buffer ( n -- a-addr ) \ gforth
+    buffers mod buffer-struct %size * block-buffers @ + ;
 
-: block ( u -- a-addr )
+: block ( u -- a-addr ) \ block- block
+  \G u identifies a block number. Assign a block buffer to u,
+  \G make it the current block buffer and return its start
+  \G address, a-addr.
     dup 0= -35 and throw
     dup get-buffer >r
     dup r@ buffer-block @ <>
-    r@ buffer-fid @ block-fid @ <> and
+    r@ buffer-fid @ block-fid @ <> or
     if
 	r@ save-buffer
 	dup block-position
@@ -109,16 +140,21 @@ Defer flush-file
     then
     r> dup last-block ! block-buffer ;
 
-: buffer ( u -- a-addr )
+: buffer ( u -- a-addr ) \ block
     \ reading in the block is unnecessary, but simpler
     block ;
 
-User scr 0 scr !
+User scr ( -- a-addr ) \ block-ext
+    \G USER VARIABLE a-addr is the address of a cell containing
+    \G the block number of the block most recently processed by
+    \G @code{LIST}.
+    0 scr !
 
-: updated?  ( n -- f )   scr @ buffer
+: updated?  ( n -- f ) \ gforth
+    scr @ buffer
     [ 0 buffer-dirty 0 block-buffer - ] Literal + @ ;
 
-: list ( u -- )
+: list ( u -- ) \ block
     \ calling block again and again looks inefficient but is necessary
     \ in a multitasking environment
     dup scr !
@@ -137,33 +173,41 @@ User scr 0 scr !
 
 ' (source) IS source
 
-: load ( i*x n -- j*x )
+: load ( i*x n -- j*x ) \ block
   push-file
-  dup loadline ! blk ! >in off ( ['] ) interpret ( catch )
-  pop-file ( throw ) ;
-
-: thru ( i*x n1 n2 -- j*x )
-  1+ swap 0 ?DO  I load  LOOP ;
+  dup loadline ! blk ! >in off ['] interpret catch
+  pop-file throw ;
 
-: +load ( i*x n -- j*x )  blk @ + load ;
+: thru ( i*x n1 n2 -- j*x ) \ block
+  1+ swap ?DO  I load  LOOP ;
 
-: +thru ( i*x n1 n2 -- j*x )
-  1+ swap 0 ?DO  I +load  LOOP ;
+: +load ( i*x n -- j*x ) \ block
+    blk @ + load ;
 
-: --> ( -- )  refill drop ; immediate
+: +thru ( i*x n1 n2 -- j*x ) \ block
+  1+ swap ?DO  I +load  LOOP ;
+
+: --> ( -- ) \ block- block
+    \G If this symbol is encountered whilst loading block @var{n},
+    \G discard the remainder of the block and load block @var{n+1}. Used
+    \G for chaining multiple blocks together as a single loadable unit.
+    refill drop ; immediate
 
-: block-included ( addr u -- )
-    block-fid @ >r block-fid off use-file
+: block-included ( addr u -- ) \ gforth
+    block-fid @ >r block-fid off open-blocks
     1 load block-fid @ close-file throw flush
     r> block-fid ! ;
 
-: include ( "name" -- )
-    name 2dup dup 3 - /string s" .fb" compare
-    0= IF  block-included  ELSE  included  THEN ;
+\ thrown out because it may provide unpleasant surprises - anton
+\ : include ( "name" -- )
+\     name 2dup dup 3 - /string s" .fb" compare
+\     0= IF  block-included  ELSE  included  THEN ;
 
 get-current environment-wordlist set-current
 true constant block
 true constant block-ext
 set-current
 
-: bye  ['] flush catch drop bye ;
\ No newline at end of file
+: bye ( -- ) \ tools-ext
+  \G Return control to the host operating system (if any).
+  ['] flush catch drop bye ;