LithosAnanake/v4/capsule/blocks.v4

\ blocks.v4 -- mass storage: blocks of 1024 characters, and text loaded from them.
\
\ DECOMPOSITION.md 5.11, FORTH-79: BLOCK BUFFER UPDATE SAVE-BUFFERS
\ EMPTY-BUFFERS LIST LOAD SCR BLK, and v3's FLUSH THRU and --> .  Part of the
\ compiler capsule; rests on everything before it.
\
\ STORAGE IS THE KERNEL'S (docs/v4.0.0/MESH.md section 8, ENGINE.md 3.3), as
\ it is for a v3 VM.  A node only ever asks for a block by number, and it
\ asks its kernel: it writes a request to port 0, where its kernel is, and
\ when the write has been served the answer is on the data stack.  The
\ node has a window in its memory, four slots of 256 cells; the kernel
\ keeps the record of which block is in which slot, does the copying, and
\ decides when a block is written.  The requests (v4/include/v4/blocks.h):
\   BLOCK#          ( n -- waddr status )   the slot holding block n
\   BUFFER#         ( n -- waddr status )   a slot for block n, not read
\   UPDATE#         ( -- status )           the block last asked for is changed
\   SAVE-BUFFERS#   ( -- status )           every changed block is written
\   EMPTY-BUFFERS#  ( -- )                  every slot is let go
\ The status is 0, or 2 storage refused (error 17), or 3 there is no such
\ block (error 13).  BLOCK and BUFFER give a byte address, as PAD and TIB
\ are: what C@ CMOVE and TYPE take.
\
\ Constants the loader supplies:
\   BLOCK# BUFFER# UPDATE# SAVE-BUFFERS# EMPTY-BUFFERS#   the requests' numbers
\   SCR     word address of the variable: the block LIST showed last
\   BLK (SRC) (SRC-HOOK)   see input.v4

header SCR inline   : SCR'   SCR ;
header BLK inline   : BLK'   BLK ;

\ ( status -- )   a request that did not work is an error
: (B-ERR)
  if FINE  -2 + if E17  drop  NODE-ERROR b! 13 !b ;
  E17: drop  NODE-ERROR b! 17 !b ;
  FINE: drop ;

\ ( waddr status -- baddr )   the slot's byte address, or the error
: (B-GOT)
  if OK  SWAP drop  jump (B-ERR)
  OK: drop  2* 2* ;

\ ( n -- baddr )   FORTH-79: the address of a buffer assigned to block n.
\ What the buffer holds is not read from storage.
header BUFFER
: BUFFER   BUFFER# (PORT) b! !b  jump (B-GOT)

\ ( n -- baddr )   FORTH-79: the address of a buffer that holds block n,
\ read from storage if it is not already in one.
header BLOCK
: BLOCK    BLOCK# (PORT) b! !b  jump (B-GOT)

\ FORTH-79: mark the block most recently asked for as changed, so that it is
\ written before its buffer is used for another.
header UPDATE
: UPDATE   UPDATE# (PORT) b! !b  jump (B-ERR)

\ FORTH-79: write every block that has been UPDATEd.
header SAVE-BUFFERS
: SAVE-BUFFERS   SAVE-BUFFERS# (PORT) b! !b  jump (B-ERR)
\ As v3: the same.
header FLUSH
: FLUSH          jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
header EMPTY-BUFFERS
: EMPTY-BUFFERS  EMPTY-BUFFERS# (PORT) b! !b ;

\ ---- LIST ----------------------------------------------------------------------
\ ( n -- )   as v3: a new line, "Block n", then sixteen lines of 64
\ characters, each after its number, and an empty line.  SCR is left holding n.  A character
\ that is not printable is shown as a blank.  (Q)+0 is the line, (Q)+1 the
\ column, (Q)+2 the block's number.
header LIST
: LIST
  dup (Q)+2 a! !  BLOCK drop                 \ an error here leaves nothing behind
  (Q)+2 a! @  dup SCR a! !
  CR  $636F6C42 (EMIT4) $206B (EMIT4)  0 DOT-R  CR          \ "Block "
  0 (Q) a! !
  LN: (Q) a! @  0 <# # # #> TYPE  58 EMIT SPACE
      0 (Q)+1 a! !
      CH: SCR a! @ BLOCK  (Q) a! @ 2* 2* 2* 2* 2* 2* +  (Q)+1 a! @ +  C@
          dup -32 + -if GE  drop drop 32 jump EM
          GE: drop  dup -127 + -if BIG  drop jump EM
          BIG: drop drop 32
          EM: EMIT
          (Q)+1 a! @ 1 + dup !  -64 + if EOL  drop jump CH
      EOL: drop CR
      (Q) a! @ 1 + dup !  -16 + if DONE  drop jump LN
  DONE: drop  jump CR

\ ---- LOAD ----------------------------------------------------------------------
\ The text being interpreted is at (SRC), SPAN characters of it, >IN the
\ place in it.  LOAD saves those and BLK on the return stack, points them at
\ the block, interprets it, and puts them back; so a block may LOAD another,
\ and the rest of the line LOAD was on is interpreted afterwards.  (v3's
\ LOAD loses the rest of its line.)

\ ( -- )   what WORD calls before it reads: while a block is being loaded,
\ make sure it is in a buffer and (SRC) is that buffer.
: (BLK-SRC)
  BLK a! @ if TERM  BLOCK (SRC) a! ! ;
  TERM: drop ;

\ ( n -- )   FORTH-79: interpret block n, then go on with what follows.
header LOAD
: LOAD
  -if POS  jump BAD
  POS: if BAD
  BLK a! @ push  >IN a! @ push  SPAN a! @ push  (SRC) a! @ push
  BLK a! !  0 >IN a! !  1024 SPAN a! !
  &(BLK-SRC) (SRC-HOOK) a! !
  INTERPRET
  pop (SRC) a! !  pop SPAN a! !  pop >IN a! !  pop BLK a! ! ;
  BAD: drop  NODE-ERROR b! 13 !b ;

\ ( -- )   go on with the next block.  Only in a block being loaded: at the
\ terminal it is an error (code 14).
header --> immediate
: NEXT-BLOCK
  BLK a! @ if TERM  1 + !  0 >IN a! ! ;
  TERM: drop  NODE-ERROR b! 14 !b ;

\ ( first last -- )   as v3: LOAD each block from first to last.
header THRU
: THRU
  push
  L: dup inv  pop dup push  + 1 +  -if GO  drop drop pop drop ;      \ last - first
  GO: drop  dup push LOAD pop  1 +  jump L