Annotation of gforth/blocks.fs, revision 1.5
1.5 ! pazsan 1: \ A less simple implementation of the blocks wordset.
1.1 anton 2:
1.5 ! pazsan 3: \ An more efficient implementation would use mmap on OSs that
1.1 anton 4: \ provide it and many buffers on OSs that do not provide mmap.
5:
1.5 ! pazsan 6: \ Now, the replacement algorithm is "direct mapped"; change to LRU
! 7: \ if too slow. Using more buffers helps, too.
! 8:
1.1 anton 9: \ I think I avoid the assumption 1 char = 1 here, but I have not tested this
10:
1.2 pazsan 11: \ 1024 constant chars/block \ mandated by the standard
1.1 anton 12:
1.5 ! pazsan 13: require struct.fs
! 14:
! 15: struct
! 16: 1 cells: field buffer-block \ the block number
! 17: 1 cells: field buffer-fid \ the block's fid
! 18: 1 cells: field buffer-dirty \ the block dirty flag
! 19: chars/block chars: field block-buffer \ the data
! 20: 0 cells: field next-buffer
! 21: end-struct buffer-struct
! 22:
! 23: Variable block-buffers
! 24: Variable last-block
! 25:
! 26: $20 Value buffers
! 27:
! 28: User block-fid
1.1 anton 29:
1.5 ! pazsan 30: : block-cold
! 31: defers 'cold block-fid off last-block off
! 32: buffers buffer-struct drop * allocate throw dup block-buffers !
! 33: buffers buffer-struct drop * erase ;
1.1 anton 34:
1.5 ! pazsan 35: ' block-cold IS 'cold
! 36:
! 37: block-cold
! 38:
! 39: Defer flush-file
! 40:
! 41: : use-file ( addr u -- )
! 42: block-fid @ IF flush-file block-fid @ close-file throw THEN
! 43: 2dup r/w bin open-file 0<>
! 44: if
! 45: drop r/w bin create-file throw
! 46: else
! 47: nip nip
! 48: then
! 49: block-fid ! ;
1.1 anton 50:
1.3 anton 51: \ the file is opened as binary file, since it either will contain text
52: \ without newlines or binary data
1.1 anton 53: : get-block-fid ( -- fid )
54: block-fid @ 0=
55: if
1.5 ! pazsan 56: s" blocks.fb" use-file
1.1 anton 57: then
58: block-fid @ ;
59:
60: : block-position ( u -- )
61: \ positions the block file to the start of block u
1.3 anton 62: 1- chars/block chars um* get-block-fid reposition-file throw ;
1.1 anton 63:
64: : update ( -- )
1.5 ! pazsan 65: last-block @ ?dup IF buffer-dirty on THEN ;
1.1 anton 66:
1.5 ! pazsan 67: : save-buffer ( buffer -- ) >r
! 68: r@ buffer-dirty @ r@ buffer-block @ 0<> and
1.1 anton 69: if
1.5 ! pazsan 70: r@ buffer-block @ block-position
! 71: r@ block-buffer chars/block r@ buffer-fid @ write-file throw
! 72: r@ buffer-dirty off
! 73: endif
! 74: rdrop ;
! 75:
! 76: : empty-buffer ( buffer -- )
! 77: buffer-block off ;
! 78:
! 79: : save-buffers ( -- ) block-buffers @
! 80: buffers 0 ?DO dup save-buffer next-buffer LOOP drop ;
1.1 anton 81:
1.5 ! pazsan 82: : empty-buffers ( -- ) block-buffers @
! 83: buffers 0 ?DO dup empty-buffer next-buffer LOOP drop ;
1.1 anton 84:
85: : flush ( -- )
86: save-buffers
87: empty-buffers ;
88:
1.5 ! pazsan 89: ' flush IS flush-file
! 90:
! 91: : get-buffer ( n -- a-addr )
! 92: buffers mod buffer-struct drop * block-buffers @ + ;
! 93:
1.1 anton 94: : block ( u -- a-addr )
95: dup 0= -35 and throw
1.5 ! pazsan 96: dup get-buffer >r
! 97: dup r@ buffer-block @ <>
! 98: r@ buffer-fid @ block-fid @ <> and
1.1 anton 99: if
1.5 ! pazsan 100: r@ save-buffer
1.1 anton 101: dup block-position
1.5 ! pazsan 102: r@ block-buffer chars/block get-block-fid read-file throw
1.1 anton 103: \ clear the rest of the buffer if the file is too short
1.5 ! pazsan 104: r@ block-buffer over chars + chars/block rot chars - blank
! 105: r@ buffer-block !
! 106: get-block-fid r@ buffer-fid !
1.1 anton 107: else
108: drop
109: then
1.5 ! pazsan 110: r> dup last-block ! block-buffer ;
1.1 anton 111:
112: : buffer ( u -- a-addr )
113: \ reading in the block is unnecessary, but simpler
114: block ;
115:
1.2 pazsan 116: User scr 0 scr !
1.1 anton 117:
1.5 ! pazsan 118: : updated? ( n -- f ) scr @ buffer
! 119: [ 0 buffer-dirty 0 block-buffer - ] Literal + @ ;
! 120:
1.1 anton 121: : list ( u -- )
122: \ calling block again and again looks inefficient but is necessary
123: \ in a multitasking environment
124: dup scr !
1.5 ! pazsan 125: ." Screen " u.
! 126: updated? 0= IF ." not " THEN ." modified " cr
1.1 anton 127: 16 0
128: ?do
1.4 anton 129: i 2 .r space scr @ block i 64 * chars + 64 type cr
1.1 anton 130: loop ;
131:
1.2 pazsan 132: : (source) ( -- addr len )
133: blk @ ?dup
134: IF block chars/block
135: ELSE tib #tib @
136: THEN ;
137:
138: ' (source) IS source
139:
140: : load ( i*x n -- j*x )
141: push-file
142: dup loadline ! blk ! >in off ( ['] ) interpret ( catch )
143: pop-file ( throw ) ;
1.1 anton 144:
1.2 pazsan 145: : thru ( i*x n1 n2 -- j*x )
146: 1+ swap 0 ?DO I load LOOP ;
1.1 anton 147:
1.2 pazsan 148: : +load ( i*x n -- j*x ) blk @ + load ;
149:
150: : +thru ( i*x n1 n2 -- j*x )
151: 1+ swap 0 ?DO I +load LOOP ;
1.4 anton 152:
1.5 ! pazsan 153: : --> ( -- ) refill drop ; immediate
! 154:
! 155: : block-included ( addr u -- )
! 156: block-fid @ >r block-fid off use-file
! 157: 1 load block-fid @ close-file throw flush
! 158: r> block-fid ! ;
! 159:
! 160: : include ( "name" -- )
! 161: name 2dup dup 3 - /string s" .fb" compare
! 162: 0= IF block-included ELSE included THEN ;
! 163:
1.4 anton 164: get-current environment-wordlist set-current
165: true constant block
166: true constant block-ext
167: set-current
1.5 ! pazsan 168:
! 169: : bye ['] flush catch drop bye ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>