From c8dc14897c89084846b3c3ceaad4a8878a311375 Mon Sep 17 00:00:00 2001 From: rajames Date: Mon, 5 Oct 2026 08:32:04 -0400 Subject: [PATCH] feat(v4.0.0): block storage, LOAD and LIST (D-19) - The golden model's host node gets a block storage device: four memory-mapped registers (number, address, command, status), 1024-byte blocks as 256 cells. tests/test_node.c. - capsule/blocks.v4: BLOCK BUFFER UPDATE SAVE-BUFFERS EMPTY-BUFFERS LIST LOAD SCR BLK (FORTH-79) and v3's FLUSH THRU and -->, over two buffers. - The text being interpreted is at the address in (SRC), which QUERY makes the terminal's buffer and LOAD a block's; LOAD saves and restores it, so blocks nest and the rest of LOAD's line runs afterwards. WORD makes sure a loading block is still in a buffer before it reads. - In a block, \ skips to the next 64-character line. - A block number that does not exist, and --> at the terminal, are errors with messages (D-18). - tests/test_host_quit.c: ten transcripts of the v3 binary; nesting three deep on two buffers; what reaches the device and when. v3's LOAD drops the rest of its line, and v3 has no BLK. Co-Authored-By: Claude Opus 5.5 --- docs/v4.0.0/DECOMPOSITION.md | 14 ++-- v4/capsule/blocks.v4 | 156 +++++++++++++++++++++++++++++++++++ v4/capsule/core.v4 | 1 + v4/capsule/input.v4 | 26 ++++-- v4/capsule/quit.v4 | 8 +- v4/include/v4/node.h | 31 +++++++ v4/src/node.c | 40 +++++++++ v4/tests/host_map.h | 23 +++++- v4/tests/test_host_quit.c | 115 +++++++++++++++++++++++++- v4/tests/test_node.c | 64 ++++++++++++++ 10 files changed, 462 insertions(+), 16 deletions(-) create mode 100644 v4/capsule/blocks.v4 diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 7cda900e..71194d1d 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -179,7 +179,8 @@ definition below depends on one, it says so. | **D-15** | Division by zero in `/` `MOD` `/MOD` `*/` `*/MOD` `M/MOD` (ruled 2026-10-04). | **Guarded: the word reports it and the line ends.** Each of these words tests its divisor before anything else. If it is zero the word prints v3's message, its own name and `: Division by zero`, takes its operands off the stack as v3 does, ends any definition that was open, prints ` ERROR` and returns to the prompt, from however deep; its caller is not returned to. `M/MOD` says so too, where v3 printed ` ERROR` alone. Source in `v4/capsule/forth.v4`; executed on the golden model's host node (2026-10-04), including transcripts of the v3 binary. `Q./` keeps D-11 (saturate and flag). `UM/MOD` and `SM/REM` are internal and unguarded: their callers have checked. What a mesh node, with no console, does on a zero divisor comes with the mesh (step 2); §4's definitions, which the mesh-node tests execute, still leave it unspecified. | | **D-16** | Stack overflow and underflow; `DEPTH`, `PICK`, `ROLL` (ruled 2026-10-04; revises D-2). | **Guarded: a stack fault.** Each stack counts what it holds. Before every opcode the node checks that the stacks hold what the opcode takes — including a `T` or `S` it only reads — and have room for what it leaves. If not, the opcode does nothing and the node faults exactly as for a bad address (D-14), to that kind's handler: `Stack overflow`, `Stack underflow`, `Return stack overflow`, `Return stack underflow`, then ` ERROR` and the prompt. **Every fault, D-14's included, empties both stacks**: the handler does not return, and what a word stopped part-way has left on the data stack is of no use to its caller. (v3 keeps what the failing word had not taken, and names the word: `DROP: Stack underflow`.) The fault handler is a table of five words, one per kind, each a jump (`(FAULTS)` in `v4/capsule/quit.v4`). Two registers (§7) are all a programme sees of the stacks: `DSTACK-DEPTH` and `RSTACK-DEPTH` read as the depth, and a store to one empties that stack. There is still no stack pointer and no address for a stack cell, so `SP@` and `SP!` stay retired; `.S` waits for number output to reach the capsule. The sizes were unchanged by this ruling, 10 and 9 (D-17 then deepens the host node's): one more value, or one more level of call, is now an error message where it used to be silent corruption. Executed on the golden model (2026-10-04): `tests/test_exec.c` for every opcode at every depth of both stacks, `tests/test_host_quit.c` from the prompt. | | **D-17** | Stack sizes on the host node (2026-10-04, following D-16). | **32 values and 32 return entries on the host node; a mesh node keeps the F18's 10 and 9.** Once the stacks are counted (D-16) their size is a parameter of the node, like its memory, and the host node is the one that runs the interpreter and the compiler underneath the user's programme: at 10 and 9 the prompt left a programme about six values, and `/` could be used only four words deep. The mechanism is the same at both sizes — top registers over a ring — and so is every word's definition. v3's stacks are deeper still. In the golden model the sizes are `V4_DATA_RING` and `V4_RET_RING` (`stack.h`), set for the host-node tests in `v4/Makefile`. | -| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 9 `Shift count out of range`, 10 `Protected word`, 11 `Division by zero` (`Q./`), 12 `Argument out of range`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. | +| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 9 `Shift count out of range`, 10 `Protected word`, 11 `Division by zero` (`Q./`), 12 `Argument out of range`, 13 `Block out of range`, 14 `No block is being loaded`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. | +| **D-19** | Block storage on the golden model (2026-10-05). | **Four memory-mapped registers on the host node, until the mesh carries the storage service.** `BLOCK-NUMBER`, `BLOCK-ADDRESS` (the word address of 256 cells), `BLOCK-COMMAND` (a store of 1 reads the block into those cells, 2 writes it from them) and `BLOCK-STATUS` (0 when the command worked, −1 for a block the device has not got or cells not all in memory). A block is 1024 bytes: 256 cells, four bytes to a cell, the first byte lowest, at either cell width. This is the console's arrangement (§7) applied to storage; like it, it is the model's stand-in and not the mesh protocol, which §5.11 still leaves to the device node. | **Consequences of D-2 that every definition must respect.** The data stack holds 10 items and the return stack 9, and every `call`, `FOR`, `DO` loop frame and `push` uses return-stack slots. Nesting @@ -669,10 +670,10 @@ The storage service belongs to the Artemis role, now a device node. | Word | Fate | Notes | | --- | --- | --- | -| `BLOCK` `BUFFER` `UPDATE` `SAVE-BUFFERS` `EMPTY-BUFFERS` `FLUSH` | DEV | Block-service messages. Buffers live in the requesting node's RAM or in DDR. | -| `LOAD` `THRU` `-->` | CC | The interpreter reads blocks through the service. | -| `LIST` | CAP | `BLOCK` plus `TYPE`. | -| `SCR` | CAP | Variable. | +| `BLOCK` `BUFFER` `UPDATE` `SAVE-BUFFERS` `EMPTY-BUFFERS` `FLUSH` | DEV | FORTH-79 (`FLUSH` is v3's, the same as `SAVE-BUFFERS`). Source in `v4/capsule/blocks.v4`, over the device of D-19. There are **two buffers**, so two blocks can be in memory at once; a buffer goes to the block that asks, turn about, and a block that was `UPDATE`d is written before its buffer is given away. `BLOCK` and `BUFFER` give a **byte address**, as `PAD` and `TIB` are — what `C@`, `CMOVE` and `TYPE` take. A block number below 1, or one the device has not got, is D-18's code 13, `Block out of range` (v3 says ` ERROR` alone). Executed on the golden model's host node (2026-10-05), including transcripts of the v3 binary, with the bytes on the device checked after each step. | +| `LOAD` `THRU` `-->` `BLK` | CC | `LOAD` and `BLK` are FORTH-79; `THRU` and `-->` are v3's. Source in `v4/capsule/blocks.v4`. The text being interpreted is at the address in the variable `(SRC)`, `SPAN` characters long, `>IN` the place in it; `QUERY` makes that the terminal's buffer and `LOAD` a block's, all 1024 characters as one stream. `LOAD` saves `(SRC)`, `SPAN`, `>IN` and `BLK` on the return stack and puts them back, so a block may `LOAD` another and **the rest of the line `LOAD` was on is interpreted afterwards** (v3 drops it). `BLK` is the block being interpreted, 0 at the terminal; v3 has no `BLK`. A buffer can be given to another block between one word of the text and the next, so while a block is loading `WORD` first makes sure it is in a buffer (a hook `LOAD` installs). In a block `\` skips to the next 64-character line. `-->` at the terminal is code 14, `No block is being loaded`. An error while loading ends every `LOAD` under way and the terminal is the input again. Executed on the golden model's host node (2026-10-05), three blocks deep on two buffers, including transcripts of the v3 binary. | +| `LIST` | CAP | As v3: a new line, `Block n`, sixteen lines of 64 characters each after its two-digit number and a colon, and an empty line; a character that is not printable shows as a blank. Leaves `n` in `SCR`. Executed on the golden model's host node (2026-10-05) against a transcript of the v3 binary. | +| `SCR` | CAP | Variable: the block `LIST` showed last. | | `BLK-CONFIRM-FORMAT` `RELOCATE-BLOCK` | DEV | Owner-only storage messages. | | `BLK-ACL-ALLOW@` `BLK-ACL-ALLOW!` `BLK-ACL-TTL@` `BLK-ACL-TTL!` | HERA | ACL state is held by Hera. | | `BLK-OWNER@` | HERA | Read-only, as in v3. | @@ -759,7 +760,7 @@ call would bury what it works on. A **compile-only** word may not be executed by `v4/capsule/forth.v4` holds the first words of the vocabulary flagged this way (`DUP`, `+`, `>R`, `I`, `LEAVE`, `@`, the in-line variables and so on). -**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top. +**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`), `blocks.v4` (mass storage and `LOAD`), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top. **The stacks and the compiler.** The interpreter and compiler run on the same stacks as the user's words, with the user's values beneath them. The capsule was written for stacks of ten cells and nine @@ -1058,3 +1059,4 @@ Addresses are assigned in the node memory map (D-4). Names only here. | `CONSOLE-STATUS` | R | Console receive status: a fetch gives −1 when a character is pending and 0 when not, and changes nothing. `?TERMINAL` reads it, and `KEY` polls it. On the mesh it is the console port's bit of `PORT-STATUS`. | | `DSTACK-DEPTH` | R/W | A fetch gives how many values the data stack holds, the fetch's own push not counted. A store empties the data stack; the value stored is taken off first and ignored. `DEPTH` reads it; `ABORT` stores to it (D-16). | | `RSTACK-DEPTH` | R/W | The same for the return stack. `QUIT`, `ABORT` and the error exits store to it before they call anything. | +| `BLOCK-NUMBER` `BLOCK-ADDRESS` `BLOCK-COMMAND` `BLOCK-STATUS` | R/W | The block storage device on the golden model's host node (D-19). | diff --git a/v4/capsule/blocks.v4 b/v4/capsule/blocks.v4 new file mode 100644 index 00000000..6da79766 --- /dev/null +++ b/v4/capsule/blocks.v4 @@ -0,0 +1,156 @@ +\ 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 diff --git a/v4/capsule/core.v4 b/v4/capsule/core.v4 index 510dbc90..5ae3cb14 100644 --- a/v4/capsule/core.v4 +++ b/v4/capsule/core.v4 @@ -16,6 +16,7 @@ \ 7 Control structure mismatch 8 Control structures too deep \ 9 Shift count out of range 10 Protected word \ 11 Division by zero (Q./) 12 Argument out of range +\ 13 Block out of range 14 No block is being loaded \ -1 the word has printed its own message macro SWAP over push push drop pop pop endmacro diff --git a/v4/capsule/input.v4 b/v4/capsule/input.v4 index 953d1cea..289c44f6 100644 --- a/v4/capsule/input.v4 +++ b/v4/capsule/input.v4 @@ -13,13 +13,22 @@ \ EXPECT or QUERY read \ WBUF byte address of WORD's buffer, 257 bytes \ (P) word address of eight cells of scratch for this file +\ (SRC) word address of the variable: the byte address of the text being +\ interpreted. QUERY makes it TIB; LOAD (blocks.v4) makes it a +\ block buffer. >IN is an offset from it and SPAN its length. +\ (SRC-HOOK) word address of a variable: 0, or the address of a word +\ that WORD calls before it looks at the text, to make sure (SRC) +\ is right. LOAD puts one there: a block buffer can be given to +\ another block between one word of the text and the next. +\ BLK word address of the variable: the block being interpreted, or +\ 0 for the terminal (FORTH-79) \ TIB >IN SPAN and BL are in-line: written in a definition they are literals. macro BL 32 endmacro \ ( -- baddr u ) the input buffer and how much of it is in use header SOURCE -: SOURCE TIB SPAN a! @ -if P drop 0 P: ; +: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ; \ ( baddr n -- ) FORTH-79: characters from the terminal are stored from \ baddr upward until a new-line or until n have been received; the new-line @@ -49,7 +58,7 @@ header EXPECT \ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0. header QUERY -: QUERY TIB 80 EXPECT 0 >IN a! ! ; +: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ; \ ---- WORD ------------------------------------------------------------------ \ WORD is called from deep inside the interpreter and compiler, with whatever @@ -64,7 +73,7 @@ header QUERY \ In line, not called: WORD may have only a few return entries to spare. macro (LEFT) (P)+6 a! @ (P)+1 a! @ - endmacro \ ( -- d ) d < 0 while inside the text -macro (CH) (P)+6 a! @ TIB + C@ (P) a! @ xor endmacro \ ( -- x ) x = 0 at a delimiter +macro (CH) (P)+6 a! @ (SRC) a! @ + C@ (P) a! @ xor endmacro \ ( -- x ) x = 0 at a delimiter macro (STEP) (P)+6 a! @ 1 + ! endmacro \ ( c -- baddr ) FORTH-79: characters are taken from TIB until the @@ -78,6 +87,10 @@ macro (STEP) (P)+6 a! @ 1 + ! endmacro \ than if it were written in one piece. : (WORD-SET) ( c -- ) 255 and (P) a! ! + (SRC-HOOK) a! @ if NONE push ex \ call it: ex comes back to the next word + jump HOOKED + NONE: drop + HOOKED: SPAN a! @ -if A drop 0 A: (P)+1 a! ! >IN a! @ -if B drop 0 B: (P)+6 a! ! ; @@ -91,7 +104,7 @@ macro (STEP) (P)+6 a! @ 1 + ! endmacro (P)+2 a! @ WBUF C! \ copy it, last character first CP: (P)+3 a! @ if COPIED -1 + dup ! \ k - dup (P)+7 a! @ + TIB + C@ \ k c + dup (P)+7 a! @ + (SRC) a! @ + C@ \ k c SWAP WBUF+1 + C! jump CP COPIED: drop @@ -190,4 +203,7 @@ header NUMBER header ( immediate : PAREN 41 WORD drop ; header \ immediate -: BACKSLASH SPAN a! @ >IN a! ! ; +\ In a block a line is 64 characters: skip to the start of the next. +: BACKSLASH + BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ; + TERM: drop SPAN a! @ >IN a! ! ; diff --git a/v4/capsule/quit.v4 b/v4/capsule/quit.v4 index 82ba91da..087f7e96 100644 --- a/v4/capsule/quit.v4 +++ b/v4/capsule/quit.v4 @@ -22,7 +22,8 @@ \ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that. \ \ Constants the loader supplies: -\ (Q) word address of two cells of scratch for this file +\ (Q) word address of four cells of scratch, which system.v4 and +\ blocks.v4 use too \ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers \ ( -- ) empty the return stack. `a` is only something to store: any @@ -46,6 +47,7 @@ macro R-CLEAR RSTACK-DEPTH b! a !b endmacro GO: drop READ: $203E6B6F (EMIT4) \ "ok> " + 0 BLK a! ! \ the terminal, whatever was being loaded QUERY 0 NODE-ERROR b! !b INTERPRET @@ -96,7 +98,7 @@ header ABORT -if POS drop 2 jump (REPL) POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4 -1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9 - -1 + if M10 -1 + if M11 -1 + if M12 + -1 + if M10 -1 + if M11 -1 + if M12 -1 + if M13 -1 + if M14 drop 2 jump (REPL) M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (REPL) M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (REPL) @@ -110,6 +112,8 @@ header ABORT M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (REPL) M11: drop $69766944 (EMIT4) $6E6F6973 (EMIT4) $20796220 (EMIT4) $6F72657A (EMIT4) CR 2 jump (REPL) M12: drop $75677241 (EMIT4) $746E656D (EMIT4) $74756F20 (EMIT4) $20666F20 (EMIT4) $676E6172 (EMIT4) $65 (EMIT4) CR 2 jump (REPL) + M13: drop $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR 2 jump (REPL) + M14: drop $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR 2 jump (REPL) \ The table the loader gives the node: six words, one for each kind of \ fault in the node's order, each a jump. A jump fills its word, so they diff --git a/v4/include/v4/node.h b/v4/include/v4/node.h index 2d6bb0c1..0c4d558b 100644 --- a/v4/include/v4/node.h +++ b/v4/include/v4/node.h @@ -92,6 +92,11 @@ typedef struct { v4_cell dstack_reg; /* its word address, or -1 */ v4_cell rstack_reg; /* its word address, or -1 */ + /* The block storage device (D-19). See v4_node_storage_attach. */ + v4_cell storage_reg; /* word address of its four registers, or -1 */ + unsigned char *storage; /* the blocks, 1024 bytes each */ + unsigned storage_blocks; /* how many */ + /* NODE-ERROR as a trap (D-18). See v4_node_error_attach. */ v4_cell error_reg; /* its word address, or -1 */ } v4_node; @@ -238,6 +243,32 @@ void v4_node_fault(v4_node *n, unsigned kind, v4_cell addr); * detaches both (-1); the addresses are the caller's choice (D-4). */ void v4_node_stack_regs_attach(v4_node *n, v4_cell d, v4_cell r); +/* THE BLOCK STORAGE DEVICE (DECOMPOSITION.md D-19, 5.11). + * + * Mass storage is a device service; until the mesh exists the model stands + * in for it on the host node with four memory-mapped registers at `reg`: + * + * reg + 0 BLOCK-NUMBER which block, 0 .. blocks - 1 + * reg + 1 BLOCK-ADDRESS word address of 256 cells of node memory + * reg + 2 BLOCK-COMMAND a store of 1 reads the block into those cells, + * a store of 2 writes it from them + * reg + 3 BLOCK-STATUS 0 after a command that worked, -1 after one + * that did not: no such block, cells that are + * not all in memory, or an unknown command + * + * The first, second and fourth are memory words the device reads and writes; + * only a store to the third does anything. A block is 1024 bytes, and a + * byte address is four times a word address plus 0 .. 3 (D-1), so a block + * is 256 cells, four bytes to a cell, the first byte lowest, whatever the + * cell width: a read leaves the rest of each cell zero, and a write takes + * the low 32 bits. + * + * `bytes` is the caller's: `blocks` * 1024 bytes, which the device reads and + * writes and never frees. v4_node_reset detaches it (reg -1). */ +#define V4_BLOCK_BYTES 1024u +#define V4_BLOCK_CELLS 256u +void v4_node_storage_attach(v4_node *n, v4_cell reg, unsigned char *bytes, unsigned blocks); + /* NODE-ERROR as a trap (DECOMPOSITION.md D-18, ruled 2026-10-04: every error * is guarded, shown, and returns the node to its prompt). * diff --git a/v4/src/node.c b/v4/src/node.c index 3e4c5182..55beba22 100644 --- a/v4/src/node.c +++ b/v4/src/node.c @@ -1,5 +1,6 @@ /* node.c -- the v4 node. See node.h. */ #include "v4/node.h" +#include void v4_node_reset(v4_node *n) { @@ -16,6 +17,43 @@ void v4_node_reset(v4_node *n) v4_node_fault_attach(n, -1); v4_node_stack_regs_attach(n, -1, -1); v4_node_error_attach(n, -1); + v4_node_storage_attach(n, -1, 0, 0); +} + +void v4_node_storage_attach(v4_node *n, v4_cell reg, unsigned char *bytes, unsigned blocks) +{ + n->storage_reg = reg; + n->storage = bytes; + n->storage_blocks = blocks; +} + +/* BLOCK-COMMAND: do it, and leave the status in BLOCK-STATUS. */ +static void storage_command(v4_node *n, v4_cell command) +{ + v4_cell num = n->mem[n->storage_reg], addr = n->mem[n->storage_reg + 1]; + unsigned char *b; + unsigned i; + + n->mem[n->storage_reg + 3] = (v4_cell)-1; + if (!n->storage || num < 0 || (v4_ucell)num >= (v4_ucell)n->storage_blocks) return; + if (!v4_node_addr_ok(addr) || !v4_node_addr_ok(addr + (v4_cell)(V4_BLOCK_CELLS - 1u))) return; + b = n->storage + (size_t)num * V4_BLOCK_BYTES; + if (command == 1) { + for (i = 0; i < V4_BLOCK_CELLS; i++) + n->mem[addr + (v4_cell)i] = (v4_cell)((v4_ucell)b[4u * i] | ((v4_ucell)b[4u * i + 1u] << 8) + | ((v4_ucell)b[4u * i + 2u] << 16) | ((v4_ucell)b[4u * i + 3u] << 24)); + } else if (command == 2) { + for (i = 0; i < V4_BLOCK_CELLS; i++) { + v4_ucell w = (v4_ucell)n->mem[addr + (v4_cell)i]; + b[4u * i] = (unsigned char)(w & 0xFFu); + b[4u * i + 1u] = (unsigned char)((w >> 8) & 0xFFu); + b[4u * i + 2u] = (unsigned char)((w >> 16) & 0xFFu); + b[4u * i + 3u] = (unsigned char)((w >> 24) & 0xFFu); + } + } else { + return; + } + n->mem[n->storage_reg + 3] = 0; } void v4_node_error_attach(v4_node *n, v4_cell addr) @@ -86,6 +124,8 @@ void v4_node_store(v4_node *n, v4_cell addr, v4_cell value) if (addr == n->rstack_reg) { v4_rstack_clear(&n->rs); return; } if (!v4_node_addr_ok(addr)) return; n->mem[(unsigned)addr] = value; + /* BLOCK-COMMAND. storage_reg is -1 when no device is attached. */ + if (n->storage_reg >= 0 && addr == n->storage_reg + 2) { storage_command(n, value); return; } /* NODE-ERROR: a non-zero code raises an error. -1 when not attached. */ if (addr == n->error_reg && value != 0) v4_node_fault(n, V4_FAULT_RAISED, value); } diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index 1f53103c..464892bd 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -45,7 +45,6 @@ #define VOC_LINK (TOP - 50) /* the newest vocabulary */ #define FENCE (TOP - 26) /* FORGET's lower limit */ #define HLD (TOP - 25) /* where the pictured number has got to */ -#define QVARS (TOP - 52) /* (Q): quit.v4, 2 cells */ /* buffers (word addresses; a byte address is four times this) */ #define CFS_W (TOP - 96) /* the control-flow stack, 32 cells */ @@ -59,6 +58,15 @@ #define HEND ((HBUF_W + 16) * 4) #define XVARS (HBUF_W - 4) /* (X): words.v4, 4 cells */ #define QBASE (XVARS - 40) /* the Q words' and DUMP's scratch cells, 39 in all */ +#define BVARS (QBASE - 16) /* blocks.v4: (B) 6 cells, then SCR BLK (SRC) (SRC-HOOK) and the device's four */ +#define SCR (BVARS + 6) +#define BLK (BVARS + 7) +#define SRC (BVARS + 8) +#define SRC_HOOK (BVARS + 9) +#define STORAGE_REG (BVARS + 10) +#define BUF0_W (BVARS - 2 * 256) /* the two block buffers, 256 cells each */ +#define BUF1_W (BUF0_W + 256) +#define QVARS (BUF0_W - 4) /* (Q): quit.v4, system.v4 and blocks.v4, 4 cells */ #define WBUF (WBUF_W * 4) #define TIB (TIB_W * 4) #define PAD (PAD_W * 4) @@ -119,6 +127,17 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned v4_text_constant(tx, "(S)", SVARS); v4_text_constant(tx, "(W)", WVARS); v4_text_constant(tx, "(X)", XVARS); + v4_text_constant(tx, "(B)", BVARS); + v4_text_constant(tx, "SCR", SCR); + v4_text_constant(tx, "BLK", BLK); + v4_text_constant(tx, "(SRC)", SRC); + v4_text_constant(tx, "(SRC-HOOK)", SRC_HOOK); + v4_text_constant(tx, "BLOCK-NUMBER", STORAGE_REG); + v4_text_constant(tx, "BLOCK-ADDRESS", STORAGE_REG + 1); + v4_text_constant(tx, "BLOCK-COMMAND", STORAGE_REG + 2); + v4_text_constant(tx, "BLOCK-STATUS", STORAGE_REG + 3); + v4_text_constant(tx, "BUF0", BUF0_W); + v4_text_constant(tx, "BUF1", BUF1_W); v4_text_constant(tx, "(Q/)", QBASE); /* 5 cells */ v4_text_constant(tx, "(QE)", QBASE + 5); /* 8 */ v4_text_constant(tx, "(QR)", QBASE + 13); /* 5 */ @@ -157,6 +176,8 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned n->mem[CONTEXT] = LATEST; n->mem[CURRENT] = LATEST; n->mem[VOC_LINK] = 0; + /* and the text interpreted is the terminal's */ + n->mem[SRC] = TIB; return 1; } diff --git a/v4/tests/test_host_quit.c b/v4/tests/test_host_quit.c index 942deaf5..2a23ae53 100644 --- a/v4/tests/test_host_quit.c +++ b/v4/tests/test_host_quit.c @@ -18,6 +18,9 @@ * v3 goes on compiling the lines that follow into it. * - ABORT" at the prompt stops the line when its flag is true. v3 prints * the text and carries on. Compiled into a word, v3's crashes (SIGSEGV). + * - LOAD goes on with the rest of its line afterwards, and there is BLK + * (both FORTH-79); v3's LOAD drops the rest of the line and it has no + * BLK. A block number that does not exist says so. * - vocabularies are FORTH-79's: a word defined in one is found only when * that vocabulary is CONTEXT, and FORTH is searched after it. v3 finds * every word everywhere, and a word redefined in a vocabulary replaces @@ -56,6 +59,16 @@ static v4_heat h; static v4_text tx; static v4_cell w_quit, w_key, w_key_end, w_fault, capsule_latest; static char out[V4_CONSOLE_CAP + 1]; + +/* The storage device's blocks: zeros at every switch-on. */ +#define DISK_BLOCKS 64u +static unsigned char disk[DISK_BLOCKS * V4_BLOCK_BYTES]; +/* A block holding `text`, the rest of it blanks. */ +static void put_block(unsigned num, const char *text) +{ + memset(disk + num * V4_BLOCK_BYTES, ' ', V4_BLOCK_BYTES); + memcpy(disk + num * V4_BLOCK_BYTES, text, strlen(text)); +} static long last_steps; /* Run until the node has taken all its input and has been inside KEY, waiting, @@ -89,6 +102,10 @@ static void boot_with(unsigned depth) n.mem[CONTEXT] = LATEST; n.mem[CURRENT] = LATEST; n.mem[VOC_LINK] = 0; + n.mem[SRC] = TIB; + for (v4_cell k = BVARS; k < BVARS + 14; k++) if (k != SRC) n.mem[k] = 0; /* empty buffers, SCR and BLK 0, no hook */ + memset(disk, 0, sizeof disk); + v4_node_storage_attach(&n, STORAGE_REG, disk, DISK_BLOCKS); v4_node_console_attach(&n, CONSOLE_TX); v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST); v4_node_fault_attach(&n, w_fault); @@ -331,6 +348,27 @@ static const transcript script[] = { { "Q.0 Q.LOG 65 EMIT\n-1 Q.FROM-INT Q.LOG\n", "Argument out of range\n ERROR\nok> Argument out of range\n ERROR\nok> ", 0 }, { "7 PAD -1 DUMP 65 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "PAD 0 DUMP\n", " ok\nok> ", 1 }, + /* blocks.v4 */ + { "20 BLOCK 1024 BLANK 65 20 BLOCK C! UPDATE SAVE-BUFFERS 20 BLOCK C@ .\n", + "65 ok\nok> ", 1 }, + { "20 BLOCK 1024 BLANK 20 BLOCK 16 65 FILL UPDATE 20 LIST\nSCR @ .\n", + "\nBlock 20\n00: AAAAAAAAAAAAAAAA \n01: \n02: \n03: \n04: \n05: \n06: \n07: \n08: \n09: \n10: \n11: \n12: \n13: \n14: \n15: \n\n ok\nok> 20 ok\nok> ", 1 }, + { "30 BLOCK 1024 BLANK S\" 65 EMIT 66 EMIT\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n", + "AB ok\nok> ", 1 }, + { "30 BLOCK 1024 BLANK S\" 65 EMIT -->\" 30 BLOCK SWAP CMOVE UPDATE\n31 BLOCK 1024 BLANK S\" 66 EMIT\" 31 BLOCK SWAP CMOVE UPDATE 30 LOAD\n", + " ok\nok> AB ok\nok> ", 1 }, + { "30 BLOCK 1024 BLANK S\" 65 EMIT\" 30 BLOCK SWAP CMOVE UPDATE\n31 BLOCK 1024 BLANK S\" 66 EMIT\" 31 BLOCK SWAP CMOVE UPDATE 30 31 THRU\n", + " ok\nok> AB ok\nok> ", 1 }, + { "30 BLOCK 1024 BLANK S\" : SQ DUP * ;\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n7 SQ .\n", + " ok\nok> 49 ok\nok> ", 1 }, + { "30 BLOCK 1024 BLANK S\" 1 2 NOSUCH 3\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n.S\n", + "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> <2> 1 2 \n ok\nok> ", 1 }, + { "20 BLOCK 16 65 FILL EMPTY-BUFFERS 20 BLOCK C@ .\n", + "0 ok\nok> ", 1 }, + { "20 BLOCK 1024 66 FILL UPDATE FLUSH 20 BLOCK C@ .\n", + "66 ok\nok> ", 1 }, + { "20 BLOCK 1024 BLANK 66 20 BLOCK C! UPDATE 21 BLOCK DROP 22 BLOCK DROP\n20 BLOCK C@ .\n", + " ok\nok> 66 ok\nok> ", 1 }, /* CASE, ['], S", FORGET */ { ": C1 CASE 1 OF 65 EMIT ENDOF 2 OF 66 EMIT ENDOF 67 EMIT ENDCASE ;\n1 C1 2 C1 3 C1\n.S\n", " ok\nok> ABC ok\nok> <0> \n ok\nok> ", 1 }, { ": C2 CASE 1 OF 10 ENDOF 2 OF 20 ENDOF DUP 100 + SWAP ENDCASE ;\n1 C2 . 2 C2 . 7 C2 .\n.S\n", " ok\nok> 10 20 107 ok\nok> <0> \n ok\nok> ", 1 }, @@ -477,8 +515,8 @@ int main(void) printf("v4 host prompt tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS); { - static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4" }; - CHECK(host_load(&tx, &n, files, 11), "the capsule assembles"); + static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4" }; + CHECK(host_load(&tx, &n, files, 12), "the capsule assembles"); } CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx)); CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space"); @@ -821,6 +859,79 @@ int main(void) CHECK(is(say("FORGET G3 G1 G2\n"), "AB ok\nok> ") && is(say("G3\n"), "UNKNOWN WORD: 'G3'\n ERROR\nok> "), "one above it can"); } + /* ---- blocks: text loaded from storage ---- */ + boot_bare(); + put_block(5, "65 EMIT 66 EMIT"); + CHECK(is(say("5 LOAD 67 EMIT BLK @ .\n"), "ABC0 ok\nok> "), "LOAD interprets the block and then the rest of the line"); + put_block(6, "BLK @ . 7 LOAD BLK @ ."); + put_block(7, "BLK @ . 68 EMIT"); + CHECK(is(say("6 LOAD BLK @ .\n"), "6 7 D6 0 ok\nok> "), "a block may LOAD another; BLK is the block being interpreted"); + put_block(8, "65 EMIT 9 LOAD 66 EMIT"); + put_block(9, "67 EMIT 10 LOAD 68 EMIT"); + put_block(10, "69 EMIT"); + CHECK(is(say("8 LOAD\n"), "ACEDB ok\nok> "), "three deep, with two buffers: each block is fetched again when it is come back to"); + put_block(11, ": W1 1 ; -->"); + put_block(12, ": W2 W1 1+ ; W2 . -->"); + put_block(13, "W2 W2 + ."); + CHECK(is(say("11 LOAD 70 EMIT\n"), "2 4 F ok\nok> "), "--> goes on with the next block"); + CHECK(is(say("11 13 THRU 9 8 THRU 71 EMIT\n"), "2 4 2 4 4 G ok\nok> "), "THRU loads each in turn (here the --> chain from 11 and 12, then 13); an empty range loads nothing"); + memset(disk + 14 * V4_BLOCK_BYTES, ' ', V4_BLOCK_BYTES); + memcpy(disk + 14 * V4_BLOCK_BYTES, "65 EMIT \\ 66 EMIT and the rest of this line", 43); + memcpy(disk + 14 * V4_BLOCK_BYTES + 64, "67 EMIT ( a comment", 19); + memcpy(disk + 14 * V4_BLOCK_BYTES + 128, "over two lines ) 68 EMIT : LONGDEF", 34); + memcpy(disk + 14 * V4_BLOCK_BYTES + 192, "69 EMIT ; LONGDEF", 17); + CHECK(is(say("14 LOAD\n"), "ACDE ok\nok> "), "in a block \\ skips to the next 64-character line; ( and : run across lines"); + put_block(15, "1 16 LOAD 2"); + put_block(16, "3 NOSUCH 4"); + CHECK(is(say("15 LOAD 99 .\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> "), "an error in a loaded block ends everything"); + CHECK(is(say("BLK @ . .S\n"), "0 <2> 1 3 \n ok\nok> ") && n.mem[SRC] == TIB, "and the terminal is the input again"); + put_block(17, ": HALFDONE 1 2"); + CHECK(is(say("17 LOAD\n"), " ok\nok> ") && n.mem[STATE] != 0 && is(say("+ ; HALFDONE .\n"), "3 ok\nok> "), "a definition begun in a block can be finished at the terminal"); + /* errors */ + CHECK(is(say("ABORT\n"), " ok\nok> "), "(an empty stack)"); + CHECK(is(say("7 0 BLOCK 65 EMIT\n"), "Block out of range\n ERROR\nok> ") && is(say("-1 BLOCK\n"), "Block out of range\n ERROR\nok> ") + && is(say("64 BLOCK\n"), "Block out of range\n ERROR\nok> ") && is(say("63 BLOCK DROP .S\n"), "<1> 7 \n ok\nok> "), "a block number below 1 or past the device's last"); + CHECK(is(say("0 LOAD\n"), "Block out of range\n ERROR\nok> ") && is(say("-5 LOAD\n"), "Block out of range\n ERROR\nok> ") + && is(say("0 BUFFER\n"), "Block out of range\n ERROR\nok> ") && is(say("99 LIST\n"), "Block out of range\n ERROR\nok> "), "LOAD, BUFFER and LIST the same"); + CHECK(is(say("-->\n"), "No block is being loaded\n ERROR\nok> ") && is(say("65 EMIT\n"), "A ok\nok> "), "--> at the terminal"); + put_block(18, "1 99 LOAD 2"); + CHECK(is(say("ABORT\n"), " ok\nok> "), "(an empty stack)"); + CHECK(is(say("18 LOAD\n.S\n"), "Block out of range\n ERROR\nok> <1> 1 \n ok\nok> "), "a block that loads one that is not there"); + + /* ---- blocks: what is written, and when ---- */ + boot_bare(); + CHECK(is(say("3 BLOCK 1024 BLANK 72 3 BLOCK C! 73 3 BLOCK 1023 + C! UPDATE\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 0, + "an UPDATEd block is not written yet"); + CHECK(is(say("FLUSH\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'H' && disk[3 * V4_BLOCK_BYTES + 1] == ' ' && disk[3 * V4_BLOCK_BYTES + 1023] == 'I' + && disk[2 * V4_BLOCK_BYTES + 1023] == 0 && disk[4 * V4_BLOCK_BYTES] == 0, "FLUSH writes it, all 1024 bytes and no others"); + CHECK(is(say("74 3 BLOCK C! UPDATE 4 BLOCK DROP\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'H', "with two buffers a second block does not disturb it"); + CHECK(is(say("5 BLOCK DROP\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'J', "a third takes its buffer, and it is written first"); + CHECK(is(say("3 BLOCK C@ . 75 3 BLOCK C! UPDATE EMPTY-BUFFERS FLUSH 3 BLOCK C@ .\n"), "74 74 ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'J', + "EMPTY-BUFFERS forgets a change without writing it"); + CHECK(is(say("76 3 BLOCK C! 5 BLOCK DROP 6 BLOCK DROP 3 BLOCK C@ .\n"), "74 ok\nok> "), "a change without UPDATE is lost when the buffer is taken"); + CHECK(is(say("3 BLOCK 4 BLOCK 1024 CMOVE UPDATE SAVE-BUFFERS\n"), " ok\nok> ") && memcmp(disk + 3 * V4_BLOCK_BYTES, disk + 4 * V4_BLOCK_BYTES, V4_BLOCK_BYTES) == 0 + && disk[4 * V4_BLOCK_BYTES] == 'J', "two blocks in memory at once: one copied to the other"); + put_block(40, "this is on the device"); + CHECK(is(say("40 BUFFER 1024 65 FILL UPDATE FLUSH\n"), " ok\nok> ") && disk[40 * V4_BLOCK_BYTES] == 'A' && disk[40 * V4_BLOCK_BYTES + 1023] == 'A', + "BUFFER gives a buffer for a block without reading it"); + { + v4_cell k, wide = 0; + (void)say("3 BLOCK DROP\n"); + for (k = 0; k < 2 * 256; k++) if ((v4_ucell)n.mem[BUF0_W + k] > 0xFFFFFFFFu) wide = 1; + CHECK(!wide, "a block's bytes are four to a cell at every cell width"); + } + { + v4_cell before[8], k; + CHECK(is(say("VOCABULARY KEEP KEEP DEFINITIONS : KEPT 75 EMIT ; FORTH DEFINITIONS\n"), " ok\nok> "), "a vocabulary, before blocks are listed and loaded"); + for (k = 0; k < 8; k++) before[k] = n.mem[TOP - 56 + k]; /* the cells around (Q)'s old place */ + put_block(41, "66 EMIT"); + (void)say("41 LIST 41 LOAD\n"); + for (k = 0; k < 8; k++) CHECK(n.mem[TOP - 56 + k] == before[k], "LIST and LOAD leave cell TOP-%d alone", (int)(56 - k)); + CHECK(is(say("KEEP KEPT FORTH\n"), "K ok\nok> ") && n.mem[VOC_LINK] != 0, "and the vocabulary is intact"); + } + CHECK(strncmp(say("50 LIST\n"), "\nBlock 50\n00: \n01: ", 81) == 0 && n.mem[SCR] == 50, + "a block of zeros lists as blanks, and SCR is the block listed"); + /* ---- vocabularies (FORTH-79) ---- */ boot_bare(); CHECK(is(say("CONTEXT @ CURRENT @ = . ORDER\n"), "-1 Search order: FORTH \nCurrent: FORTH\n ok\nok> "), "at switch-on there is FORTH"); diff --git a/v4/tests/test_node.c b/v4/tests/test_node.c index 72f70d58..3448b7a1 100644 --- a/v4/tests/test_node.c +++ b/v4/tests/test_node.c @@ -195,6 +195,69 @@ static void test_out_of_range_word_address_touches_nothing(void) free(n); } +/* D-19: the block storage device. Four registers; a store to the third + * reads a block into 256 cells of memory or writes it from them. */ +static void test_storage_device(void) +{ + static unsigned char blocks[4 * V4_BLOCK_BYTES]; + const v4_cell REG = 40, BUF = 100; + v4_node *n = malloc(sizeof *n); + unsigned i; + int ok; + if (!n) { CHECK(0, "malloc"); return; } + v4_node_reset(n); + CHECK(n->storage_reg == -1, "a fresh node has no storage"); + for (i = 0; i < sizeof blocks; i++) blocks[i] = (unsigned char)(i * 7u + (i >> 10)); + v4_node_storage_attach(n, REG, blocks, 4); + + /* read block 2 */ + n->mem[BUF - 1] = 111; n->mem[BUF + 256] = 222; + v4_node_store(n, REG, 2); v4_node_store(n, REG + 1, BUF); + n->mem[REG + 3] = 55; + v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == 0, "a read that works leaves status 0"); + for (ok = 1, i = 0; i < V4_BLOCK_CELLS; i++) { + const unsigned char *b = blocks + 2 * V4_BLOCK_BYTES + 4u * i; + v4_ucell want = (v4_ucell)b[0] | ((v4_ucell)b[1] << 8) | ((v4_ucell)b[2] << 16) | ((v4_ucell)b[3] << 24); + if ((v4_ucell)n->mem[BUF + (v4_cell)i] != want) ok = 0; + } + CHECK(ok, "the block is in memory, four bytes to a cell, the first lowest, the rest of the cell zero"); + CHECK(n->mem[BUF - 1] == 111 && n->mem[BUF + 256] == 222, "and only 256 cells were written"); + CHECK(n->mem[REG] == 2 && n->mem[REG + 1] == BUF && n->mem[REG + 2] == 1, "the registers are memory words"); + + /* write it to block 0, changed */ + n->mem[BUF] = (v4_cell)0x44332211; n->mem[BUF + 255] = (v4_cell)(v4_ucell)0xAABBCCDDu; + v4_node_store(n, REG, 0); + v4_node_store(n, REG + 2, 2); + CHECK(n->mem[REG + 3] == 0 && blocks[0] == 0x11 && blocks[1] == 0x22 && blocks[2] == 0x33 && blocks[3] == 0x44 + && blocks[1020] == 0xDD && blocks[1023] == 0xAA, "a write puts the low four bytes of each cell on the device"); + CHECK(memcmp(blocks + 4, blocks + 2 * V4_BLOCK_BYTES + 4, 1016) == 0, "the rest of the block as it was read"); + CHECK(blocks[V4_BLOCK_BYTES] == (unsigned char)(1024u * 7u + 1u), "and the next block untouched"); + + /* what does not work: status -1, nothing moved */ + v4_node_store(n, REG, 4); v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == -1, "a block past the last"); + v4_node_store(n, REG, -1); v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == -1, "a negative block"); + v4_node_store(n, REG, 1); v4_node_store(n, REG + 1, (v4_cell)V4_NODE_WORDS - 255); v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == -1, "cells that run past the end of memory"); + v4_node_store(n, REG + 1, -4); v4_node_store(n, REG + 2, 2); + CHECK(n->mem[REG + 3] == -1, "a negative address"); + v4_node_store(n, REG + 1, BUF); v4_node_store(n, REG + 2, 3); + CHECK(n->mem[REG + 3] == -1, "an unknown command"); + v4_node_store(n, REG + 1, (v4_cell)V4_NODE_WORDS - 256); v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == 0 && v4_node_guards_intact(n), "the last 256 cells of memory are usable"); + + /* detached: plain memory */ + v4_node_storage_attach(n, -1, 0, 0); + n->mem[REG + 3] = 9; v4_node_store(n, REG + 2, 1); + CHECK(n->mem[REG + 3] == 9 && n->mem[REG + 2] == 1, "detached, the registers are memory"); + v4_node_storage_attach(n, REG, blocks, 4); + v4_node_reset(n); + CHECK(n->storage_reg == -1, "reset detaches the device"); + free(n); +} + static void test_ends_are_distinguishable(void) { /* The two boundaries carry different patterns precisely so that a failure @@ -254,6 +317,7 @@ int main(void) test_linear_overrun_low_is_caught(); test_linear_overrun_high_is_caught(); test_out_of_range_word_address_touches_nothing(); + test_storage_device(); test_ends_are_distinguishable(); test_workload_never_false_alarms();