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>