Diff for /gforth/blocks.fs between versions 1.25 and 1.57

version 1.25, 1999/05/21 20:35:35 version 1.57, 2011/01/19 19:26:03
Line 1 Line 1
 \ A less simple implementation of the blocks wordset.   \ A less simple implementation of the blocks wordset. 
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2006,2007,2008 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
   
   
 \ A more efficient implementation would use mmap on OSs that  \ A more efficient implementation would use mmap on OSs that
Line 44  Variable last-block Line 43  Variable last-block
   
 $20 Value buffers  $20 Value buffers
   
   \ limit block files to 2GB; gforth <0.6.0 erases larger block files on
   \ 32-bit systems
   $200000 Value block-limit
   
 User block-fid  User block-fid
   User block-offset ( -- addr ) \ gforth
   \G User variable containing the number of the first block (default
   \G since 0.5.0: 0).  Block files created with Gforth versions before
   \G 0.5.0 have the offset 1.  If you use these files you can: @code{1
   \G offset !}; or add 1 to every block number used; or prepend 1024
   \G characters to the file.
   0 block-offset !  \ store 1 here fore 0.4.0 compatibility
   
   ' block-offset alias offset \ !! eliminate this?
   
 : block-cold ( -- )  : block-cold ( -- )
     block-fid off  last-block off      block-fid off  last-block off
     buffer-struct buffers * %alloc dup block-buffers ! ( addr )      buffer-struct buffers * %alloc dup block-buffers ! ( addr )
     buffer-struct %size buffers * erase ;      buffer-struct %size buffers * erase ;
   
 ' block-cold INIT8 chained  :noname ( -- )
       defers 'cold
       block-cold
   ; is 'cold
   
 block-cold  block-cold
   
 Defer flush-blocks ( -- ) \ gforth  Defer flush-blocks ( -- ) \ gforth
   
 : open-blocks ( c-addr u -- ) \ gforth  : open-blocks ( c-addr u -- ) \ gforth
     \g Use the file, whose name is given by @i{c-addr u}, as the blocks file.  \g Use the file, whose name is given by @i{c-addr u}, as the blocks file.
     2dup open-fpath-file 0<>      try ( c-addr u )
     if          2dup open-fpath-file throw
         r/w bin create-file throw  
     else  
         rot close-file throw  2dup file-status throw bin open-file throw          rot close-file throw  2dup file-status throw bin open-file throw
         >r 2drop r>          >r 2drop r>
       endtry-iferror ( c-addr u ior )
           >r 2dup file-status nip 0= r> and throw \ does it really not exist?
           r/w bin create-file throw
     then      then
     block-fid @ IF  flush-blocks block-fid @ close-file throw  THEN      block-fid @ IF
           flush-blocks block-fid @ close-file throw
       THEN
     block-fid ! ;      block-fid ! ;
   
 : use ( "file" -- ) \ gforth  : use ( "file" -- ) \ gforth
Line 86  Defer flush-blocks ( -- ) \ gforth Line 104  Defer flush-blocks ( -- ) \ gforth
     block-fid @ ;      block-fid @ ;
   
 : block-position ( u -- ) \ block  : block-position ( u -- ) \ block
     \G Position the block file to the start of block @i{u}.  \G Position the block file to the start of block @i{u}.
     1- chars/block chars um* get-block-fid reposition-file throw ;      dup block-limit u>= -35 and throw
       offset @ - chars/block chars um* get-block-fid reposition-file throw ;
   
 : update ( -- ) \ block  : update ( -- ) \ block
     \G Mark the current block buffer as dirty.      \G Mark the state of the current block buffer as assigned-dirty.
     last-block @ ?dup IF  buffer-dirty on  THEN ;      last-block @ ?dup IF  buffer-dirty on  THEN ;
   
 : save-buffer ( buffer -- ) \ gforth  : save-buffer ( buffer -- ) \ gforth
     >r      >r
     r@ buffer-dirty @ r@ buffer-block @ 0<> and      r@ buffer-dirty @
     if      if
         r@ buffer-block @ block-position          r@ buffer-block @ block-position
         r@ block-buffer chars/block  r@ buffer-fid @  write-file throw          r@ block-buffer chars/block  r@ buffer-fid @  write-file throw
         r@ buffer-dirty off          r@ buffer-fid @ flush-file throw
           r@ buffer-dirty off 
     endif      endif
     rdrop ;      rdrop ;
   
 : empty-buffer ( buffer -- ) \ gforth  : empty-buffer ( buffer -- ) \ gforth
     buffer-block off ;      dup buffer-block on buffer-dirty off ;
   
 : save-buffers  ( -- ) \ block  : save-buffers  ( -- ) \ block
     \G Transfer the contents of each @code{update}d block buffer to      \G Transfer the contents of each @code{update}d block buffer to
     \G mass storage, then mark all block buffers as unassigned.      \G mass storage, then mark all block buffers as assigned-clean.
     block-buffers @      block-buffers @
     buffers 0 ?DO dup save-buffer next-buffer LOOP drop ;      buffers 0 ?DO dup save-buffer next-buffer LOOP drop ;
   
Line 127  Defer flush-blocks ( -- ) \ gforth Line 147  Defer flush-blocks ( -- ) \ gforth
   
 ' flush IS flush-blocks  ' flush IS flush-blocks
   
 : get-buffer ( n -- a-addr ) \ gforth  : get-buffer ( u -- a-addr ) \ gforth
     buffers mod buffer-struct %size * block-buffers @ + ;      0 buffers um/mod drop buffer-struct %size * block-buffers @ + ;
   
 : block ( u -- a-addr ) \ block- block  : block ( u -- a-addr ) \ block
     \G If a block buffer is assigned for block @i{u}, return its      \G If a block buffer is assigned for block @i{u}, return its
     \G start address, @i{a-addr}. Otherwise, assign a block buffer      \G start address, @i{a-addr}. Otherwise, assign a block buffer
     \G for block @i{u} (if the assigned block buffer has been      \G for block @i{u} (if the assigned block buffer has been
     \G @code{update}d, transfer the contents to mass storage), read      \G @code{update}d, transfer the contents to mass storage), read
     \G the block into the block buffer and return its start address,      \G the block into the block buffer and return its start address,
     \G @i{a-addr}.      \G @i{a-addr}.
     dup 0= -35 and throw      dup offset @ u< -35 and throw
     dup get-buffer >r      dup get-buffer >r
     dup r@ buffer-block @ <>      dup r@ buffer-block @ <>
     r@ buffer-fid @ block-fid @ <> or      r@ buffer-fid @ block-fid @ <> or
Line 167  Defer flush-blocks ( -- ) \ gforth Line 187  Defer flush-blocks ( -- ) \ gforth
     \ reading in the block is unnecessary, but simpler      \ reading in the block is unnecessary, but simpler
     block ;      block ;
   
 User scr ( -- a-addr ) \ block-ext  User scr ( -- a-addr ) \ block-ext s-c-r
     \G USER VARIABLE: @i{a-addr} is the address of a cell containing      \G @code{User} variable -- @i{a-addr} is the address of a cell containing
     \G the block number of the block most recently processed by      \G the block number of the block most recently processed by
     \G @code{list}.      \G @code{list}.
 0 scr !  0 scr !
   
 \ nac31Mar1999 moved "scr @" to list to make the stack comment correct  \ nac31Mar1999 moved "scr @" to list to make the stack comment correct
 : updated?  ( n -- f ) \ gforth  : updated?  ( n -- f ) \ gforth
     \G Return true if block @i{n} has been marked as dirty.      \G Return true if @code{updated} has been used to mark block @i{n}
       \G as assigned-dirty.
     buffer      buffer
     [ 0 buffer-dirty 0 block-buffer - ] Literal + @ ;      [ 0 buffer-dirty 0 block-buffer - ] Literal + @ ;
   
Line 192  User scr ( -- a-addr ) \ block-ext Line 213  User scr ( -- a-addr ) \ block-ext
         i 2 .r space scr @ block i 64 * chars + 64 type cr          i 2 .r space scr @ block i 64 * chars + 64 type cr
     loop ;      loop ;
   
   [IFDEF] current-input
   :noname  2 <> -12 and throw >in ! blk ! ;
                                 \ restore-input
   :noname  blk @ >in @ 2 ;      \ save-input
   :noname  2 ;                  \ source-id "*a block*"
   :noname  1 blk +! 1 loadline +! >in off true ;      \ refill
   :noname  blk @ block chars/block ;  \ source
   
   Create block-input   A, A, A, A, A,
   
   : load  ( i*x u -- j*x ) \ block
       \g Text-interpret block @i{u}.  Block 0 cannot be @code{load}ed.
       dup 0= -35 and throw
       block-input 0 new-tib dup loadline ! blk !  s" * a block*" loadfilename 2!
       ['] interpret catch pop-file throw ;
   [ELSE]
 : (source)  ( -- c-addr u )  : (source)  ( -- c-addr u )
   blk @ ?dup    blk @ ?dup
   IF    block chars/block    IF    block chars/block
Line 202  User scr ( -- a-addr ) \ block-ext Line 239  User scr ( -- a-addr ) \ block-ext
 \G @i{c-addr} is the address of the input buffer and @i{u} is the  \G @i{c-addr} is the address of the input buffer and @i{u} is the
 \G number of characters in it.  \G number of characters in it.
   
 : load ( i*x n -- j*x ) \ block  : load ( i*x u -- j*x ) \ block
     \G Save the current input source specification. Store @i{n} in      \g Text-interpret block @i{u}.  Block 0 cannot be @code{load}ed.
     \G @code{BLK}, set @code{>IN} to 0 and interpret. When the parse      dup 0= -35 and throw
     \G area is exhausted, restore the input source specification.      s" * a block*" loadfilename>r
     push-file      push-file
     dup loadline ! blk ! >in off ['] interpret catch      dup loadline ! blk ! >in off ['] interpret catch
     pop-file throw ;      pop-file
       r>loadfilename
       throw ;
   [THEN]
   
 : thru ( i*x n1 n2 -- j*x ) \ block-ext  : thru ( i*x n1 n2 -- j*x ) \ block-ext
     \G @code{load} the blocks @i{n1} through @i{n2} in sequence.      \G @code{load} the blocks @i{n1} through @i{n2} in sequence.
Line 224  User scr ( -- a-addr ) \ block-ext Line 264  User scr ( -- a-addr ) \ block-ext
     \G current block + @i{n1} thru the current block + @i{n2}.      \G current block + @i{n1} thru the current block + @i{n2}.
     1+ swap ?DO  I +load  LOOP ;      1+ swap ?DO  I +load  LOOP ;
   
 : --> ( -- ) \ gforth- gforth chain  : --> ( -- ) \ gforthman- gforth chain
     \G If this symbol is encountered whilst loading block @i{n},      \G If this symbol is encountered whilst loading block @i{n},
     \G discard the remainder of the block and load block @i{n+1}. Used      \G discard the remainder of the block and load block @i{n+1}. Used
     \G for chaining multiple blocks together as a single loadable      \G for chaining multiple blocks together as a single loadable
Line 249  User scr ( -- a-addr ) \ block-ext Line 289  User scr ( -- a-addr ) \ block-ext
 \     0= IF  block-included  ELSE  included  THEN ;  \     0= IF  block-included  ELSE  included  THEN ;
   
 get-current environment-wordlist set-current  get-current environment-wordlist set-current
 true constant block  true constant block \ environment- environment
 true constant block-ext  true constant block-ext
 set-current  set-current
   

Removed from v.1.25  
changed lines
  Added in v.1.57


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>