From 880560fc009b1395d0a3a7eedfdf573e8079e58c Mon Sep 17 00:00:00 2001 From: rajames Date: Sun, 4 Oct 2026 09:19:57 -0400 Subject: [PATCH] feat(v4.0.0): the code generator The third layer of the compiler capsule, v4/capsule/codegen.v4: opcodes, literals and branches packed into instruction words at HERE, by the rules of sections 1.2 and 2. (OP,) (LIT,) (LABEL) (BRANCH,) (JUMP,) (CALL,) (BRANCH>) (RESOLVE) (FLUSH) (CG-RESET). Tested by laying the same programmes down with the text assembler on one node and with the code generator, running, on another, and comparing memory word for word: every opcode, literals and branches in every slot position, and 600 random programmes. What it lays down is then run. Co-Authored-By: Claude Opus 5.5 --- docs/v4.0.0/DECOMPOSITION.md | 21 ++ v4/capsule/codegen.v4 | 104 ++++++++++ v4/tests/test_host_codegen.c | 371 +++++++++++++++++++++++++++++++++++ 3 files changed, 496 insertions(+) create mode 100644 v4/capsule/codegen.v4 create mode 100644 v4/tests/test_host_codegen.c diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 31f30a7a..8adbd714 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -736,6 +736,27 @@ it, `xt + 1`; for any other word the parameter field is the code itself. | `LIT` | OP | `@p` | | `does_rt` | RET | Internal helper; `DOES>` is implemented by the compiler capsule. | +**The code generator** (`v4/capsule/codegen.v4`) is what these words are built on. It packs opcodes, +literals and branches into instruction words at `HERE`, by the rules of §1.2 and §2: slots filled left +to right, unused slots `nop`, a literal's value in the cell after its word, `;` `ex` and any branch +closing the word. A branch goes only in a slot whose address field reaches all of the node's memory +(slots 0–2 on a 16,384-word host node, 0–3 on a 1,024-word one); otherwise it starts the next word, so +no reach check is ever needed. + +| Word | Does | +| --- | --- | +| `(OP,)` | `( op -- )` any opcode that is neither a branch nor `@p` | +| `(LIT,)` | `( x -- )` `@p` and its value | +| `(LABEL)` | `( -- addr )` closes the word being built; the address of the next: a branch target | +| `(BRANCH,)` | `( target op -- )` a branch to a known address; `(JUMP,)` and `(CALL,)` `( addr -- )` are the two commonest | +| `(BRANCH>)` `(RESOLVE)` | `( op -- ref )` a branch whose address is not known yet, and `( target ref -- )` filling it in | +| `(FLUSH)` `(CG-RESET)` | append the word being built; forget it | + +Executed on the golden model's host node (2026-10-04) by laying the same programmes down with the text +assembler on one node and with the code generator, running, on another, and comparing memory word for +word: every opcode, literals and branches in every slot position, and 600 random programmes. What it +lays down was then run. + ### 5.18 Control flow | Word | Fate | v4 definition / notes | diff --git a/v4/capsule/codegen.v4 b/v4/capsule/codegen.v4 new file mode 100644 index 00000000..014184cf --- /dev/null +++ b/v4/capsule/codegen.v4 @@ -0,0 +1,104 @@ +\ codegen.v4 -- the code generator: opcodes, literals and branches packed into +\ instruction words at HERE. +\ +\ This is what the compiling words ( : ; IF LOOP LITERAL ... ) are built on. +\ It lays code down exactly as DECOMPOSITION.md 1.2 and 2 require and as the +\ test harness's own packers do (v4/include/v4/asm.h, text.h): +\ +\ - opcodes fill slots 0 .. 5 of a word left to right; a full word is +\ appended to the dictionary and a new one started; unused slots are nop +\ - a literal is @p in a slot and its value in the cell after the word; +\ several in one word follow it in order +\ - ; and ex close the word, since nothing after them runs +\ - a branch closes the word: the bits to its right are its address +\ - a branch goes only in a slot whose address field reaches all of the +\ node's memory; otherwise the word is closed first and the branch starts +\ the next one. So no branch ever needs a reach check. +\ +\ An instruction word is 32 bits at every cell width (D-9): slot k is the five +\ bits whose lowest is bit 27 - 5k, and a branch there has 27 - 5k address bits. +\ +\ Rests on core.v4 and dict.v4. Constants the loader supplies: +\ (CG) word address of nine cells: the word being built, the next +\ free slot, the number of literals it owes, and up to six of them +\ CG-BSLOTS how many slots, counted from slot 0, may hold a branch + +macro (CUR) (CG) endmacro +macro (SLOT) (CG) 1 + endmacro +macro (NLIT) (CG) 2 + endmacro +macro (LITS) (CG) 3 + endmacro + +\ ( x n -- x' ) x shifted left n places, n >= 0 +: (LSHIFT) if Z -1 + push L: 2* next L ; Z: drop ; + +\ ( k -- n ) the number of the lowest bit of slot k: 27 - 5k +: (LOWBIT) dup 2* 2* + NEGATE 27 + ; + +\ ( k -- mask ) the address bits of a branch in slot k +: (MASK) (LOWBIT) 1 SWAP (LSHIFT) -1 + ; + +\ ( -- ) forget the word being built +: (CG-RESET) 0 (CUR) a! ! 0 (SLOT) a! ! 0 (NLIT) a! ! ; + +\ ( op -- ) into the next free slot. The slot must be free. +: (PUT) + (SLOT) a! @ dup 1 + ! \ op k + (LOWBIT) (LSHIFT) + (CUR) a! @ + ! ; + +\ ( -- ) append the word being built, its unused slots nop, then the +\ literals it owes; nothing if no slot is in use +: (FLUSH) + (SLOT) a! @ if EMPTY drop + P: (SLOT) a! @ -6 + if FULL drop 28 (PUT) jump P + FULL: drop + (CUR) a! @ , + 0 L: dup (NLIT) a! @ xor if DONE + drop dup (LITS) + a! @ , 1 + jump L + DONE: drop drop + jump (CG-RESET) + EMPTY: drop ; + +\ ( op -- ) any opcode that is neither a branch nor @p +: (OP,) + dup push (PUT) pop + if ENDS -1 + if ENDS \ ; and ex end the word + drop (SLOT) a! @ -6 + if ENDS drop ; \ and so does its last slot + ENDS: drop jump (FLUSH) + +\ ( x -- ) @p and its value +: (LIT,) + (NLIT) a! @ dup 1 + ! \ x n + (LITS) + a! ! + 8 (PUT) + (SLOT) a! @ -6 + if FULL drop ; + FULL: drop jump (FLUSH) + +\ ( -- addr ) where the next word will go: a branch target +: (LABEL) (FLUSH) HERE ; + +\ ( op -- ref ) a branch (jump 2, call 3, next 5, if 6, -if 7) whose address +\ is filled in later by (RESOLVE). ref is the branch's word address times 8, +\ plus its slot. +: (BRANCH>) + (SLOT) a! @ CG-BSLOTS - -if MOVE drop jump PLACED + MOVE: drop (FLUSH) + PLACED: + \ the word will be appended at HERE; its literals, if any, come after it + HERE 2* 2* 2* (SLOT) a! @ + push + (PUT) + 6 (SLOT) a! ! (FLUSH) + pop ; + +\ ( target ref -- ) put the address into the branch at ref +: (RESOLVE) + dup 7 and (MASK) push \ target ref R: mask + 2/ 2/ 2/ a! \ target A: the branch's word + pop dup push and \ the address bits + @ pop inv and + ! ; + +\ ( target op -- ) a branch to a known address +: (BRANCH,) (BRANCH>) jump (RESOLVE) + +: (JUMP,) ( addr -- ) 2 jump (BRANCH,) +: (CALL,) ( addr -- ) 3 jump (BRANCH,) diff --git a/v4/tests/test_host_codegen.c b/v4/tests/test_host_codegen.c new file mode 100644 index 00000000..58a97657 --- /dev/null +++ b/v4/tests/test_host_codegen.c @@ -0,0 +1,371 @@ +/* test_host_codegen.c -- the code generator, executed on the host node. + * + * capsule/codegen.v4 packs opcodes, literals and branches into instruction + * words at HERE; it is what the compiling words will be built on. It is the + * third thing in this tree that does that job -- after the slot packer in C + * (asm.h) and the text assembler on top of it (text.h) -- and the first that + * is itself v4 code. So the test is a comparison: the same programme is laid + * down twice, once by the text assembler on one node and once by the code + * generator running on another, at the same address, and the two memories + * must be the same word for word. Then what the generator made is run. + */ +#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) +#define MAXU ((v4_ucell)~(v4_ucell)0) + +/* 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) +#define CGVARS (TOP - 30) /* nine cells */ +#define WBUF_W (TOP - 90) +#define TIB_W (TOP - 360) +#define PAD_W (TOP - 470) +#define DICT_W ((v4_cell)8192) /* dictionary space: words 8192 .. 12287 */ +#define DICT_END_W ((v4_cell)12288) + +static v4_node n, ref; /* the generator's node; the text assembler's */ +static v4_exec_state es; +static v4_heat h; +static v4_text tx, rtx; /* the capsule on n; the reference programme on ref */ + +static const char *const mnemonic[V4_OPCODE_COUNT] = { + ";", "ex", "jump", "call", "unext", "next", "if", "-if", "@p", "@+", "@b", "@", "!p", "!+", "!b", "!", + "+*", "2*", "2/", "inv", "+", "and", "xor", "drop", "dup", "pop", "over", "a", "nop", "push", "b!", "a!" }; + +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 int run(const char *name, unsigned argc, v4_cell a, v4_cell b) +{ + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + v4_heat_reset(&h); + v4_dstack_push(&n.ds, CANARY); + if (argc > 0) v4_dstack_push(&n.ds, a); + if (argc > 1) v4_dstack_push(&n.ds, b); + return v4_test_call(&n, &es, &h, W(name), 100000) > 0; +} +static v4_cell pop(void) { return v4_dstack_pop(&n.ds); } +static int clean(void) { return pop() == CANARY; } +/* a word that takes its arguments and leaves nothing */ +static int did(const char *name, unsigned argc, v4_cell a, v4_cell b) { return run(name, argc, a, b) && clean(); } +/* a word that leaves one cell */ +static v4_cell get(const char *name, unsigned argc, v4_cell a, v4_cell b) +{ + v4_cell r; + if (!run(name, argc, a, b)) return (v4_cell)0x0BADBAD; + r = pop(); + return clean() ? r : (v4_cell)0x0BADBAD; +} + +/* ---- a programme, described once and laid down twice --------------------- */ + +enum { K_OP, K_LIT, K_LABEL, K_BACK, K_FWD, K_HERE }; /* K_HERE resolves a K_FWD */ +typedef struct { int kind; unsigned op; v4_cell value; int label; } item; + +#define MAX_ITEMS 400 +static item prog[MAX_ITEMS]; +static unsigned nprog; + +static void p_op(unsigned op) { prog[nprog].kind = K_OP; prog[nprog].op = op; nprog++; } +static void p_lit(v4_cell v) { prog[nprog].kind = K_LIT; prog[nprog].value = v; nprog++; } +static void p_label(int l) { prog[nprog].kind = K_LABEL; prog[nprog].label = l; nprog++; } +static void p_back(unsigned op, int l) { prog[nprog].kind = K_BACK; prog[nprog].op = op; prog[nprog].label = l; nprog++; } +static void p_fwd(unsigned op, int l) { prog[nprog].kind = K_FWD; prog[nprog].op = op; prog[nprog].label = l; nprog++; } +static void p_here(int l) { prog[nprog].kind = K_HERE; prog[nprog].label = l; nprog++; } + +/* By the text assembler, on `ref`, at the dictionary's first word. */ +static int lay_by_text(void) +{ + static char src[MAX_ITEMS * 40]; + size_t at = 0; + unsigned i; + at += (size_t)sprintf(src + at, ": PROG "); + for (i = 0; i < nprog; i++) { + const item *it = &prog[i]; + switch (it->kind) { + case K_OP: at += (size_t)sprintf(src + at, "%s ", mnemonic[it->op]); break; +#if V4_CELL_BITS == 32 + case K_LIT: at += (size_t)sprintf(src + at, "%ld ", (long)it->value); break; +#else + case K_LIT: at += (size_t)sprintf(src + at, "%lld ", (long long)it->value); break; +#endif + case K_LABEL: at += (size_t)sprintf(src + at, "B%d: ", it->label); break; + case K_BACK: at += (size_t)sprintf(src + at, "%s B%d ", mnemonic[it->op], it->label); break; + case K_FWD: at += (size_t)sprintf(src + at, "%s F%d ", mnemonic[it->op], it->label); break; + case K_HERE: at += (size_t)sprintf(src + at, "F%d: ", it->label); break; + } + } + v4_node_reset(&ref); + v4_text_begin(&rtx, &ref, DICT_W); + return v4_text_assemble(&rtx, src) && v4_text_finish(&rtx); +} + +/* By the code generator, on `n`: one call to a word of codegen.v4 for each + * item, as the compiling words will make them. */ +static int lay_by_generator(void) +{ + static v4_cell back[64], fwd[64]; + unsigned i; + for (v4_cell k = DICT_W; k < DICT_END_W; k++) n.mem[k] = 0; + n.mem[DP] = DICT_W * 4; + n.mem[NODE_ERROR] = 0; + if (!did("(CG-RESET)", 0, 0, 0)) return 0; + for (i = 0; i < nprog; i++) { + const item *it = &prog[i]; + switch (it->kind) { + case K_OP: if (!did("(OP,)", 1, (v4_cell)it->op, 0)) return 0; break; + case K_LIT: if (!did("(LIT,)", 1, it->value, 0)) return 0; break; + case K_LABEL: back[it->label] = get("(LABEL)", 0, 0, 0); break; + case K_BACK: if (!did("(BRANCH,)", 2, back[it->label], (v4_cell)it->op)) return 0; break; + case K_FWD: fwd[it->label] = get("(BRANCH>)", 1, (v4_cell)it->op, 0); break; + case K_HERE: { v4_cell here = get("(LABEL)", 0, 0, 0); if (!did("(RESOLVE)", 2, here, fwd[it->label])) return 0; } break; + } + } + return did("(FLUSH)", 0, 0, 0) && n.mem[NODE_ERROR] == 0; +} + +/* Lay the programme down both ways; 1 if the two are the same. */ +static int same(const char *what) +{ + v4_cell end_ref, end_gen, k; + if (!lay_by_text()) { printf(" %s: the text assembler refused it: %s\n", what, v4_text_error(&rtx)); return 0; } + if (!lay_by_generator()) { printf(" %s: the generator did not finish\n", what); return 0; } + end_ref = v4_text_here(&rtx); + end_gen = (n.mem[DP] + 3) / 4; + if (end_ref != end_gen) { printf(" %s: lengths differ: %ld by text, %ld by the generator\n", what, (long)(end_ref - DICT_W), (long)(end_gen - DICT_W)); return 0; } + for (k = DICT_W; k < end_ref + 8; k++) + if (n.mem[k] != ref.mem[k]) { + printf(" %s: word %ld differs: %llx by text, %llx by the generator\n", what, (long)(k - DICT_W), + (unsigned long long)(v4_ucell)ref.mem[k], (unsigned long long)(v4_ucell)n.mem[k]); + return 0; + } + return 1; +} + +static uint32_t rng = 0x7F4A7C15u; +static uint32_t rnd(void) { rng ^= rng << 13; rng ^= rng >> 17; rng ^= rng << 5; return rng; } + +static const unsigned plain_ops[] = { /* every opcode but the branches and @p */ + 0, 1, 4, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31 }; +static const unsigned branch_ops[] = { 2, 3, 5, 6, 7 }; +static const v4_cell lits[] = { 0, 1, -1, 2, 255, 65536, -65536, 12345678, (v4_cell)V4_MSB, (v4_cell)(V4_MSB - 1u), (v4_cell)(MAXU / 3u) }; + +/* Run the programme the generator laid down, as a word. */ +static int exec_prog(unsigned argc, v4_cell a, v4_cell b) +{ + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + v4_dstack_push(&n.ds, CANARY); + if (argc > 0) v4_dstack_push(&n.ds, a); + if (argc > 1) v4_dstack_push(&n.ds, b); + return v4_test_call(&n, &es, &h, DICT_W, 100000) > 0; +} + +int main(void) +{ + unsigned i, t, bslots = 0; + + printf("v4 host code generator tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS); + + for (i = 0; i < 4; i++) if ((v4_ucell)v4_iword_slot_mask(i) >= (v4_ucell)(V4_NODE_WORDS - 1u)) bslots = i + 1; + CHECK(bslots == 3, "at this node size a branch may sit in slots 0 .. 2: %u", bslots); + + 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_W * 4); + v4_text_constant(&tx, ">IN", TO_IN); + v4_text_constant(&tx, "SPAN", SPAN); + v4_text_constant(&tx, "WBUF", WBUF_W * 4); + 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_W * 4); + v4_text_constant(&tx, "(D)", DVARS); + v4_text_constant(&tx, "(CG)", CGVARS); + v4_text_constant(&tx, "CG-BSLOTS", (v4_cell)bslots); + 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_file(&tx, V4_CAPSULE_DIR "/codegen.v4"), "codegen.v4 assembles: %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; } + + /* ---- the arithmetic it rests on ---- */ + for (i = 0; i <= 31; i++) + CHECK(get("(LSHIFT)", 2, 1, (v4_cell)i) == (v4_cell)((v4_ucell)1 << i) && get("(LSHIFT)", 2, 5, (v4_cell)i) == (v4_cell)((v4_ucell)5 << i), + "(LSHIFT) by %u", i); + for (i = 0; i < 6; i++) { + CHECK(get("(LOWBIT)", 1, (v4_cell)i, 0) == (v4_cell)V4_SLOT_LOW_BIT(i), "slot %u's lowest bit is %u", i, V4_SLOT_LOW_BIT(i)); + CHECK(get("(MASK)", 1, (v4_cell)i, 0) == (v4_cell)v4_iword_slot_mask(i), "slot %u's address mask", i); + } + + /* ---- one thing at a time ---- */ + nprog = 0; + CHECK(same("nothing"), "nothing lays nothing"); + CHECK((n.mem[DP] + 3) / 4 == DICT_W, "and HERE does not move"); + + for (i = 0; i < sizeof plain_ops / sizeof plain_ops[0]; i++) { + nprog = 0; p_op(plain_ops[i]); + CHECK(same(mnemonic[plain_ops[i]]), "the opcode %s alone", mnemonic[plain_ops[i]]); + nprog = 0; p_op(28); p_op(28); p_op(plain_ops[i]); p_op(24); + CHECK(same(mnemonic[plain_ops[i]]), "the opcode %s in slot 2, something after it", mnemonic[plain_ops[i]]); + } + for (t = 1; t <= 14; t++) { + nprog = 0; for (i = 0; i < t; i++) p_op(24); + CHECK(same("dups"), "%u opcodes: a word every six", t); + } + for (i = 0; i < sizeof lits / sizeof lits[0]; i++) { + nprog = 0; p_lit(lits[i]); p_op(0); + CHECK(same("a literal"), "the literal [%u]", i); + } + for (t = 1; t <= 14; t++) { + nprog = 0; for (i = 0; i < t; i++) p_lit((v4_cell)(100 + i)); + CHECK(same("literals"), "%u literals in a row: each word's follow it in order", t); + } + for (t = 0; t <= 6; t++) { /* a literal in each slot, then more code */ + nprog = 0; for (i = 0; i < t; i++) p_op(24); + p_lit(77); p_op(20); p_lit(-88); p_op(0); + CHECK(same("mixed"), "a literal after %u opcodes", t); + } + + /* a branch after 0 .. 6 opcodes, backward and forward, each of the five */ + for (i = 0; i < 5; i++) + for (t = 0; t <= 6; t++) { + unsigned k; + nprog = 0; p_label(0); p_op(28); p_op(28); p_op(28); p_op(28); p_op(28); p_op(28); + for (k = 0; k < t; k++) p_op(24); + p_back(branch_ops[i], 0); p_op(23); p_op(0); + CHECK(same("back"), "%s backward after %u opcodes", mnemonic[branch_ops[i]], t); + nprog = 0; + for (k = 0; k < t; k++) p_op(24); + p_fwd(branch_ops[i], 0); p_op(23); p_op(23); p_op(0); p_here(0); p_op(0); + CHECK(same("forward"), "%s forward after %u opcodes", mnemonic[branch_ops[i]], t); + nprog = 0; /* with literals owed by the branch's word */ + p_lit(5); p_lit(6); + for (k = 0; k < t; k++) p_op(24); + p_fwd(branch_ops[i], 0); p_lit(7); p_op(0); p_here(0); p_op(0); + CHECK(same("forward with literals"), "%s forward after two literals and %u opcodes", mnemonic[branch_ops[i]], t); + } + + /* a label after 0 .. 6 opcodes closes the word */ + for (t = 0; t <= 6; t++) { + nprog = 0; for (i = 0; i < t; i++) p_op(24); + p_label(0); p_op(23); p_back(2, 0); + CHECK(same("label"), "a label after %u opcodes", t); + } + + /* ---- random programmes ---- */ + for (t = 0; t < 600; t++) { + unsigned len = 5 + rnd() % 120, nback = 0, nfwd = 0, open[8], nopen = 0; + nprog = 0; + for (i = 0; i < len && nprog < MAX_ITEMS - 20; i++) { + unsigned r = rnd() % 100; + if (r < 55) p_op(plain_ops[rnd() % (sizeof plain_ops / sizeof plain_ops[0])]); + else if (r < 75) p_lit(rnd() % 3 ? (v4_cell)(int32_t)rnd() : lits[rnd() % (sizeof lits / sizeof lits[0])]); + else if (r < 82 && nback < 40) p_label((int)nback++); + else if (r < 90 && nback > 0) p_back(branch_ops[rnd() % 5], (int)(rnd() % nback)); + else if (r < 95 && nopen < 8 && nfwd < 40) { open[nopen++] = nfwd; p_fwd(branch_ops[rnd() % 5], (int)nfwd++); } + else if (nopen > 0) { unsigned k = rnd() % nopen; p_here((int)open[k]); open[k] = open[--nopen]; } + } + while (nopen > 0) p_here((int)open[--nopen]); + CHECK(same("random"), "random programme %u of %u items", t, nprog); + } + + /* ---- what it lays down runs ---- */ + + /* ( a b -- b a ) over push push drop pop pop ; */ + nprog = 0; p_op(26); p_op(29); p_op(29); p_op(23); p_op(25); p_op(25); p_op(0); + CHECK(same("SWAP") && exec_prog(2, 3, 4) && pop() == 3 && pop() == 4 && clean(), "SWAP, generated, swaps"); + + /* ( n -- n*8+5 ) 2 push L: 2* next L 5 + ; a backward branch and a literal */ + nprog = 0; p_lit(2); p_op(29); p_label(0); p_op(17); p_back(5, 0); p_lit(5); p_op(20); p_op(0); + CHECK(same("loop") && exec_prog(1, 3, 0) && pop() == 29 && clean(), "a counted loop, generated, counts"); + + /* ( n -- 10 | 20 ) if Z drop 10 ; Z: drop 20 ; a forward branch */ + nprog = 0; p_fwd(6, 0); p_op(23); p_lit(10); p_op(0); p_here(0); p_op(23); p_lit(20); p_op(0); + CHECK(same("if") && exec_prog(1, 7, 0) && pop() == 10 && clean() && exec_prog(1, 0, 0) && pop() == 20 && clean(), "a conditional, generated, chooses"); + + /* a call to a word of the capsule, and a jump to one: ( c baddr -- c' ) dup push C! pop jump C@ */ + CHECK(lay_by_generator() == 1, "reset"); + nprog = 0; + for (v4_cell k = DICT_W; k < DICT_W + 16; k++) n.mem[k] = 0; + n.mem[DP] = DICT_W * 4; + CHECK(did("(CG-RESET)", 0, 0, 0) && did("(OP,)", 1, 24, 0) && did("(OP,)", 1, 29, 0) + && did("(CALL,)", 1, W("C!"), 0) && did("(OP,)", 1, 25, 0) && did("(JUMP,)", 1, W("C@"), 0) && did("(FLUSH)", 0, 0, 0), + "a call and a jump to capsule words are generated"); + for (i = 0; i < 8; i++) + CHECK(exec_prog(2, (v4_cell)(0x500 + 'A' + i), PAD_W * 4 + (v4_cell)i) && pop() == (v4_cell)('A' + i) && clean(), "and they run [%u]", i); + /* dup push call | pop jump : the call is in slot 2 of the first word, the jump in slot 1 of the second */ + CHECK(v4_iword_op((v4_iword)(v4_ucell)n.mem[DICT_W], 2) == V4_OP_CALL + && v4_iword_target((v4_iword)(v4_ucell)n.mem[DICT_W], 2) == (v4_iword)W("C!"), "(CALL,) lays a call to its address"); + CHECK(v4_iword_op((v4_iword)(v4_ucell)n.mem[DICT_W + 1], 1) == V4_OP_JUMP + && v4_iword_target((v4_iword)(v4_ucell)n.mem[DICT_W + 1], 1) == (v4_iword)W("C@"), "(JUMP,) lays a jump to its address"); + + /* (RESOLVE) writes only the address bits of its slot: a target with + * higher bits set leaves the opcodes of the word as they were */ + for (i = 0; i < 3; i++) { + v4_cell r, before; + unsigned k; + n.mem[DP] = DICT_W * 4; + CHECK(did("(CG-RESET)", 0, 0, 0), "reset"); + for (k = 0; k < i; k++) CHECK(did("(OP,)", 1, 24, 0), "dup"); + r = get("(BRANCH>)", 1, 6, 0); + before = n.mem[DICT_W]; + CHECK(r == DICT_W * 8 + (v4_cell)i, "the reference names the word and slot %u", i); + CHECK(did("(RESOLVE)", 2, (v4_cell)-1, r), "resolved to all ones"); + CHECK((v4_ucell)n.mem[DICT_W] == ((v4_ucell)before | (v4_ucell)v4_iword_slot_mask(i)), + "only the %u address bits of slot %u are written", V4_SLOT_LOW_BIT(i), i); + CHECK(did("(RESOLVE)", 2, 0, r) && n.mem[DICT_W] == before, "and resolving again to 0 clears them, and nothing else"); + } + + /* (CG-RESET) forgets a word half built */ + n.mem[DP] = DICT_W * 4; + CHECK(did("(OP,)", 1, 24, 0) && did("(LIT,)", 1, 9, 0) && did("(CG-RESET)", 0, 0, 0) && did("(FLUSH)", 0, 0, 0) + && n.mem[DP] == DICT_W * 4, "(CG-RESET) forgets a half-built word"); + + /* a full dictionary: nothing is written past it, and NODE-ERROR is set */ + n.mem[DP] = (DICT_END_W - 1) * 4; + n.mem[DICT_END_W] = 0x5EED; + n.mem[NODE_ERROR] = 0; + CHECK(did("(LIT,)", 1, 1, 0) && did("(LIT,)", 1, 2, 0) && did("(FLUSH)", 0, 0, 0) + && n.mem[NODE_ERROR] != 0 && n.mem[DICT_END_W] == 0x5EED, "code that does not fit sets NODE-ERROR and writes nothing past the end"); + + CHECK(v4_node_guards_intact(&n) && v4_node_guards_intact(&ref), "guards intact"); + + printf(" %d checks, %d failures\n", checks, failures); + return failures ? 1 : 0; +}