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

feat(v4.0.0): the code generator

Browse Source 
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 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 09:19:57 -04:00
co-authored by Claude Opus 5.5
parent c10d3a9cca
commit 880560fc00
3 changed files with 496 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
docs/v4.0.0/DECOMPOSITION.md
+21
View File
@@ -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 |
v4/capsule/codegen.v4
+104
View File
@@ -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,)
v4/tests/test_host_codegen.c
+371
View File
@@ -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 <stdint.h>
#include <stdio.h>
#include <string.h>
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;
}