Return to blocks.fs CVS log

Up to [gforth] / gforth

added "system documentation requirements" section to gforth.ds.
added answers for environmental queries for wordsets.
changed W/O file access mode from "w+" to "w".
S" now uses a buffer
BIN is now idempotent
added FILE-STATUS
some other minor changes and bug fixes.

    1: \ A simple immplementation of the blocks wordset. 
    2: 
    3: \ This implementation uses only a single buffer and will therefore be a
    4: \ little slow. An efficient implementation would use mmap on OSs that
    5: \ provide it and many buffers on OSs that do not provide mmap.
    6: 
    7: \ I think I avoid the assumption 1 char = 1 here, but I have not tested this
    8: 
    9: \ 1024 constant chars/block \ mandated by the standard
   10: 
   11: create block-buffer chars/block chars allot
   12: 
   13: variable buffer-block 0 buffer-block ! \ the block currently in the buffer
   14: variable block-fid 0 block-fid ! \ the file id of the current block file
   15: variable buffer-dirty buffer-dirty off
   16: 
   17: 
   18: \ the file is opened as binary file, since it either will contain text
   19: \ without newlines or binary data
   20: : get-block-fid ( -- fid )
   21:     block-fid @ 0=
   22:     if
   23: 	s" blocks.fb" r/w bin open-file 0<>
   24: 	if
   25: 	    s" blocks.fb" r/w bin create-file throw
   26: 	then
   27: 	block-fid !
   28:     then
   29:     block-fid @ ;
   30: 
   31: : block-position ( u -- )
   32:     \ positions the block file to the start of block u
   33:     1- chars/block chars um* get-block-fid reposition-file throw ;
   34: 
   35: : update ( -- )
   36:     buffer-dirty on ;
   37: 
   38: : save-buffers ( -- )
   39:     buffer-dirty @ buffer-block @ 0<> and
   40:     if
   41: 	buffer-block @ block-position
   42: 	block-buffer chars/block get-block-fid write-file throw
   43: 	buffer-dirty off
   44:     endif ;
   45: 
   46: : empty-buffers ( -- )
   47:     0 buffer-block ! ;
   48: 
   49: : flush ( -- )
   50:     save-buffers
   51:     empty-buffers ;
   52: 
   53: : block ( u -- a-addr )
   54:     dup 0= -35 and throw
   55:     dup buffer-block @ <>
   56:     if
   57: 	save-buffers
   58: 	dup block-position
   59: 	block-buffer chars/block get-block-fid read-file throw
   60: 	\ clear the rest of the buffer if the file is too short
   61: 	block-buffer over chars + chars/block rot - blank
   62: 	buffer-block !    
   63:     else
   64: 	drop
   65:     then
   66:     block-buffer ;
   67: 
   68: : buffer ( u -- a-addr )
   69:     \ reading in the block is unnecessary, but simpler
   70:     block ;
   71: 
   72: User scr 0 scr !
   73: 
   74: : list ( u -- )
   75:     \ calling block again and again looks inefficient but is necessary
   76:     \ in a multitasking environment
   77:     dup scr !
   78:     ." Screen " u. cr
   79:     16 0
   80:     ?do
   81: 	i 2 .r space scr @ block i 64 * chars + 64 type cr
   82:     loop ;
   83: 
   84: : (source)  ( -- addr len )
   85:   blk @ ?dup
   86:   IF    block chars/block
   87:   ELSE  tib #tib @
   88:   THEN ;
   89: 
   90: ' (source) IS source
   91: 
   92: : load ( i*x n -- j*x )
   93:   push-file
   94:   dup loadline ! blk ! >in off ( ['] ) interpret ( catch )
   95:   pop-file ( throw ) ;
   96: 
   97: : thru ( i*x n1 n2 -- j*x )
   98:   1+ swap 0 ?DO  I load  LOOP ;
   99: 
  100: : +load ( i*x n -- j*x )  blk @ + load ;
  101: 
  102: : +thru ( i*x n1 n2 -- j*x )
  103:   1+ swap 0 ?DO  I +load  LOOP ;
  104: 
  105: get-current environment-wordlist set-current
  106: true constant block
  107: true constant block-ext
  108: set-current