File:  [gforth] / gforth / blocks.fs
Revision 1.1: download - view: text, annotated - select for diffs
Wed Aug 10 17:22:35 1994 UTC (24 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added blocks.fs
improved indentation in gforth.el

    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: : get-block-fid ( -- fid )
   19:     block-fid @ 0=
   20:     if
   21: 	s" blocks.fb" r/w open-file 0<>
   22: 	if
   23: 	    s" blocks.fb" r/w create-file .s throw
   24: 	then
   25: 	block-fid !
   26:     then
   27:     block-fid @ ;
   28: 
   29: : block-position ( u -- )
   30:     \ positions the block file to the start of block u
   31:     1- chars/block chars um* get-block-fid reposition-file .s throw ;
   32: 
   33: : update ( -- )
   34:     buffer-dirty on ;
   35: 
   36: : save-buffers ( -- )
   37:     buffer-dirty @
   38:     if
   39: 	buffer-block @ block-position
   40: 	block-buffer chars/block get-block-fid write-file throw
   41: 	buffer-dirty off
   42:     endif ;
   43: 
   44: : empty-buffers ( -- )
   45:     0 buffer-block ! ;
   46: 
   47: : flush ( -- )
   48:     save-buffers
   49:     empty-buffers ;
   50: 
   51: : block ( u -- a-addr )
   52:     dup 0= -35 and throw
   53:     dup buffer-block @ <>
   54:     if
   55: 	save-buffers
   56: 	dup block-position
   57: 	block-buffer chars/block get-block-fid read-file .s throw
   58: 	\ clear the rest of the buffer if the file is too short
   59: 	block-buffer over chars + chars/block rot - blank
   60: 	buffer-block !    
   61:     else
   62: 	drop
   63:     then
   64:     block-buffer ;
   65: 
   66: : buffer ( u -- a-addr )
   67:     \ reading in the block is unnecessary, but simpler
   68:     block ;
   69: 
   70: variable scr 0 scr ! \ !! this should be a user var
   71: 
   72: : list ( u -- )
   73:     \ calling block again and again looks inefficient but is necessary
   74:     \ in a multitasking environment
   75:     dup scr !
   76:     ." Screen " u. cr
   77:     16 0
   78:     ?do
   79: 	scr @ block i 64 * chars + 64 type cr
   80:     loop ;
   81: 
   82: 
   83: \ not yet implemented (with block semantics):
   84: 
   85: \ evaluate
   86: \ load
   87: \ refill
   88: \ thru
   89: \ \

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