Re-root site.

common/blocks.fs

@@ -0,0 +1,75 @@
+\ 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