version 1.1, 1994/08/10 17:22:35
|
version 1.4, 1995/04/20 09:42:45
|
Line 6
|
Line 6
|
|
|
\ I think I avoid the assumption 1 char = 1 here, but I have not tested this |
\ I think I avoid the assumption 1 char = 1 here, but I have not tested this |
|
|
1024 constant chars/block \ mandated by the standard |
\ 1024 constant chars/block \ mandated by the standard |
|
|
create block-buffer chars/block chars allot |
create block-buffer chars/block chars allot |
|
|
Line 15 variable block-fid 0 block-fid ! \ the f
|
Line 15 variable block-fid 0 block-fid ! \ the f
|
variable buffer-dirty buffer-dirty off |
variable buffer-dirty buffer-dirty off |
|
|
|
|
|
\ the file is opened as binary file, since it either will contain text |
|
\ without newlines or binary data |
: get-block-fid ( -- fid ) |
: get-block-fid ( -- fid ) |
block-fid @ 0= |
block-fid @ 0= |
if |
if |
s" blocks.fb" r/w open-file 0<> |
s" blocks.fb" r/w bin open-file 0<> |
if |
if |
s" blocks.fb" r/w create-file .s throw |
s" blocks.fb" r/w bin create-file throw |
then |
then |
block-fid ! |
block-fid ! |
then |
then |
Line 28 variable buffer-dirty buffer-dirty off
|
Line 30 variable buffer-dirty buffer-dirty off
|
|
|
: block-position ( u -- ) |
: block-position ( u -- ) |
\ positions the block file to the start of block u |
\ positions the block file to the start of block u |
1- chars/block chars um* get-block-fid reposition-file .s throw ; |
1- chars/block chars um* get-block-fid reposition-file throw ; |
|
|
: update ( -- ) |
: update ( -- ) |
buffer-dirty on ; |
buffer-dirty on ; |
|
|
: save-buffers ( -- ) |
: save-buffers ( -- ) |
buffer-dirty @ |
buffer-dirty @ buffer-block @ 0<> and |
if |
if |
buffer-block @ block-position |
buffer-block @ block-position |
block-buffer chars/block get-block-fid write-file throw |
block-buffer chars/block get-block-fid write-file throw |
Line 54 variable buffer-dirty buffer-dirty off
|
Line 56 variable buffer-dirty buffer-dirty off
|
if |
if |
save-buffers |
save-buffers |
dup block-position |
dup block-position |
block-buffer chars/block get-block-fid read-file .s throw |
block-buffer chars/block get-block-fid read-file throw |
\ clear the rest of the buffer if the file is too short |
\ clear the rest of the buffer if the file is too short |
block-buffer over chars + chars/block rot - blank |
block-buffer over chars + chars/block rot - blank |
buffer-block ! |
buffer-block ! |
Line 67 variable buffer-dirty buffer-dirty off
|
Line 69 variable buffer-dirty buffer-dirty off
|
\ reading in the block is unnecessary, but simpler |
\ reading in the block is unnecessary, but simpler |
block ; |
block ; |
|
|
variable scr 0 scr ! \ !! this should be a user var |
User scr 0 scr ! |
|
|
: list ( u -- ) |
: list ( u -- ) |
\ calling block again and again looks inefficient but is necessary |
\ calling block again and again looks inefficient but is necessary |
Line 76 variable scr 0 scr ! \ !! this should be
|
Line 78 variable scr 0 scr ! \ !! this should be
|
." Screen " u. cr |
." Screen " u. cr |
16 0 |
16 0 |
?do |
?do |
scr @ block i 64 * chars + 64 type cr |
i 2 .r space scr @ block i 64 * chars + 64 type cr |
loop ; |
loop ; |
|
|
|
: (source) ( -- addr len ) |
\ not yet implemented (with block semantics): |
blk @ ?dup |
|
IF block chars/block |
\ evaluate |
ELSE tib #tib @ |
\ load |
THEN ; |
\ refill |
|
\ thru |
' (source) IS source |
\ \ |
|
|
: load ( i*x n -- j*x ) |
|
push-file |
|
dup loadline ! blk ! >in off ( ['] ) interpret ( catch ) |
|
pop-file ( throw ) ; |
|
|
|
: thru ( i*x n1 n2 -- j*x ) |
|
1+ swap 0 ?DO I load LOOP ; |
|
|
|
: +load ( i*x n -- j*x ) blk @ + load ; |
|
|
|
: +thru ( i*x n1 n2 -- j*x ) |
|
1+ swap 0 ?DO I +load LOOP ; |
|
|
|
get-current environment-wordlist set-current |
|
true constant block |
|
true constant block-ext |
|
set-current |