Annotation of gforth/blocks.fs, revision 1.1
1.1 ! anton 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>