admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(v4.0.0): block storage, LOAD and LIST (D-19)

Browse Source 
- 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 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-05 08:32:04 -04:00
co-authored by Claude Opus 5.5
parent 0fbe1432b7
commit c8dc14897c
10 changed files with 462 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files
docs/v4.0.0/DECOMPOSITION.md
+8 -6
View File
@@ -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-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-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-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 **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 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 | | 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. | | `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` `-->` | CC | The interpreter reads blocks through the service. | | `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 | `BLOCK` plus `TYPE`. | | `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. | | `SCR` | CAP | Variable: the block `LIST` showed last. |
| `BLK-CONFIRM-FORMAT` `RELOCATE-BLOCK` | DEV | Owner-only storage messages. | | `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-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. | | `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`, `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). `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 **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 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`. | | `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). | | `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. | | `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). |
v4/capsule/blocks.v4
+156
View File
@@ -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
v4/capsule/core.v4
+1
View File
@@ -16,6 +16,7 @@
\ 7 Control structure mismatch 8 Control structures too deep \ 7 Control structure mismatch 8 Control structures too deep
\ 9 Shift count out of range 10 Protected word \ 9 Shift count out of range 10 Protected word
\ 11 Division by zero (Q./) 12 Argument out of range \ 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 \ -1 the word has printed its own message
macro SWAP over push push drop pop pop endmacro macro SWAP over push push drop pop pop endmacro
v4/capsule/input.v4
+21 -5
View File
@@ -13,13 +13,22 @@
\ EXPECT or QUERY read \ EXPECT or QUERY read
\ WBUF byte address of WORD's buffer, 257 bytes \ WBUF byte address of WORD's buffer, 257 bytes
\ (P) word address of eight cells of scratch for this file \ (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. \ TIB >IN SPAN and BL are in-line: written in a definition they are literals.
macro BL 32 endmacro macro BL 32 endmacro
\ ( -- baddr u ) the input buffer and how much of it is in use \ ( -- baddr u ) the input buffer and how much of it is in use
header SOURCE 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 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 \ 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. \ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
header QUERY header QUERY
: QUERY TIB 80 EXPECT 0 >IN a! ! ; : QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
\ ---- WORD ------------------------------------------------------------------ \ ---- WORD ------------------------------------------------------------------
\ WORD is called from deep inside the interpreter and compiler, with whatever \ 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. \ 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 (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 macro (STEP) (P)+6 a! @ 1 + ! endmacro
\ ( c -- baddr ) FORTH-79: characters are taken from TIB until the \ ( 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. \ than if it were written in one piece.
: (WORD-SET) ( c -- ) : (WORD-SET) ( c -- )
255 and (P) a! ! 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! ! SPAN a! @ -if A drop 0 A: (P)+1 a! !
>IN a! @ -if B drop 0 B: (P)+6 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! (P)+2 a! @ WBUF C!
\ copy it, last character first \ copy it, last character first
CP: (P)+3 a! @ if COPIED -1 + dup ! \ k 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! SWAP WBUF+1 + C!
jump CP jump CP
COPIED: drop COPIED: drop
@@ -190,4 +203,7 @@ header NUMBER
header ( immediate header ( immediate
: PAREN 41 WORD drop ; : PAREN 41 WORD drop ;
header \ immediate 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! ! ;
v4/capsule/quit.v4
+6 -2
View File
@@ -22,7 +22,8 @@
\ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that. \ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that.
\ \
\ Constants the loader supplies: \ 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 \ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers
\ ( -- ) empty the return stack. `a` is only something to store: any \ ( -- ) 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 GO: drop
READ: READ:
$203E6B6F (EMIT4) \ "ok> " $203E6B6F (EMIT4) \ "ok> "
0 BLK a! ! \ the terminal, whatever was being loaded
QUERY QUERY
0 NODE-ERROR b! !b 0 NODE-ERROR b! !b
INTERPRET INTERPRET
@@ -96,7 +98,7 @@ header ABORT
-if POS drop 2 jump (REPL) -if POS drop 2 jump (REPL)
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4 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 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) drop 2 jump (REPL)
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 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) 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) 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) 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) 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 \ 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 \ fault in the node's order, each a jump. A jump fills its word, so they
v4/include/v4/node.h
+31
View File
@@ -92,6 +92,11 @@ typedef struct {
v4_cell dstack_reg; /* its word address, or -1 */ v4_cell dstack_reg; /* its word address, or -1 */
v4_cell rstack_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. */ /* NODE-ERROR as a trap (D-18). See v4_node_error_attach. */
v4_cell error_reg; /* its word address, or -1 */ v4_cell error_reg; /* its word address, or -1 */
} v4_node; } 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). */ * 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); 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 /* 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). * is guarded, shown, and returns the node to its prompt).
* *
v4/src/node.c
+40
View File
@@ -1,5 +1,6 @@
/* node.c -- the v4 node. See node.h. */ /* node.c -- the v4 node. See node.h. */
#include "v4/node.h" #include "v4/node.h"
#include <stddef.h>
void v4_node_reset(v4_node *n) 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_fault_attach(n, -1);
v4_node_stack_regs_attach(n, -1, -1); v4_node_stack_regs_attach(n, -1, -1);
v4_node_error_attach(n, -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) 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 (addr == n->rstack_reg) { v4_rstack_clear(&n->rs); return; }
if (!v4_node_addr_ok(addr)) return; if (!v4_node_addr_ok(addr)) return;
n->mem[(unsigned)addr] = value; 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. */ /* 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); if (addr == n->error_reg && value != 0) v4_node_fault(n, V4_FAULT_RAISED, value);
} }
v4/tests/host_map.h
+22 -1
View File
@@ -45,7 +45,6 @@
#define VOC_LINK (TOP - 50) /* the newest vocabulary */ #define VOC_LINK (TOP - 50) /* the newest vocabulary */
#define FENCE (TOP - 26) /* FORGET's lower limit */ #define FENCE (TOP - 26) /* FORGET's lower limit */
#define HLD (TOP - 25) /* where the pictured number has got to */ #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) */ /* buffers (word addresses; a byte address is four times this) */
#define CFS_W (TOP - 96) /* the control-flow stack, 32 cells */ #define CFS_W (TOP - 96) /* the control-flow stack, 32 cells */
@@ -59,6 +58,15 @@
#define HEND ((HBUF_W + 16) * 4) #define HEND ((HBUF_W + 16) * 4)
#define XVARS (HBUF_W - 4) /* (X): words.v4, 4 cells */ #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 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 WBUF (WBUF_W * 4)
#define TIB (TIB_W * 4) #define TIB (TIB_W * 4)
#define PAD (PAD_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, "(S)", SVARS);
v4_text_constant(tx, "(W)", WVARS); v4_text_constant(tx, "(W)", WVARS);
v4_text_constant(tx, "(X)", XVARS); 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, "(Q/)", QBASE); /* 5 cells */
v4_text_constant(tx, "(QE)", QBASE + 5); /* 8 */ v4_text_constant(tx, "(QE)", QBASE + 5); /* 8 */
v4_text_constant(tx, "(QR)", QBASE + 13); /* 5 */ 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[CONTEXT] = LATEST;
n->mem[CURRENT] = LATEST; n->mem[CURRENT] = LATEST;
n->mem[VOC_LINK] = 0; n->mem[VOC_LINK] = 0;
/* and the text interpreted is the terminal's */
n->mem[SRC] = TIB;
return 1; return 1;
} }
v4/tests/test_host_quit.c
+113 -2
View File
@@ -18,6 +18,9 @@
* v3 goes on compiling the lines that follow into it. * v3 goes on compiling the lines that follow into it.
* - ABORT" at the prompt stops the line when its flag is true. v3 prints * - 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). * 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 * - 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 * that vocabulary is CONTEXT, and FORTH is searched after it. v3 finds
* every word everywhere, and a word redefined in a vocabulary replaces * 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_text tx;
static v4_cell w_quit, w_key, w_key_end, w_fault, capsule_latest; static v4_cell w_quit, w_key, w_key_end, w_fault, capsule_latest;
static char out[V4_CONSOLE_CAP + 1]; 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; static long last_steps;
/* Run until the node has taken all its input and has been inside KEY, waiting, /* 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[CONTEXT] = LATEST;
n.mem[CURRENT] = LATEST; n.mem[CURRENT] = LATEST;
n.mem[VOC_LINK] = 0; 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_attach(&n, CONSOLE_TX);
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST); v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
v4_node_fault_attach(&n, w_fault); 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 }, { "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 }, { "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 }, { "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 */ /* 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 }, { ": 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 }, { ": 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); 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" }; 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, 11), "the capsule assembles"); 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_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space"); 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"); 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) ---- */ /* ---- vocabularies (FORTH-79) ---- */
boot_bare(); boot_bare();
CHECK(is(say("CONTEXT @ CURRENT @ = . ORDER\n"), "-1 Search order: FORTH \nCurrent: FORTH\n ok\nok> "), "at switch-on there is FORTH"); CHECK(is(say("CONTEXT @ CURRENT @ = . ORDER\n"), "-1 Search order: FORTH \nCurrent: FORTH\n ok\nok> "), "at switch-on there is FORTH");
v4/tests/test_node.c
+64
View File
@@ -195,6 +195,69 @@ static void test_out_of_range_word_address_touches_nothing(void)
free(n); 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) static void test_ends_are_distinguishable(void)
{ {
/* The two boundaries carry different patterns precisely so that a failure /* 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_low_is_caught();
test_linear_overrun_high_is_caught(); test_linear_overrun_high_is_caught();
test_out_of_range_word_address_touches_nothing(); test_out_of_range_word_address_touches_nothing();
test_storage_device();
test_ends_are_distinguishable(); test_ends_are_distinguishable();
test_workload_never_false_alarms(); test_workload_never_false_alarms();