From c10d3a9ccacb8c91fe1291ee66f226ef6b426d02 Mon Sep 17 00:00:00 2001 From: rajames Date: Sun, 4 Oct 2026 08:59:06 -0400 Subject: [PATCH] feat(v4.0.0): the dictionary: its space, its entries, and FIND The second layer of the compiler capsule, v4/capsule/dict.v4: HERE ALIGN ALLOT , C, 2, PAD LATEST; an entry layout reached entirely from the xt, with >LINK LFA LINK> >NAME NFA NAME> CFA PFA >BODY TRAVERSE SMUDGE HIDDEN on it; and FIND and ' . FIND is FORTH-79's and v3's. ' is FORTH-79's: the parameter field address, which for a code word is what FIND gives. ALLOT counts cells (D-1). 31 characters of a name are significant. Executed at both cell widths against a list of 300 entries kept in C. WORD no longer holds its length on the return stack. Co-Authored-By: Claude Opus 5.5 --- docs/v4.0.0/DECOMPOSITION.md | 23 +- v4/capsule/dict.v4 | 139 +++++++++++ v4/capsule/input.v4 | 10 +- v4/tests/test_host_dict.c | 444 +++++++++++++++++++++++++++++++++++ 4 files changed, 610 insertions(+), 6 deletions(-) create mode 100644 v4/capsule/dict.v4 create mode 100644 v4/tests/test_host_dict.c diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 409f9cc1..31f30a7a 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -674,14 +674,33 @@ The storage service belongs to the Artemis role, now a device node. | Word | Fate | Notes | | --- | --- | --- | -| `HERE` `ALIGN` `ALLOT` `,` `C,` `2,` `PAD` `LATEST` | CC | The dictionary lives on the host node. | +| `HERE` `ALIGN` `ALLOT` `,` `C,` `2,` `PAD` `LATEST` | CC | The dictionary lives on the host node; source in `v4/capsule/dict.v4`. The dictionary pointer `DP` is a byte address, so `C,` packs four characters to a cell; `HERE` is the next whole cell (a word address); `,` and `ALLOT` align first. An address unit is a cell (D-1), so `ALLOT` counts cells where v3's counted bytes; a negative count gives space back. `2,` stores the low cell first, as v3. Going outside the dictionary space stores nothing, moves nothing and sets `NODE-ERROR`. `PAD` is a fixed scratch area, as in v3, given as a byte address. `LATEST` is the xt of the newest entry, 0 if there is none (v3's pushes `HERE`, which looks like a bug; reported, not changed). Executed on the golden model's host node (2026-10-04). `,` and `ALLOT` leave their caller 6 data cells and 5 return entries. | | `SP@` `SP!` | RET | No visible stack pointer (D-2). | ### 5.13 Dictionary manipulation | Word | Fate | | --- | --- | -| `'` `FIND` `SMUDGE` `HIDDEN` `>BODY` `>NAME` `NAME>` `>LINK` `LINK>` `CFA` `LFA` `NFA` `PFA` `TRAVERSE` `INTERPRET` | CC | +| `FIND` | CC | `( -- xt \| 0 )`, FORTH-79 and v3 alike: the compilation address of the next word in the input stream, or 0 if it is not in the dictionary. `32 WORD` then a search from the newest entry back, skipping hidden ones; names are case sensitive, as v3, and 31 characters are significant (FORTH-79). Executed on the golden model's host node (2026-10-04) against a list kept in C, 300 entries. Leaves its caller 4 data cells and 2 return entries. | +| `'` | CC | `( -- addr )`, FORTH-79: the parameter field address of the next word in the input stream; not found is an error (0, and `NODE-ERROR` set). v3's `'` returned what `FIND` returns. For a word that is code the two are the same address; for a data word the parameter field is the cell after its code, which is what FORTH-79's `n ' NAME !` needs. Its compiling behaviour comes with the compiler words. Executed on the golden model's host node (2026-10-04). | +| `>LINK` `LFA` `LINK>` `>NAME` `NFA` `NAME>` `CFA` `PFA` `>BODY` `TRAVERSE` | CC | The fields of an entry, all reached from its xt, as in v3 where the xt was the entry: `>LINK`/`LFA` the link's address, `LINK>` the older entry's xt, `>NAME`/`NFA` the byte address of the counted name, `NAME>` back to the xt, `CFA` the xt itself, `PFA`/`>BODY` the parameter field, `TRAVERSE` from a name's count byte to past its last character (for `n > 0`; otherwise unchanged, as v3). Executed on the golden model's host node (2026-10-04). | +| `SMUDGE` `HIDDEN` | CC | `SMUDGE` toggles the hidden flag of the newest entry; `HIDDEN` sets it. v3 refuses both outside compilation; that check comes with the compiler words. Executed on the golden model's host node (2026-10-04). | +| `INTERPRET` | CC | | + +An entry, as `v4/capsule/dict.v4` builds it. A word's execution address (xt) is the address of its +code, and everything else is found from it: + +``` +name the count byte, then the characters, four bytes to a cell, zero-padded to a whole cell +xt - 3 flags: 1 immediate, 2 hidden, 4 data +xt - 2 the word address of the name +xt - 1 the link: the xt of the entry before this one, 0 for the first +xt the code +``` + +A name holds at most 31 characters. A *data* word (one made by `CREATE`, `VARIABLE` or `CONSTANT`) is +one whose code is a single call to its run-time routine, with its parameter field in the cell after +it, `xt + 1`; for any other word the parameter field is the code itself. ### 5.14 Vocabularies diff --git a/v4/capsule/dict.v4 b/v4/capsule/dict.v4 new file mode 100644 index 00000000..64835f10 --- /dev/null +++ b/v4/capsule/dict.v4 @@ -0,0 +1,139 @@ +\ dict.v4 -- the dictionary: its space, its entries, and looking a name up. +\ +\ DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND ' , +\ and the entry-field words >LINK LFA LINK> >NAME NFA NAME> CFA PFA >BODY +\ TRAVERSE SMUDGE HIDDEN. Part of the compiler capsule: it runs on the host +\ node. Rests on core.v4 and input.v4. +\ +\ AN ENTRY. A word's execution address (xt) is the address of its code, and +\ everything else is found from it: +\ +\ name the count byte, then the characters, four bytes to a cell, +\ padded with zeros to a whole cell +\ xt - 3 flags: 1 immediate, 2 hidden, 4 data +\ xt - 2 the word address of the name +\ xt - 1 the link: the xt of the entry before this one, 0 for the first +\ xt the code +\ +\ A name holds at most 31 characters; longer ones are cut to 31 both when +\ defined and when looked up, so 31 characters are significant (FORTH-79). +\ A "data" word is one whose code is a single call to its run-time routine, +\ with its parameter field in the cell after it: xt + 1. For any other word +\ the parameter field is the code itself. +\ +\ THE SPACE. DP is a byte address, so that C, can pack characters; HERE is +\ the next whole cell. An address unit is a cell (D-1): ALLOT counts cells. +\ +\ Constants the loader supplies: +\ DP word address of the variable: the next free byte +\ (LATEST) word address of the variable: the xt of the newest entry, or 0 +\ DBASE DLIMIT byte addresses of the start and end of dictionary space +\ PAD byte address of the scratch area for strings, 84 bytes or more +\ (D) word address of two cells of scratch for this file +\ PAD is in line. + +macro 4* 2* 2* endmacro +macro 4/ 2/ 2/ endmacro +macro OR over inv and xor endmacro + +\ ---- the space (5.12) ------------------------------------------------------ + +: (DERR) ( -- 0 ) NODE-ERROR b! -1 !b 0 ; + +\ ( n -- flag ) move DP by n bytes if it stays inside the dictionary space +\ and say -1; otherwise leave it, set NODE-ERROR and say 0. +: (DP+) + DP a! @ + + dup DBASE - -if LOW drop drop jump (DERR) + LOW: drop DLIMIT over - -if HIGH drop drop jump (DERR) + HIGH: drop DP a! ! -1 ; + +: HERE ( -- addr ) DP a! @ 3 + 4/ ; +: ALIGN ( -- ) DP a! @ 3 + -4 and DP a! ! ; +: ALLOT ( n -- ) ALIGN 4* (DP+) drop ; + +: , ( x -- ) + ALIGN HERE push 4 (DP+) if FULL drop pop a! ! ; + FULL: drop pop drop drop ; +: C, ( c -- ) + DP a! @ push 1 (DP+) if FULL drop pop C! ; + FULL: drop pop drop drop ; +: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3 + +: LATEST ( -- xt ) (LATEST) a! @ ; + +\ ---- the fields of an entry (5.13) ----------------------------------------- + +: (FLAGS) ( xt -- addr ) -3 + ; +: >LINK ( xt -- addr ) -1 + ; +: LFA ( xt -- addr ) jump >LINK +: LINK> ( addr -- xt ) a! @ ; +: >NAME ( xt -- baddr ) -2 + a! @ 4* ; +: NFA ( xt -- baddr ) jump >NAME +: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ; +: CFA ( xt -- xt ) ; +: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ; +: >BODY ( xt -- addr ) jump PFA + +\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the +\ byte after its last character; otherwise the address unchanged. +: TRAVERSE + -if NN drop ; + NN: if ZERO drop dup C@ 31 and + 1 + ; + ZERO: drop ; + +: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ; +: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ; + +\ ---- making an entry ------------------------------------------------------- + +\ ( baddr -- baddr ) cut the counted string to 31 characters, in place +: (CLIP) dup C@ -32 + -if LONG drop ; LONG: drop 31 over C! ; + +\ ( baddr -- ) an entry for the counted string at baddr; its code starts at +\ HERE afterwards. An empty name, or no room, makes nothing and sets +\ NODE-ERROR. +: (HEADER) + (CLIP) dup C@ if EMPTY \ baddr len + ALIGN + dup 4 + -4 and 12 + \ baddr len need bytes: name cells and three more + dup (DP+) if FULL drop NEGATE (DP+) drop \ there is room; DP back where it was + HERE (D) a! ! \ where the name starts + dup C, \ baddr len + L: if DONE SWAP 1 + dup C@ C, SWAP -1 + jump L \ nothing on R across C, + DONE: drop drop + P: DP a! @ 3 and if ALIGNED drop 0 C, jump P + ALIGNED: drop + 0 , (D) a! @ , LATEST , + HERE (LATEST) a! ! ; + FULL: drop drop + EMPTY: drop drop NODE-ERROR b! -1 !b ; + +\ ---- looking a name up ----------------------------------------------------- + +\ ( baddr1 baddr2 -- flag ) two counted strings are the same +: (NAME=) + over C@ 1 + \ b1 b2 n the count byte and the characters + L: if SAME push + over C@ over C@ xor if EQ drop drop drop pop drop 0 ; + EQ: drop 1 + push 1 + pop pop -1 + jump L + SAME: drop drop drop -1 ; + +\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string +: (LOOKUP) + (CLIP) (D) 1 + a! ! + LATEST + L: if END + dup (FLAGS) a! @ 2 and if VISIBLE jump OLDER + VISIBLE: drop dup >NAME (D) 1 + a! @ (NAME=) if OLDER drop ; + OLDER: drop >LINK a! @ jump L + END: ; + +\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the +\ input stream, or 0 if it is not in the dictionary. +: FIND 32 WORD jump (LOOKUP) + +\ ( -- addr ) FORTH-79: the parameter field address of the next word in the +\ input stream. Not found is an error: 0, and NODE-ERROR is set. +: ' 32 WORD (LOOKUP) if MISSING jump PFA + MISSING: drop jump (DERR) diff --git a/v4/capsule/input.v4 b/v4/capsule/input.v4 index 67a2ed0a..54187f75 100644 --- a/v4/capsule/input.v4 +++ b/v4/capsule/input.v4 @@ -42,7 +42,8 @@ macro BL 32 endmacro : QUERY TIB 80 EXPECT 0 >IN a! ! ; \ ---- WORD ------------------------------------------------------------------ -\ (P)+0 the delimiter, (P)+1 the length of the text in TIB. +\ (P)+0 the delimiter, (P)+1 the length of the text in TIB, (P)+2 the length +\ of the word (CONVERT uses (P)+2 too; the two never run inside each other). macro (WDELIM) (P) endmacro macro (WLEN) (P) 1 + endmacro @@ -70,11 +71,12 @@ macro (WLEN) (P) 1 + endmacro pop over over - \ end start len dup -256 + -if CAP drop jump FITS CAP: drop drop 255 FITS: dup WBUF C! - dup push push TIB + WBUF 1 + pop CMOVE \ end R: len + dup (P) 2 + a! ! \ the length waits in (P)+2, not on a stack + push TIB + WBUF 1 + pop CMOVE \ end (LEFT) -if RANOUT - drop (WDELIM) a! @ pop WBUF + 1 + C! \ the delimiter after the text + drop (WDELIM) a! @ (P) 2 + a! @ WBUF + 1 + C! \ the delimiter after the text 1 + >IN a! ! WBUF ; - RANOUT: drop 0 pop WBUF + 1 + C! + RANOUT: drop 0 (P) 2 + a! @ WBUF + 1 + C! >IN a! ! WBUF ; \ ---- ENCLOSE --------------------------------------------------------------- diff --git a/v4/tests/test_host_dict.c b/v4/tests/test_host_dict.c new file mode 100644 index 00000000..b2108aaa --- /dev/null +++ b/v4/tests/test_host_dict.c @@ -0,0 +1,444 @@ +/* test_host_dict.c -- the dictionary, executed on the host node. + * + * DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND + * and ', and the entry-field words. The definitions are text, + * capsule/dict.v4, on top of core.v4 and input.v4. + * + * v4's dictionary is new: v3's was a C structure and its words handed out + * host pointers. What carries over is what the words mean: + * HERE the next free address , C, 2, append a cell, a byte, a double + * ALLOT reserve space ALIGN round the pointer up to a cell + * FIND ( -- xt | 0 ) the word named next in the input, 0 if there is none + * (v3 and FORTH-79 agree, and so does v4) + * ' FORTH-79: its parameter field address; not found is an error. + * v3's ' returned what FIND returns. For a word that is code the + * two are the same address; for a data word (one made by CREATE, + * VARIABLE or CONSTANT) the parameter field is the cell after its + * code, which is what FORTH-79's n ' NAME ! idiom needs. + * xt as in v3, the one handle the field words take: >LINK LFA LINK> + * >NAME NFA NAME> CFA PFA >BODY + * An address unit is a cell (D-1), so ALLOT counts cells where v3's counted + * bytes, and HERE moves by 1 for a cell where v3's moved by 8. + * + * v3's LATEST pushes HERE, not the latest word (reported, not fixed); here + * it is the newest entry's xt. + */ +#include "v4/text.h" +#include "v4/testcode.h" +#include +#include +#include + +static int failures = 0, checks = 0; +#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0) + +#define CANARY ((v4_cell)0x0C0FFEE5) + +/* The memory map is open (D-4); the test chooses it. */ +#define TOP ((v4_cell)V4_NODE_WORDS) +#define NODE_ERROR (TOP - 2) +#define CONSOLE_TX (TOP - 4) +#define CONSOLE_RX (TOP - 6) +#define CONSOLE_ST (TOP - 7) +#define BASE (TOP - 8) +#define TO_IN (TOP - 9) +#define SPAN (TOP - 10) +#define PVARS (TOP - 16) +#define DP (TOP - 17) +#define LATEST (TOP - 18) +#define DVARS (TOP - 20) /* two cells */ +#define WBUF_W (TOP - 90) +#define TIB_W (TOP - 360) +#define SBUF_W (TOP - 440) +#define PAD_W (TOP - 470) +#define WBUF (WBUF_W * 4) +#define TIB (TIB_W * 4) +#define SBUF (SBUF_W * 4) +#define PAD (PAD_W * 4) +#define DICT_W ((v4_cell)4096) /* dictionary space: words 4096 .. 8191 */ +#define DICT_END_W ((v4_cell)8192) +#define GUARD ((v4_cell)0x5EED5EED) + +static v4_node n; +static v4_exec_state es; +static v4_heat h; +static v4_text tx; + +static unsigned char byte_at(v4_cell baddr) +{ + return (unsigned char)(((v4_ucell)n.mem[baddr >> 2] >> (8u * (unsigned)(baddr & 3))) & 0xFFu); +} +static void put_bytes(v4_cell baddr, const void *src, unsigned len) +{ + const unsigned char *s = (const unsigned char *)src; + for (unsigned i = 0; i < len; i++) { + v4_cell ba = baddr + (v4_cell)i; + unsigned sh = 8u * (unsigned)(ba & 3); + v4_ucell w = (v4_ucell)n.mem[ba >> 2]; + n.mem[ba >> 2] = (v4_cell)((w & ~((v4_ucell)0xFFu << sh)) | ((v4_ucell)s[i] << sh)); + } +} +static void set_line(const char *s) +{ + unsigned len = (unsigned)strlen(s); + put_bytes(TIB, s, len + 1u); + n.mem[SPAN] = (v4_cell)len; + n.mem[TO_IN] = 0; +} +static v4_cell W(const char *name) +{ + v4_cell w = v4_text_word(&tx, name); + if (w < 0) { failures++; printf("FAIL: no word %s\n", name); } + return w; +} +static void fresh(void) +{ + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + v4_heat_reset(&h); + n.mem[NODE_ERROR] = 0; + v4_dstack_push(&n.ds, CANARY); +} +static int go(const char *name) { return v4_test_call(&n, &es, &h, W(name), 4000000) > 0; } +static int run(const char *name, unsigned argc, v4_cell a, v4_cell b) +{ + fresh(); + if (argc > 0) v4_dstack_push(&n.ds, a); + if (argc > 1) v4_dstack_push(&n.ds, b); + return go(name); +} +static v4_cell pop(void) { return v4_dstack_pop(&n.ds); } +static int clean(void) { return pop() == CANARY; } +static int err(void) { return n.mem[NODE_ERROR] != 0; } +/* word ( -- x ) or ( a -- x ): its one result, or a value no test expects */ +static v4_cell get(const char *name, unsigned argc, v4_cell a) +{ + v4_cell r; + if (!run(name, argc, a, 0)) return (v4_cell)0x0BADBAD; + r = pop(); + return clean() ? r : (v4_cell)0x0BADBAD; +} + +static void empty_dictionary(void) +{ + for (v4_cell i = DICT_W - 1; i <= DICT_END_W; i++) n.mem[i] = GUARD; + n.mem[DP] = DICT_W * 4; + n.mem[LATEST] = 0; +} + +/* Make an entry named `name` through WORD and (HEADER); its xt, or 0 if + * none was made. */ +static v4_cell define(const char *name) +{ + v4_cell was = n.mem[LATEST]; + set_line(name); + if (!run("MAKE", 0, 0, 0) || !clean()) return 0; + return n.mem[LATEST] != was ? n.mem[LATEST] : 0; +} +/* FIND on the text `name`. */ +static v4_cell find(const char *name) +{ + set_line(name); + return get("FIND", 0, 0); +} +/* The counted name of entry xt is `want` (cut to 31), zero-padded to a cell, + * and its fields are in place. */ +static int entry_is(v4_cell xt, const char *want, v4_cell link, v4_cell flags) +{ + unsigned len = (unsigned)strlen(want), cells, i; + v4_cell nfa; + if (len > 31) len = 31; + cells = (len + 4) / 4; + nfa = xt - 3 - (v4_cell)cells; + if (n.mem[xt - 1] != link || n.mem[xt - 2] != nfa || n.mem[xt - 3] != flags) return 0; + if (byte_at(nfa * 4) != len) return 0; + for (i = 0; i < len; i++) if (byte_at(nfa * 4 + 1 + (v4_cell)i) != (unsigned char)want[i]) return 0; + for (i = len + 1; i < cells * 4; i++) if (byte_at(nfa * 4 + (v4_cell)i) != 0) return 0; + return 1; +} + +static uint32_t rng = 0x1234ABCDu; +static uint32_t rnd(void) { rng ^= rng << 13; rng ^= rng >> 17; rng ^= rng << 5; return rng; } + +/* Stack headroom, as in test_foundation.c. */ +typedef void (*setup_fn)(void); +static int fits(const char *name, setup_fn setup, unsigned argc, v4_cell a, unsigned nres, const v4_cell *want, + unsigned dfill, unsigned rfill) +{ + unsigned i; + setup(); + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + n.mem[NODE_ERROR] = 0; + for (i = 0; i < dfill; i++) v4_dstack_push(&n.ds, (v4_cell)(0x5A000000 + i)); + v4_dstack_push(&n.ds, CANARY); + if (argc > 0) v4_dstack_push(&n.ds, a); + for (i = 0; i < rfill; i++) v4_rstack_push(&n.rs, (v4_cell)(0x6B000000 + i)); + if (!go(name)) return 0; + for (i = nres; i-- > 0; ) if (pop() != want[i]) return 0; + if (pop() != CANARY) return 0; + for (i = dfill; i-- > 0; ) if (pop() != (v4_cell)(0x5A000000 + i)) return 0; + for (i = rfill; i-- > 0; ) if (v4_rstack_pop(&n.rs) != (v4_cell)(0x6B000000 + i)) return 0; + return !err(); +} +static void headroom(const char *name, setup_fn setup, unsigned argc, v4_cell a, unsigned nres, int min_d, int min_r) +{ + v4_cell want[2]; + unsigned i; + int dh, rh; + setup(); + CHECK(run(name, argc, a, 0), "%s runs", name); + for (i = nres; i-- > 0; ) want[i] = pop(); + for (dh = 0; dh < V4_DATA_DEPTH; dh++) if (!fits(name, setup, argc, a, nres, want, (unsigned)dh + 1u, 0)) break; + for (rh = 0; rh < V4_RET_DEPTH; rh++) if (!fits(name, setup, argc, a, nres, want, 0, (unsigned)rh + 1u)) break; + printf(" %-8s headroom: data %d below canary, return %d below its return address\n", name, dh, rh); + CHECK(dh >= min_d && rh >= min_r, "%s leaves room", name); +} +static void setup_three(void) +{ + empty_dictionary(); + (void)define("ALPHA"); (void)define("BETA"); (void)define("GAMMA"); + set_line("ALPHA rest"); +} +static void setup_new(void) { empty_dictionary(); set_line("NEWWORD rest"); } + +int main(void) +{ + unsigned i, t; + v4_cell a, b, c; + + printf("v4 host dictionary tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS); + + v4_node_reset(&n); + v4_text_begin(&tx, &n, 16); + v4_text_constant(&tx, "N-1", V4_CELL_BITS - 1); + v4_text_constant(&tx, "NODE-ERROR", NODE_ERROR); + v4_text_constant(&tx, "CONSOLE-TX", CONSOLE_TX); + v4_text_constant(&tx, "CONSOLE-RX", CONSOLE_RX); + v4_text_constant(&tx, "CONSOLE-STATUS", CONSOLE_ST); + v4_text_constant(&tx, "BASE", BASE); + v4_text_constant(&tx, "TIB", TIB); + v4_text_constant(&tx, ">IN", TO_IN); + v4_text_constant(&tx, "SPAN", SPAN); + v4_text_constant(&tx, "WBUF", WBUF); + v4_text_constant(&tx, "(P)", PVARS); + v4_text_constant(&tx, "DP", DP); + v4_text_constant(&tx, "(LATEST)", LATEST); + v4_text_constant(&tx, "DBASE", DICT_W * 4); + v4_text_constant(&tx, "DLIMIT", DICT_END_W * 4); + v4_text_constant(&tx, "PAD", PAD); + v4_text_constant(&tx, "(D)", DVARS); + CHECK(v4_text_assemble_file(&tx, V4_CAPSULE_DIR "/core.v4"), "core.v4 assembles: %s", v4_text_error(&tx)); + CHECK(v4_text_assemble_file(&tx, V4_CAPSULE_DIR "/input.v4"), "input.v4 assembles: %s", v4_text_error(&tx)); + CHECK(v4_text_assemble_file(&tx, V4_CAPSULE_DIR "/dict.v4"), "dict.v4 assembles: %s", v4_text_error(&tx)); + CHECK(v4_text_assemble(&tx, + ": MAKE ( -- ) 32 WORD jump (HEADER)\n" + ": 'PAD PAD ;\n" + ": DATA! ( -- ) LATEST (FLAGS) a! @ 4 OR ! ;\n" /* what CREATE will do */ + ": IMM! ( -- ) LATEST (FLAGS) a! @ 1 OR ! ;\n"), /* what IMMEDIATE will do */ + "wrappers: %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"); + printf(" code: %ld words\n", (long)v4_text_here(&tx) - 16); + if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; } + n.mem[BASE] = 10; + + /* ---- the space: HERE , C, 2, ALIGN ALLOT ---- */ + empty_dictionary(); + CHECK(get("HERE", 0, 0) == DICT_W, "HERE starts at the dictionary's first cell"); + CHECK(run(",", 1, 111, 0) && clean() && !err() && n.mem[DICT_W] == 111 && get("HERE", 0, 0) == DICT_W + 1, ", stores a cell and HERE moves by 1"); + CHECK(run(",", 1, -222, 0) && clean() && n.mem[DICT_W + 1] == -222 && get("HERE", 0, 0) == DICT_W + 2, "the next cell"); + + /* C, packs four to a cell; HERE is the next whole cell; , aligns first */ + n.mem[DICT_W + 2] = 0; + for (i = 0; i < 4; i++) { + CHECK(run("C,", 1, (v4_cell)(0x100 + 'a' + i), 0) && clean() && !err(), "C, [%u]", i); + CHECK(byte_at((DICT_W + 2) * 4 + (v4_cell)i) == 'a' + i, "C, stores the low byte at the next byte [%u]", i); + CHECK(get("HERE", 0, 0) == DICT_W + 3, "HERE is the next whole cell after %u bytes", i + 1); + } + CHECK(run("C,", 1, 'e', 0) && clean() && get("HERE", 0, 0) == DICT_W + 4 && n.mem[DP] == (DICT_W + 3) * 4 + 1, "a fifth byte starts another cell"); + CHECK(run(",", 1, 333, 0) && clean() && n.mem[DICT_W + 4] == 333 && n.mem[DP] == (DICT_W + 5) * 4, ", after C, goes in the next whole cell"); + CHECK(byte_at((DICT_W + 3) * 4) == 'e', "and leaves the byte alone"); + CHECK(run("C,", 1, 'f', 0) && clean() && run("ALIGN", 0, 0, 0) && clean() && n.mem[DP] == (DICT_W + 6) * 4, "ALIGN rounds up to a cell"); + CHECK(run("ALIGN", 0, 0, 0) && clean() && n.mem[DP] == (DICT_W + 6) * 4, "ALIGN when aligned does nothing"); + + /* 2, : the low cell first, as v3 (HERE 1 2 2, : the first cell holds 1) */ + CHECK(run("2,", 2, 1, 2) && clean() && n.mem[DICT_W + 6] == 1 && n.mem[DICT_W + 7] == 2 && get("HERE", 0, 0) == DICT_W + 8, "v3: 2, stores the low cell first"); + + /* ALLOT counts cells */ + CHECK(run("ALLOT", 1, 5, 0) && clean() && !err() && get("HERE", 0, 0) == DICT_W + 13, "5 ALLOT reserves five cells"); + CHECK(run("ALLOT", 1, 0, 0) && clean() && get("HERE", 0, 0) == DICT_W + 13, "0 ALLOT reserves none"); + CHECK(run("ALLOT", 1, -3, 0) && clean() && !err() && get("HERE", 0, 0) == DICT_W + 10, "-3 ALLOT gives three back"); + CHECK(run("C,", 1, 'x', 0) && run("ALLOT", 1, 2, 0) && clean() && get("HERE", 0, 0) == DICT_W + 13 + && n.mem[DP] == (DICT_W + 13) * 4, "ALLOT aligns first"); + CHECK(n.mem[DICT_W - 1] == GUARD, "nothing below the dictionary space written"); + + /* the ends of the space */ + empty_dictionary(); + CHECK(run("ALLOT", 1, -1, 0) && clean() && err() && get("HERE", 0, 0) == DICT_W, "ALLOT below the start is refused and sets NODE-ERROR"); + CHECK(run("ALLOT", 1, DICT_END_W - DICT_W, 0) && clean() && !err() && get("HERE", 0, 0) == DICT_END_W, "the whole space can be allotted"); + CHECK(run(",", 1, 99, 0) && clean() && err() && n.mem[DICT_END_W] == GUARD && get("HERE", 0, 0) == DICT_END_W, ", into a full dictionary stores nothing and sets NODE-ERROR"); + CHECK(run("C,", 1, 99, 0) && clean() && err() && n.mem[DICT_END_W] == GUARD, "so does C,"); + CHECK(run("ALLOT", 1, 1, 0) && clean() && err() && get("HERE", 0, 0) == DICT_END_W, "and ALLOT"); + CHECK(run("ALLOT", 1, -1, 0) && clean() && !err() && run(",", 1, 77, 0) && clean() && !err() && n.mem[DICT_END_W - 1] == 77, "the last cell can be used"); + CHECK(get("'PAD", 0, 0) == PAD, "PAD is its buffer's byte address"); + + /* ---- entries ---- */ + empty_dictionary(); + CHECK(get("LATEST", 0, 0) == 0, "LATEST is 0 in an empty dictionary"); + a = define("ALPHA"); + CHECK(a == DICT_W + 2 + 3 && !err(), "an entry's xt follows its name and three cells: %ld", (long)a); + CHECK(entry_is(a, "ALPHA", 0, 0), "the first entry: name, no flags, link 0"); + CHECK(get("LATEST", 0, 0) == a && get("HERE", 0, 0) == a, "LATEST is its xt, and its code starts at HERE"); + CHECK(run(",", 1, 1001, 0) && clean(), "some code"); + b = define("B"); + CHECK(b == a + 1 + 1 + 3 && entry_is(b, "B", a, 0), "the second entry links to the first"); + (void)run(",", 1, 1002, 0); + c = define("GAMMA-DELTA"); + CHECK(c == b + 1 + 3 + 3 && entry_is(c, "GAMMA-DELTA", b, 0), "an eleven-character name takes three cells"); + CHECK(get("LATEST", 0, 0) == c, "LATEST is the newest"); + + /* the field words, all from the xt */ + CHECK(get(">LINK", 1, c) == c - 1 && get("LFA", 1, c) == c - 1, ">LINK and LFA are the link's address"); + CHECK(get("LINK>", 1, c - 1) == b && get("LINK>", 1, b - 1) == a && get("LINK>", 1, a - 1) == 0, "LINK> follows it, to 0 at the end"); + CHECK(get(">NAME", 1, c) == (c - 6) * 4 && get("NFA", 1, c) == (c - 6) * 4, ">NAME and NFA are the name's byte address"); + CHECK(byte_at(get(">NAME", 1, b)) == 1 && byte_at(get(">NAME", 1, b) + 1) == 'B', "which is its count byte, then its characters"); + CHECK(get("NAME>", 1, get(">NAME", 1, a)) == a && get("NAME>", 1, get(">NAME", 1, b)) == b && get("NAME>", 1, get(">NAME", 1, c)) == c, "NAME> goes back to the xt"); + CHECK(get("CFA", 1, c) == c, "CFA is the xt itself, as v3"); + CHECK(get("PFA", 1, c) == c && get(">BODY", 1, c) == c, "the parameter field of a code word is its code"); + CHECK(run("DATA!", 0, 0, 0) && clean() && n.mem[c - 3] == 4, "(marking the newest a data word)"); + CHECK(get("PFA", 1, c) == c + 1 && get(">BODY", 1, c) == c + 1, "the parameter field of a data word is the cell after its code"); + CHECK(get("PFA", 1, b) == b, "and the others are unchanged"); + { + v4_cell nfa = get(">NAME", 1, c); + CHECK(run("TRAVERSE", 2, nfa, 1) && pop() == nfa + 12 && clean(), "TRAVERSE forward goes past the name's last character"); + CHECK(run("TRAVERSE", 2, nfa, 5) && pop() == nfa + 12 && clean(), "for any positive n"); + CHECK(run("TRAVERSE", 2, nfa, -1) && pop() == nfa && clean(), "TRAVERSE backward leaves the address, as v3"); + CHECK(run("TRAVERSE", 2, nfa, 0) && pop() == nfa && clean(), "and so does 0"); + } + + /* SMUDGE toggles the newest entry's hidden bit; HIDDEN sets it */ + CHECK(run("SMUDGE", 0, 0, 0) && clean() && n.mem[c - 3] == 6, "SMUDGE hides the newest entry, keeping its other flags"); + CHECK(run("SMUDGE", 0, 0, 0) && clean() && n.mem[c - 3] == 4, "SMUDGE again shows it"); + CHECK(run("HIDDEN", 0, 0, 0) && clean() && n.mem[c - 3] == 6 && run("HIDDEN", 0, 0, 0) && clean() && n.mem[c - 3] == 6, "HIDDEN hides it, once or twice"); + CHECK(n.mem[b - 3] == 0 && n.mem[a - 3] == 0, "the others are untouched"); + CHECK(run("SMUDGE", 0, 0, 0) && clean() && n.mem[c - 3] == 4, "shown again"); + empty_dictionary(); + CHECK(run("SMUDGE", 0, 0, 0) && clean() && run("HIDDEN", 0, 0, 0) && clean() && n.mem[DICT_W] == GUARD && n.mem[DICT_W - 1] == GUARD, + "SMUDGE and HIDDEN do nothing in an empty dictionary"); + + /* names: empty, long, and the edge of the space */ + empty_dictionary(); + CHECK(define("") == 0 && err() && get("HERE", 0, 0) == DICT_W && n.mem[LATEST] == 0, "an empty name makes nothing and sets NODE-ERROR"); + { + char long31[40], long40[48]; + memset(long31, 'q', 31); long31[31] = 0; + memset(long40, 'q', 40); long40[40] = 0; + a = define(long31); + CHECK(a == DICT_W + 8 + 3 && entry_is(a, long31, 0, 0), "a 31-character name is kept whole"); + b = define(long40); + CHECK(b != 0 && entry_is(b, long31, a, 0) && b - a == 8 + 3, "a 40-character name is cut to 31"); + } + empty_dictionary(); + n.mem[DP] = (DICT_END_W - 4) * 4; + CHECK(define("ABCD") == 0 && err() && n.mem[LATEST] == 0 && n.mem[DP] == (DICT_END_W - 4) * 4 && n.mem[DICT_END_W - 4] == GUARD, + "an entry that does not fit makes nothing, moves nothing, and sets NODE-ERROR"); + n.mem[DP] = (DICT_END_W - 5) * 4; + CHECK(define("ABCD") == DICT_END_W && !err() && n.mem[DICT_END_W] == GUARD, "one that just fits is made"); + + /* ---- FIND ---- */ + empty_dictionary(); + CHECK(find("ANYTHING") == 0 && !err(), "FIND in an empty dictionary is 0, and no error"); + a = define("ALPHA"); (void)run(",", 1, 1, 0); + b = define("BETA"); (void)run(",", 1, 2, 0); + c = define("GAMMA"); (void)run(",", 1, 3, 0); + CHECK(find("ALPHA") == a && find("BETA") == b && find("GAMMA") == c && !err(), "FIND finds each word"); + CHECK(find("DELTA") == 0 && find("ALPH") == 0 && find("ALPHAS") == 0 && find("LPHA") == 0 && !err(), "and not what is not there, nor a part of a name"); + CHECK(find("alpha") == 0 && find("Alpha") == 0, "names are case sensitive, as v3"); + CHECK(find(" BETA and more") == b && n.mem[TO_IN] == 8, "FIND takes the next word of the input stream and leaves >IN after it"); + CHECK(find("") == 0 && find(" ") == 0 && !err(), "at the end of the input it is 0"); + { + v4_cell a2 = define("ALPHA"); + CHECK(a2 != 0 && a2 != a && find("ALPHA") == a2, "a later word of the same name is the one found"); + CHECK(run("SMUDGE", 0, 0, 0) && find("ALPHA") == a, "hidden, the earlier one is found again"); + CHECK(run("SMUDGE", 0, 0, 0) && find("ALPHA") == a2, "shown, the later"); + CHECK(run("HIDDEN", 0, 0, 0) && find("ALPHA") == a && find("BETA") == b, "HIDDEN hides only the newest"); + } + /* 31 characters are significant */ + { + char n31[40], n32a[40], n32b[40], n30[40]; + empty_dictionary(); + memset(n31, 'k', 31); n31[31] = 0; + memcpy(n32a, n31, 31); n32a[31] = 'X'; n32a[32] = 0; + memcpy(n32b, n31, 31); n32b[31] = 'Y'; n32b[32] = 0; + memset(n30, 'k', 30); n30[30] = 0; + a = define(n32a); + CHECK(find(n32a) == a && find(n32b) == a && find(n31) == a, "names that agree in their first 31 characters are the same name"); + CHECK(find(n30) == 0, "one that is shorter is not"); + n31[30] = 'j'; + CHECK(find(n31) == 0, "nor one that differs in the 31st"); + } + + /* ---- ' ---- */ + empty_dictionary(); + a = define("CODEWORD"); (void)run(",", 1, 1, 0); + b = define("DATAWORD"); (void)run("DATA!", 0, 0, 0); (void)run(",", 1, 2, 0); (void)run(",", 1, 55, 0); + set_line("CODEWORD x"); + CHECK(get("'", 0, 0) == a && !err() && n.mem[TO_IN] == 9, "' of a code word is its code address, which is what FIND gives"); + set_line("DATAWORD"); + CHECK(get("'", 0, 0) == b + 1 && !err() && n.mem[b + 1] == 55, "' of a data word is its parameter field"); + set_line("NOSUCHWORD"); + CHECK(get("'", 0, 0) == 0 && err(), "' of a word that is not there is an error"); + + /* ---- many words, against a list kept in C ---- */ + { + static char names[300][36]; + static v4_cell xts[300]; + unsigned count = 0; + empty_dictionary(); + for (t = 0; t < 300; t++) { + unsigned len = 1 + rnd() % (t % 7 == 0 ? 34 : 9), dup = 0; + char *nm = names[count]; + for (i = 0; i < len; i++) nm[i] = (char)("ABCDEFGHab01-+*/!@"[rnd() % 18]); + nm[len] = 0; + xts[count] = define(nm); + CHECK(xts[count] != 0 && !err(), "defining \"%s\"", nm); + (void)run(",", 1, (v4_cell)t, 0); + if (len > 31) nm[31] = 0; + for (i = 0; i < count; i++) if (strcmp(names[i], nm) == 0) dup = 1; + (void)dup; + count++; + } + for (t = 0; t < count; t++) { + v4_cell want = 0; + for (i = 0; i < count; i++) if (strcmp(names[i], names[t]) == 0) want = xts[i]; /* the newest of that name */ + CHECK(find(names[t]) == want, "FIND \"%s\"", names[t]); + } + /* walk the links from LATEST: every entry, newest first, then 0 */ + { + v4_cell xt = get("LATEST", 0, 0); + for (t = count; t-- > 0; ) { + if (xt != xts[t]) break; + if (get("NAME>", 1, get(">NAME", 1, xt)) != xt) break; + xt = get("LINK>", 1, get(">LINK", 1, xt)); + } + CHECK(t == (unsigned)-1 && xt == 0, "the links run through all %u entries, newest first", count); + } + printf(" %u entries in %ld cells\n", count, (long)(get("HERE", 0, 0) - DICT_W)); + CHECK(n.mem[DICT_W - 1] == GUARD && n.mem[DICT_END_W] == GUARD, "nothing outside the dictionary space written"); + } + + /* What they leave their caller (D-2). */ + headroom("FIND", setup_three, 0, 0, 1, 3, 2); + headroom("'", setup_three, 0, 0, 1, 3, 2); + headroom("MAKE", setup_new, 0, 0, 0, 3, 2); + headroom(",", setup_new, 1, 42, 0, 5, 5); + headroom("ALLOT", setup_new, 1, 3, 0, 5, 5); + + CHECK(v4_node_guards_intact(&n), "guards intact"); + + printf(" %d checks, %d failures\n", checks, failures); + return failures ? 1 : 0; +}