\ 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 blank 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
