\ 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. \ \ THE DEVICE (D-19) is four registers: the block's number, the word address \ of 256 cells, a command -- 1 read, 2 write -- and a status that is 0 when \ the command worked. \ \ THE BUFFERS. There are two, of 256 cells each, so two blocks can be in \ memory at once -- one can be copied to another. A buffer is given to the \ block that asks for one, turn about; if it held a block that was UPDATEd, \ that block is written first. BLOCK and BUFFER give a byte address, as PAD \ and TIB are: what C@ CMOVE and TYPE take. \ \ Constants the loader supplies: \ BLOCK-NUMBER BLOCK-ADDRESS BLOCK-COMMAND BLOCK-STATUS the device \ BUF0 BUF1 word addresses of the two buffers \ (B) word address of six cells: (B)+0 the block in buffer 0, or 0 \ (B)+1 whether it has been UPDATEd (B)+2 (B)+3 the same for \ buffer 1 (B)+4 which buffer was asked for last, 0 or 2 \ (B)+5 the block number while a buffer is found for it \ 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 ; \ ( i -- addr ) the word address of buffer i, where i is 0 or 2 : (BUF) if Z drop BUF1 ; Z: drop BUF0 ; \ ( command i -- ) read or write buffer i's block. A block the device \ does not have is an error (code 13); the buffer is then empty. : (DEVICE) dup (B) + a! @ BLOCK-NUMBER b! !b \ command i dup (BUF) BLOCK-ADDRESS b! !b push BLOCK-COMMAND b! !b pop \ i BLOCK-STATUS b! @b if FINE drop (B) + a! 0 !+ 0 ! \ nothing is in the buffer NODE-ERROR b! 13 !b ; FINE: drop drop ; \ ( i -- ) if buffer i's block has been UPDATEd, write it : (SAVE) dup (B) + 1 + a! @ if CLEAN drop 0 ! 2 SWAP jump (DEVICE) CLEAN: drop drop ; \ ( n -- i flag ) the buffer for block n: the one that has it, flag -1; or \ the other of the one asked for last, its old block written if need be and \ n's number put on it, flag 0 -- what it holds is not block n yet. A block \ number below 1 is an error (code 13). : (FIND-BUF) -if POS jump BAD POS: if BAD (B)+5 a! ! (B) a! @ (B)+5 a! @ xor if HIT0 drop (B)+2 a! @ (B)+5 a! @ xor if HIT2 drop (B)+4 a! @ 2 xor dup ! \ the other one dup (SAVE) dup (B) + a! (B)+5 b! @b !+ 0 ! \ its block now, not updated 0 ; HIT0: drop 0 (B)+4 a! ! 0 -1 ; HIT2: drop 2 (B)+4 a! ! 2 -1 ; BAD: drop NODE-ERROR b! 13 !b 0 -1 ; \ ( 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 (FIND-BUF) drop (BUF) 2* 2* ; \ ( 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 (FIND-BUF) if READ drop (BUF) 2* 2* ; READ: drop drop \ which buffer is in (B)+4: nothing waits on the stack 1 (B)+4 a! @ (DEVICE) (B)+4 a! @ (BUF) 2* 2* ; \ 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 (B)+4 a! @ (B) + a! @+ if NONE drop -1 ! ; NONE: drop ; \ FORTH-79: write every block that has been UPDATEd. header SAVE-BUFFERS : SAVE-BUFFERS 0 (SAVE) 2 jump (SAVE) \ 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 (B) a! 0 !+ 0 !+ 0 !+ 0 ! ; \ ---- 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