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: User scr 0 scr !
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: : (source) ( -- addr len )
83: blk @ ?dup
84: IF block chars/block
85: ELSE tib #tib @
86: THEN ;
87:
88: ' (source) IS source
89:
90: : load ( i*x n -- j*x )
91: push-file
92: dup loadline ! blk ! >in off ( ['] ) interpret ( catch )
93: pop-file ( throw ) ;
94:
95: : thru ( i*x n1 n2 -- j*x )
96: 1+ swap 0 ?DO I load LOOP ;
97:
98: : +load ( i*x n -- j*x ) blk @ + load ;
99:
100: : +thru ( i*x n1 n2 -- j*x )
101: 1+ swap 0 ?DO I +load LOOP ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>