\ Copyright 2021 Bradley D. Nelson 
\ 
\ Licensed under the Apache License, Version 2.0 (the "License"); 
\ you may not use this file except in compliance with the License. 
\ You may obtain a copy of the License at 
\ 
\     http://www.apache.org/licenses/LICENSE-2.0 
\ 
\ Unless required by applicable law or agreed to in writing, software 
\ distributed under the License is distributed on an "AS IS" BASIS, 
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 
\ See the License for the specific language governing permissions and 
\ limitations under the License. 
 
( Block Files ) 
internals definitions 
: clobber-line ( a -- a' ) dup 63 bl fill 63 + nl over c! 1+ ; 
: clobber ( a -- ) 15 for clobber-line next drop ; 
0 value block-dirty 
create block-data 1024 allot 
forth definitions internals 
 
-1 value block-fid   variable scr   -1 value block-id 
: open-blocks ( a n -- ) 
   block-fid 0< 0= if block-fid close-file throw -1 to block-fid then 
   2dup r/w open-file if drop r/w create-file throw else nip nip then to block-fid ; 
: use ( "name" -- ) bl parse open-blocks ; 
defer default-use 
internals definitions 
: common-default-use s" blocks.fb" open-blocks ; 
' common-default-use is default-use 
: use?!   block-fid 0< if default-use then ; 
: grow-blocks ( n -- ) 1024 * block-fid file-size throw max block-fid resize-file throw ; 
forth definitions internals 
: save-buffers 
   block-dirty if 
     block-id grow-blocks block-id 1024 * block-fid reposition-file throw 
     block-data 1024 block-fid write-file throw 
     block-fid flush-file throw 
     0 to block-dirty 
   then ; 
: block ( n -- a ) use?! dup block-id = if drop block-data exit then 
                   save-buffers dup grow-blocks 
                   dup 1024 * block-fid reposition-file throw 
                   block-data clobber 
                   block-data 1024 block-fid read-file throw drop 
                   to block-id block-data ; 
: buffer ( n -- a ) use?! dup block-id = if drop block-data exit then 
                    save-buffers to block-id block-data ; 
: empty-buffers   -1 to block-id ; 
: update   -1 to block-dirty ; 
: flush   save-buffers empty-buffers ; 
 
( Loading ) 
: load ( n -- ) block 1024 evaluate ; 
: thru ( a b -- ) over - 1+ for aft dup >r load r> 1+ then next drop ; 
 
( Utility ) 
: copy ( from to -- ) 
   swap block pad 1024 cmove pad swap block 1024 cmove update ; 
 
( Editing ) 
: list ( n -- ) scr ! ." Block " scr @ . cr scr @ block 
   15 for dup 63 type [char] | emit space 15 r@ - . cr 64 + next drop ; 
internals definitions 
: @line ( n -- ) 64 * scr @ block + ; 
: e' ( n -- ) @line clobber-line drop update ; 
forth definitions internals 
vocabulary editor   also editor definitions 
: l    scr @ list ;   : n    1 scr +! l ;  : p   -1 scr +! l ; 
: wipe   15 for r@ e' next l ;   : e   e' l ; 
: d ( n -- ) dup 1+ @line swap @line 15 @line over - cmove 15 e ; 
: r ( n "line" -- ) 0 parse 64 min rot dup e @line swap cmove l ; 
: a ( n "line" -- ) dup @line over 1+ @line 16 @line over - cmove> r ; 
only forth definitions 
 

Legal: site web personnel sans commerce / personal site without seling