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 <noreply@anthropic.com>
This commit is contained in:
rajames
co-authored by
Claude Opus 5.5
Claude Opus 5.5
parent
0fbe1432b7
commit
c8dc14897c
@@ -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). |
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
+21
-5
@@ -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! ! ;
|
||||
|
||||
+6
-2
@@ -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
|
||||
|
||||
@@ -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).
|
||||
*
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
/* node.c -- the v4 node. See node.h. */
|
||||
#include "v4/node.h"
|
||||
#include <stddef.h>
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
+22
-1
@@ -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;
|
||||
}
|
||||
|
||||
|
||||
+113
-2
@@ -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");
|
||||
|
||||
@@ -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();
|
||||
|
||||
|
||||
Reference in New Issue
Block a user