File:
[gforth] /
gforth /
blocks.fs
Revision
1.4:
download - view:
text,
annotated -
select for diffs
Thu Apr 20 09:42:45 1995 UTC (29 years ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added "system documentation requirements" section to gforth.ds.
added answers for environmental queries for wordsets.
changed W/O file access mode from "w+" to "w".
S" now uses a buffer
BIN is now idempotent
added FILE-STATUS
some other minor changes and bug fixes.
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: \ the file is opened as binary file, since it either will contain text
19: \ without newlines or binary data
20: : get-block-fid ( -- fid )
21: block-fid @ 0=
22: if
23: s" blocks.fb" r/w bin open-file 0<>
24: if
25: s" blocks.fb" r/w bin create-file throw
26: then
27: block-fid !
28: then
29: block-fid @ ;
30:
31: : block-position ( u -- )
32: \ positions the block file to the start of block u
33: 1- chars/block chars um* get-block-fid reposition-file throw ;
34:
35: : update ( -- )
36: buffer-dirty on ;
37:
38: : save-buffers ( -- )
39: buffer-dirty @ buffer-block @ 0<> and
40: if
41: buffer-block @ block-position
42: block-buffer chars/block get-block-fid write-file throw
43: buffer-dirty off
44: endif ;
45:
46: : empty-buffers ( -- )
47: 0 buffer-block ! ;
48:
49: : flush ( -- )
50: save-buffers
51: empty-buffers ;
52:
53: : block ( u -- a-addr )
54: dup 0= -35 and throw
55: dup buffer-block @ <>
56: if
57: save-buffers
58: dup block-position
59: block-buffer chars/block get-block-fid read-file throw
60: \ clear the rest of the buffer if the file is too short
61: block-buffer over chars + chars/block rot - blank
62: buffer-block !
63: else
64: drop
65: then
66: block-buffer ;
67:
68: : buffer ( u -- a-addr )
69: \ reading in the block is unnecessary, but simpler
70: block ;
71:
72: User scr 0 scr !
73:
74: : list ( u -- )
75: \ calling block again and again looks inefficient but is necessary
76: \ in a multitasking environment
77: dup scr !
78: ." Screen " u. cr
79: 16 0
80: ?do
81: i 2 .r space scr @ block i 64 * chars + 64 type cr
82: loop ;
83:
84: : (source) ( -- addr len )
85: blk @ ?dup
86: IF block chars/block
87: ELSE tib #tib @
88: THEN ;
89:
90: ' (source) IS source
91:
92: : load ( i*x n -- j*x )
93: push-file
94: dup loadline ! blk ! >in off ( ['] ) interpret ( catch )
95: pop-file ( throw ) ;
96:
97: : thru ( i*x n1 n2 -- j*x )
98: 1+ swap 0 ?DO I load LOOP ;
99:
100: : +load ( i*x n -- j*x ) blk @ + load ;
101:
102: : +thru ( i*x n1 n2 -- j*x )
103: 1+ swap 0 ?DO I +load LOOP ;
104:
105: get-current environment-wordlist set-current
106: true constant block
107: true constant block-ext
108: set-current
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>