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
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
\ 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
v4/capsule/input.v4
+21 -5
View File
@@ -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! ! ;
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.
\
\ 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
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 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).
*
v4/src/node.c
+40
View File
@@ -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);
}
v4/tests/host_map.h
+22 -1
View File
@@ -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;
}
v4/tests/test_host_quit.c
+113 -2
View File
@@ -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");
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);
}
/* 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();