From 03d8d991ef041656d063974d35d52a8a3133d192 Mon Sep 17 00:00:00 2001 From: rajames Date: Sat, 3 Oct 2026 20:13:24 -0400 Subject: [PATCH] feat(v4.0.0): the DO loop runtimes (DO) (?DO) (LOOP) (+LOOP) (LEAVE) I J UNLOOP and (0BRANCH), laid down in line by hand as the compiler will, executed on the golden model at both cell widths against C on every pair of 14 loop ends and 11 steps, and against sequences recorded from the v3 binary. (LOOP) goes round again while index < limit, signed, as v3 does; the document's equality test differed whenever start >= limit. (+LOOP) is now specified. J keeps the outer index in A and needs no extra return entry. LEAVE discards the limit and index. v3 left them on its return stack, which made a LEAVE in an inner loop stop the outer one. Co-Authored-By: Claude Opus 5.5 --- docs/v4.0.0/DECOMPOSITION.md | 46 ++-- v4/tests/test_loops.c | 470 +++++++++++++++++++++++++++++++++++ 2 files changed, 502 insertions(+), 14 deletions(-) create mode 100644 v4/tests/test_loops.c diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index c31039a8..38f5e6c0 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -147,7 +147,7 @@ IF body1 ELSE body2 THEN → if L1 drop body1 jump L2 times, as on the F18. `FOR ... UNEXT` is the same but the body must fit in one instruction word. **Register conventions.** `A` and `B` are caller-saved. A word that uses them says so. Words in this -document that clobber `A`: `@ ! +! -! 2@ 2! C@ C! D2/ M* FILL ERASE MOVE COUNT CMOVE CMOVE> BLANK -TRAILING COMPARE SEARCH SCAN SKIP DECIMAL HEX OCTAL UM* * UM/MOD Q.FROM-INT Q.TO-INT Q.* Q./ Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS HOLD SIGN # #S . .R U. U.R D. D.R ? DUMP Q.PRINT TYPE SEND RECV`. Words that clobber `B`: +document that clobber `A`: `@ ! +! -! 2@ 2! C@ C! D2/ M* FILL ERASE MOVE COUNT CMOVE CMOVE> BLANK -TRAILING COMPARE SEARCH SCAN SKIP DECIMAL HEX OCTAL UM* * UM/MOD Q.FROM-INT Q.TO-INT Q.* Q./ Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS +LOOP J HOLD SIGN # #S . .R U. U.R D. D.R ? DUMP Q.PRINT TYPE SEND RECV`. Words that clobber `B`: `COMPARE SEARCH Q./ Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS <# HOLD SIGN # #S #> . .R U. U.R D. D.R ? DUMP Q.PRINT EMIT CR SPACE SPACES TYPE SEND RECV`. **Return-stack words** (`>R R> R@ 2>R 2R> 2R@ I J UNLOOP` and the loop runtimes) are always IN. @@ -721,28 +721,46 @@ The storage service belongs to the Artemis role, now a device node. | `IF` `ELSE` `THEN` `BEGIN` `UNTIL` `AGAIN` `WHILE` `REPEAT` `DO` `?DO` `LOOP` `+LOOP` `LEAVE` `CASE` `OF` `ENDOF` `ENDCASE` | CC | Compile-time structure words. Expansions per §2 and below. | | `EXIT` | OP | `;` | | `(BRANCH)` | OP | `jump` | -| `(0BRANCH)` | IN | `if L … drop` (§2) | -| `(DO)` | IN | `SWAP push push` (R: limit index) | -| `(?DO)` | IN | `2DUP = IF 2DROP jump past-loop THEN SWAP push push` | -| `(LOOP)` | IN | See below. | -| `(+LOOP)` | IN | Sign-aware boundary-crossing test; specified in the compiler capsule. | -| `(LEAVE)` | IN | `pop drop pop dup push push jump loop-test` (sets index to limit) | -| `I` | IN | `pop dup push` | -| `J` | IN | `pop pop pop dup push SWAP push SWAP push` | -| `UNLOOP` | IN | `pop pop drop drop` | +| `(0BRANCH)` | IN | `if L … drop` (§2) — executed on the golden model (2026-10-03) as `IF 1 ELSE 2 THEN`, including results recorded from the v3 binary. | +| `(DO)` | IN | `over push push drop` (R: limit index) — `SWAP push push` without the `SWAP`. The body always runs once, as v3. Executed on the golden model (2026-10-03). | +| `(?DO)` | IN | `over over xor if SKIP drop (DO) … body and loop end … jump PAST SKIP: drop drop drop PAST:` — skips the loop when index = limit, as v3. Executed on the golden model (2026-10-03). | +| `(LOOP)` | IN | See below. Adds 1 and goes round again while index < limit, signed, as v3. Executed on the golden model (2026-10-03) against C on every pair of 14 loop ends, and sequences recorded from the v3 binary. | +| `(+LOOP)` | IN | See below. `( n -- )`: adds `n` and goes round again while index < limit for `n >= 0`, while index >= limit for `n < 0`, as v3. Executed on the golden model (2026-10-03) against C on every pair of 14 loop ends with 11 steps, and sequences recorded from the v3 binary. Clobbers `A`. | +| `(LEAVE)` | IN | `pop drop pop drop jump PAST` — discards the limit and index and leaves the loop at once. In a single loop this is what v3 does. v3 left the two on its return stack (index set to limit) and jumped past the loop, so a `LEAVE` in an inner loop made the outer `LOOP` count the inner loop's leftovers and stop: `: T 3 0 DO 10 0 DO I . I 1 = IF LEAVE THEN LOOP I . LOOP ;` prints `0 1 10` in v3 and `0 1 0 0 1 1 0 1 2` here. Executed on the golden model (2026-10-03) in `LOOP` and `+LOOP`, including sequences recorded from the v3 binary. | +| `I` | IN | `pop dup push` — executed on the golden model (2026-10-03). | +| `J` | IN | `pop pop pop dup push a! push push a` — the outer index waits in `A` while the inner pair goes back, so `J` needs no return entry beyond the two loops' own (with two in-line `SWAP`s it needed one more). Executed on the golden model (2026-10-03), including a sequence recorded from the v3 binary. Clobbers `A`. | +| `UNLOOP` | IN | `pop drop pop drop` — executed on the golden model (2026-10-03) as `UNLOOP EXIT`, including a sequence recorded from the v3 binary. | ``` +, used by both loop ends: ( i' lim -- i' lim s ), the top bit of s set +exactly when i' < lim, signed -- i' itself when the two differ in sign, else +i' - lim (the subtraction in line): + over over xor -if SAME + drop over jump T +SAME: drop over over - +T: + (LOOP) expansion: pop 1 + pop \ index' limit - 2DUP xor \ index' limit flag (0 when equal) - if Lexit + \ index' limit s + -if Lexit \ not less: done drop push push \ R: limit index' jump Lbody Lexit: drop drop drop + +(+LOOP) expansion: ( n -- ) + dup a! pop + pop \ index' limit A: n + a xor \ top bit set: go round again + -if Lexit + drop push push + jump Lbody +Lexit: drop drop drop ``` -`(LOOP)` terminates when the index reaches the limit, which matches v3 for every loop where -`start < limit`. +`(LOOP)` goes round again while `index' < limit`, signed, which is v3's rule. So `0 5 DO … LOOP` runs +once, as in v3; a test for `index' = limit`, which this document had first, would run it round the whole +number circle. `(+LOOP)` goes round again exactly when `s` and `n` differ in sign: `index' < limit` for +`n >= 0` and the opposite for `n < 0`. A loop costs its word two return-stack entries while it runs. **New in v4:** `FOR`, `NEXT`, and `UNEXT` are native (§2). Counted loops that don't need an ascending index should use them; they cost one instruction per iteration. diff --git a/v4/tests/test_loops.c b/v4/tests/test_loops.c new file mode 100644 index 00000000..eb9ca784 --- /dev/null +++ b/v4/tests/test_loops.c @@ -0,0 +1,470 @@ +/* test_loops.c -- the DO loop runtimes, executed. + * + * DECOMPOSITION.md 5.18: (DO) (?DO) (LOOP) (+LOOP) (LEAVE) I J UNLOOP and + * (0BRANCH). None of these is a word in v4: each is a short sequence the + * compiler lays down in line, with the loop's limit and index on the return + * stack (limit below index). This file lays them down by hand, as the + * compiler will, inside small test words, runs those on the golden model and + * compares what each loop body saw with C and with v3. + * + * v3 (v3/src/word_source/control_words.c): + * DO the body always runs once + * ?DO skips the loop when index = limit + * LOOP adds 1 and goes round again while index < limit, signed + * +LOOP ( n -- ) adds n and goes round again while index < limit for + * n >= 0, while index >= limit for n < 0 + * LEAVE leaves the loop at once + * I J the index of this loop, of the loop outside it + * UNLOOP discards the loop's limit and index, for EXIT + * So `0 5 DO .. LOOP` runs once in v3 and here; 5.18's first (LOOP), which + * tested for index = limit, would have gone round the whole number circle. + * + * Where v4 parts from v3: v3's LEAVE set the index to the limit and jumped + * past the loop without discarding the two, which is invisible in a single + * loop but breaks an outer one: in v3 + * : T 3 0 DO 10 0 DO I . I 1 = IF LEAVE THEN LOOP I . LOOP ; + * prints "0 1 10" and stops, the outer LOOP having counted the inner loop's + * leftovers. Here LEAVE discards them, and the outer loop carries on. + * + * The expected sequences marked "v3:" were recorded from the v3 binary on + * 2026-10-03, as in test_numout.c. + */ +#include "v4/asm.h" +#include "v4/testcode.h" +#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 MAXS ((v4_cell)(V4_MSB - 1u)) +#define MINS ((v4_cell)V4_MSB) + +/* The memory map is open (D-4); the test chooses the addresses. */ +#define TRACE ((v4_cell)(V4_NODE_WORDS - 80u)) /* what the loop bodies saw, 64 cells */ +#define CNT ((v4_cell)(V4_NODE_WORDS - 8u)) /* how many cells of TRACE are used */ +#define STEP ((v4_cell)(V4_NODE_WORDS - 7u)) /* +LOOP's increment */ +#define KV ((v4_cell)(V4_NODE_WORDS - 6u)) /* the index to LEAVE or EXIT at */ +#define LAST ((v4_cell)(V4_NODE_WORDS - 5u)) /* set after the loop */ +#define TCAP 64 + +static v4_node n; +static v4_exec_state es; +static v4_heat h; +static v4_asm as; + +static v4_cell t_do, t_qdo, t_ploop, t_pqdo, t_nest, t_leave, t_pleave, t_nestleave, t_unloop, t_if, t_j3; + +#define O(name) v4_asm_op(&as, V4_OP_##name) +#define LIT(v) v4_asm_lit(&as, (v4_cell)(v)) +#define JUMP(x) v4_asm_branch(&as, V4_OP_JUMP, (x)) +#define FWD(op) v4_asm_branch_fwd(&as, V4_OP_##op) +#define HERE_(r) v4_asm_resolve(&as, (r), v4_asm_label(&as)) +#define SUB_INLINE() do { O(PUSH); O(INV); O(RPOP); O(ADD); O(INV); } while (0) + +/* ---- the expansions under test, as the compiler lays them down --------- */ + +/* (DO) ( limit index -- ) over push push drop R: limit index + * SWAP push push without the SWAP. */ +#define DO_() do { O(OVER); O(PUSH); O(PUSH); O(DROP); } while (0) + +/* (?DO) ( limit index -- ) + * over over xor if SKIP drop (DO) ...body and LOOP... SKIP: drop drop drop + * The caller resolves the returned reference after the loop, at code that + * drops the three cells. */ +#define QDO_(skip) do { O(OVER); O(OVER); O(XOR); (skip) = FWD(IF); O(DROP); DO_(); } while (0) +#define QDO_END_(skip, past) do { (past) = FWD(JUMP); HERE_(skip); O(DROP); O(DROP); O(DROP); HERE_(past); } while (0) + +/* The sign of T after this is set exactly when index' < limit, signed: + * index' itself when the two differ in sign, else index' - limit. + * ( i' lim -- i' lim s ) + * over over xor -if SAME drop over jump T SAME: drop over over - T: */ +#define LESS_SIGN_() do { v4_asm_ref same_, t_; \ + O(OVER); O(OVER); O(XOR); same_ = FWD(MINUS_IF); \ + O(DROP); O(OVER); t_ = FWD(JUMP); \ + HERE_(same_); O(DROP); O(OVER); O(OVER); SUB_INLINE(); \ + HERE_(t_); } while (0) + +/* (LOOP) + * pop 1 + pop i' lim + * i' lim s + * -if EXIT drop push push jump BODY + * EXIT: drop drop drop */ +#define LOOP_(body) do { v4_asm_ref exit_; \ + O(RPOP); LIT(1); O(ADD); O(RPOP); LESS_SIGN_(); \ + exit_ = FWD(MINUS_IF); O(DROP); O(PUSH); O(PUSH); JUMP(body); \ + HERE_(exit_); O(DROP); O(DROP); O(DROP); } while (0) + +/* (+LOOP) ( n -- ) + * dup a! pop + pop i' lim A: n + * i' lim s + * a xor top bit set: go round again + * -if EXIT drop push push jump BODY + * EXIT: drop drop drop + * Going round again is index' < limit for n >= 0 and the opposite for + * n < 0, that is, exactly when s and n differ in sign. Clobbers A. */ +#define PLOOP_(body) do { v4_asm_ref exit_; \ + O(DUP); O(BANG_A); O(RPOP); O(ADD); O(RPOP); LESS_SIGN_(); O(PUSH_A); O(XOR); \ + exit_ = FWD(MINUS_IF); O(DROP); O(PUSH); O(PUSH); JUMP(body); \ + HERE_(exit_); O(DROP); O(DROP); O(DROP); } while (0) + +/* (LEAVE) pop drop pop drop jump PAST the caller resolves PAST after the loop */ +#define LEAVE_(past) do { O(RPOP); O(DROP); O(RPOP); O(DROP); (past) = FWD(JUMP); } while (0) + +/* I pop dup push + * J pop pop pop dup push a! push push a + * the outer index waits in A while the inner pair goes back, so J + * needs no return entry beyond the two loops' own. Clobbers A. + * UNLOOP pop drop pop drop */ +#define I_() do { O(RPOP); O(DUP); O(PUSH); } while (0) +#define J_() do { O(RPOP); O(RPOP); O(RPOP); O(DUP); O(PUSH); O(BANG_A); O(PUSH); O(PUSH); O(PUSH_A); } while (0) +#define UNLOOP_() do { O(RPOP); O(DROP); O(RPOP); O(DROP); } while (0) + +/* ---- what the test bodies do ------------------------------------------- */ +#define VGET(a) do { LIT(a); O(BANG_A); O(FETCH_A); } while (0) +#define VSET(a) do { LIT(a); O(BANG_A); O(STORE_A); } while (0) +/* ( x -- ) append x to TRACE: CNT @ 63 and TRACE + a! ! CNT @ 1 + CNT ! + * The index is masked so that a loop that runs away stays inside TRACE and + * fails on its count, not by writing over the node. */ +#define REC_() do { VGET(CNT); LIT(TCAP - 1); O(AND); LIT(TRACE); O(ADD); O(BANG_A); O(STORE_A); \ + VGET(CNT); LIT(1); O(ADD); VSET(CNT); } while (0) + +static void build(void) +{ + v4_asm_ref a, b, skip, past; + v4_cell body, body2; + + /* ( limit start -- ) DO I rec LOOP */ + t_do = v4_asm_label(&as); + DO_(); body = v4_asm_label(&as); I_(); REC_(); LOOP_(body); O(SEMI); + + /* ( limit start -- ) ?DO I rec LOOP */ + t_qdo = v4_asm_label(&as); + QDO_(skip); body = v4_asm_label(&as); I_(); REC_(); LOOP_(body); QDO_END_(skip, past); O(SEMI); + + /* ( limit start -- ) DO I rec STEP @ +LOOP */ + t_ploop = v4_asm_label(&as); + DO_(); body = v4_asm_label(&as); I_(); REC_(); VGET(STEP); PLOOP_(body); O(SEMI); + + /* ( limit start -- ) ?DO I rec STEP @ +LOOP */ + t_pqdo = v4_asm_label(&as); + QDO_(skip); body = v4_asm_label(&as); I_(); REC_(); VGET(STEP); PLOOP_(body); QDO_END_(skip, past); O(SEMI); + + /* ( olimit ilimit -- ) KV ! 0 DO KV @ 10 DO I rec J rec LOOP LOOP */ + t_nest = v4_asm_label(&as); + VSET(KV); LIT(0); DO_(); + body = v4_asm_label(&as); + VGET(KV); LIT(10); DO_(); + body2 = v4_asm_label(&as); + I_(); REC_(); J_(); REC_(); + LOOP_(body2); + LOOP_(body); + O(SEMI); + + /* ( limit start -- ) DO I rec I KV @ = IF LEAVE THEN I rec LOOP 77 LAST ! */ + t_leave = v4_asm_label(&as); + DO_(); body = v4_asm_label(&as); + I_(); REC_(); + I_(); VGET(KV); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP); + HERE_(a); O(DROP); LEAVE_(past); + HERE_(b); + I_(); REC_(); + LOOP_(body); + HERE_(past); + LIT(77); VSET(LAST); O(SEMI); + + /* ( limit start -- ) DO I rec I KV @ = IF LEAVE THEN I rec STEP @ +LOOP 77 LAST ! */ + t_pleave = v4_asm_label(&as); + DO_(); body = v4_asm_label(&as); + I_(); REC_(); + I_(); VGET(KV); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP); + HERE_(a); O(DROP); LEAVE_(past); + HERE_(b); + I_(); REC_(); + VGET(STEP); PLOOP_(body); + HERE_(past); + LIT(77); VSET(LAST); O(SEMI); + + /* ( -- ) 3 0 DO 10 0 DO I rec I 1 = IF LEAVE THEN LOOP I rec LOOP 77 LAST ! */ + t_nestleave = v4_asm_label(&as); + LIT(3); LIT(0); DO_(); + body = v4_asm_label(&as); + LIT(10); LIT(0); DO_(); + body2 = v4_asm_label(&as); + I_(); REC_(); + I_(); LIT(1); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP); + HERE_(a); O(DROP); LEAVE_(past); + HERE_(b); + LOOP_(body2); + HERE_(past); + I_(); REC_(); + LOOP_(body); + LIT(77); VSET(LAST); O(SEMI); + + /* ( limit start -- ) DO I KV @ = IF UNLOOP EXIT THEN I rec LOOP 99 LAST ! */ + t_unloop = v4_asm_label(&as); + DO_(); body = v4_asm_label(&as); + I_(); VGET(KV); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP); + HERE_(a); O(DROP); UNLOOP_(); O(SEMI); + HERE_(b); + I_(); REC_(); + LOOP_(body); + LIT(99); VSET(LAST); O(SEMI); + + /* ( f -- n ) IF 1 ELSE 2 THEN (0BRANCH), section 2: + * if L1 drop 1 jump L2 L1: drop 2 L2: */ + t_if = v4_asm_label(&as); + a = FWD(IF); O(DROP); LIT(1); b = FWD(JUMP); + HERE_(a); O(DROP); LIT(2); + HERE_(b); O(SEMI); + + /* ( x y -- x y j ) 5 3 DO 2 1 DO J LEAVE LOOP LEAVE LOOP + * J with two cells of the caller's under it: it must leave them alone. */ + t_j3 = v4_asm_label(&as); + LIT(5); LIT(3); DO_(); + LIT(2); LIT(1); DO_(); + J_(); + UNLOOP_(); UNLOOP_(); + O(SEMI); +} + +/* ---- running ---------------------------------------------------------- */ + +static void prepare(v4_cell step, v4_cell k) +{ + unsigned i; + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + v4_heat_reset(&h); + for (i = 0; i < TCAP; i++) n.mem[TRACE + (v4_cell)i] = 0x7E7E7E; + n.mem[CNT] = 0; n.mem[STEP] = step; n.mem[KV] = k; n.mem[LAST] = 0; +} +/* Runs `word`; true when it returns with the data stack as it found it + * under its arguments and the return stack exactly as it found it: two + * marked entries wait under the return address, and a loop that left its + * limit or index behind, or took one too many, would return through them. */ +#define RMARK0 ((v4_cell)0x6B0000A0) +#define RMARK1 ((v4_cell)0x6B0000A1) +static int call(v4_cell word, v4_cell step, v4_cell k, unsigned argc, v4_cell a, v4_cell b) +{ + prepare(step, k); + v4_dstack_push(&n.ds, CANARY); + if (argc > 0) v4_dstack_push(&n.ds, a); + if (argc > 1) v4_dstack_push(&n.ds, b); + v4_rstack_push(&n.rs, RMARK0); + v4_rstack_push(&n.rs, RMARK1); + return v4_test_call(&n, &es, &h, word, 100000) > 0 && n.ds.t == CANARY + && v4_rstack_pop(&n.rs) == RMARK1 && v4_rstack_pop(&n.rs) == RMARK0; +} +/* The trace is exactly these. */ +static int saw(const v4_cell *want, unsigned len) +{ + unsigned i; + if (n.mem[CNT] != (v4_cell)len) return 0; + for (i = 0; i < len; i++) if (n.mem[TRACE + (v4_cell)i] != want[i]) return 0; + return n.mem[TRACE + (v4_cell)len] == 0x7E7E7E; +} +#define SAW(...) saw((const v4_cell[]){ __VA_ARGS__ }, (unsigned)(sizeof((const v4_cell[]){ __VA_ARGS__ }) / sizeof(v4_cell))) + +/* Stack headroom, as in test_foundation.c: the same trace with marked cells + * under the canary and under the return address. */ +static int fits(v4_cell word, v4_cell step, v4_cell k, unsigned argc, v4_cell a, v4_cell b, + const v4_cell *want, unsigned len, unsigned dfill, unsigned rfill) +{ + unsigned i; + prepare(step, k); + 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); + if (argc > 1) v4_dstack_push(&n.ds, b); + for (i = 0; i < rfill; i++) v4_rstack_push(&n.rs, (v4_cell)(0x6B000000 + i)); + if (v4_test_call(&n, &es, &h, word, 100000) <= 0) return 0; + if (!saw(want, len)) return 0; + if (v4_dstack_pop(&n.ds) != CANARY) return 0; + for (i = dfill; i-- > 0; ) if (v4_dstack_pop(&n.ds) != (v4_cell)(0x5A000000 + i)) return 0; + for (i = rfill; i-- > 0; ) if (v4_rstack_pop(&n.rs) != (v4_cell)(0x6B000000 + i)) return 0; + return 1; +} +static void headroom(const char *name, v4_cell word, v4_cell step, v4_cell k, unsigned argc, v4_cell a, v4_cell b, + int min_d, int min_r) +{ + v4_cell want[TCAP]; + unsigned len, i; + int dh, rh; + CHECK(call(word, step, k, argc, a, b), "%s runs", name); + len = (unsigned)n.mem[CNT]; + for (i = 0; i < len; i++) want[i] = n.mem[TRACE + (v4_cell)i]; + for (dh = 0; dh < V4_DATA_DEPTH; dh++) if (!fits(word, step, k, argc, a, b, want, len, (unsigned)dh + 1u, 0)) break; + for (rh = 0; rh < V4_RET_DEPTH; rh++) if (!fits(word, step, k, argc, a, b, want, len, 0, (unsigned)rh + 1u)) break; + printf(" %-22s 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); +} + +/* ---- the C reference: v3's rules ---------------------------------------- */ + +/* The indexes a loop body sees; at most TCAP - 1 are produced, and the + * return is -1 if the loop would run longer than that. */ +static int ref_loop(v4_cell limit, v4_cell start, int qdo, int plus, v4_cell step, v4_cell *out) +{ + v4_cell i = start; + int len = 0; + if (qdo && start == limit) return 0; + for (;;) { + if (len >= TCAP - 1) return -1; + out[len++] = i; + i = (v4_cell)((v4_ucell)i + (v4_ucell)(plus ? step : 1)); + if (!plus) { if (!(i < limit)) break; } + else if (step >= 0) { if (!(i < limit)) break; } + else { if (!(i >= limit)) break; } + } + return len; +} + +static const v4_cell ends[] = { 0, 1, 2, 5, -1, -2, -5, 10, MAXS, (v4_cell)(MAXS - 1), (v4_cell)(MAXS - 4), + MINS, (v4_cell)(MINS + 1), (v4_cell)(MINS + 4) }; +#define NENDS (sizeof ends / sizeof ends[0]) +static const v4_cell steps[] = { 1, 2, 3, 7, -1, -2, -3, -7, 0, MAXS, MINS }; +#define NSTEPS (sizeof steps / sizeof steps[0]) + +int main(void) +{ + v4_cell want[TCAP]; + unsigned i, j, k, runs = 0, skipped = 0; + int len; + + printf("v4 loop tests: V4_CELL_BITS=%d\n", V4_CELL_BITS); + + v4_node_reset(&n); + /* Words 0 .. 15 each jump to themselves. A loop that leaves its index + * or limit on the return stack makes the word return to that number; + * the tests of LEAVE and UNLOOP use indexes and limits below 16, so such + * a return lands here and never comes back, where empty memory (all + * `;`) would have passed it on to the real return address unnoticed. */ + for (i = 0; i < 16; i++) { + v4_asm_begin(&as, &n, (v4_cell)i); + JUMP((v4_cell)i); + CHECK(v4_asm_ok(&as), "trap %u assembles", i); + } + v4_asm_begin(&as, &n, 16); + build(); + CHECK(v4_asm_ok(&as), "loop test words assemble"); + CHECK(v4_asm_label(&as) < TRACE, "code stays below the variables"); + printf(" code: %ld of %u words\n", (long)v4_asm_label(&as) - 16, (unsigned)V4_NODE_WORDS); + + /* ---- the v3 transcripts ---- */ + + /* : T 5 0 DO I . LOOP ; 0 1 2 3 4 : U 0 5 DO I . LOOP ; 5 + * : V 5 5 DO I . LOOP ; 5 : W 5 5 ?DO I . LOOP ; (nothing) + * : X 5 2 ?DO I . LOOP ; 2 3 4 */ + CHECK(call(t_do, 0, 0, 2, 5, 0) && SAW(0, 1, 2, 3, 4), "v3: 5 0 DO LOOP"); + CHECK(call(t_do, 0, 0, 2, 0, 5) && SAW(5), "v3: 0 5 DO LOOP runs once"); + CHECK(call(t_do, 0, 0, 2, 5, 5) && SAW(5), "v3: 5 5 DO LOOP runs once"); + CHECK(call(t_qdo, 0, 0, 2, 5, 5) && n.mem[CNT] == 0, "v3: 5 5 ?DO LOOP does not run"); + CHECK(call(t_qdo, 0, 0, 2, 5, 2) && SAW(2, 3, 4), "v3: 5 2 ?DO LOOP"); + + /* 10 0 DO I . 2 +LOOP 0 2 4 6 8 0 10 DO I . -3 +LOOP 10 7 4 1 + * 0 0 DO I . 5 +LOOP 0 3 7 DO I . 1 +LOOP 7 + * 7 3 DO I . -1 +LOOP 3 */ + CHECK(call(t_ploop, 2, 0, 2, 10, 0) && SAW(0, 2, 4, 6, 8), "v3: 10 0 DO 2 +LOOP"); + CHECK(call(t_ploop, -3, 0, 2, 0, 10) && SAW(10, 7, 4, 1), "v3: 0 10 DO -3 +LOOP"); + CHECK(call(t_ploop, 5, 0, 2, 0, 0) && SAW(0), "v3: 0 0 DO 5 +LOOP"); + CHECK(call(t_ploop, 1, 0, 2, 3, 7) && SAW(7), "v3: 3 7 DO 1 +LOOP"); + CHECK(call(t_ploop, -1, 0, 2, 7, 3) && SAW(3), "v3: 7 3 DO -1 +LOOP"); + + /* : T 3 0 DO 12 10 DO I . J . LOOP LOOP ; 10 0 11 0 10 1 11 1 10 2 11 2 */ + CHECK(call(t_nest, 0, 0, 2, 3, 12) && SAW(10, 0, 11, 0, 10, 1, 11, 1, 10, 2, 11, 2), "v3: nested loops, I and J"); + + /* : T 10 0 DO I . I 3 = IF LEAVE THEN I . LOOP ; 0 0 1 1 2 2 3 + * : T 20 0 DO I . I 6 = IF LEAVE THEN I . 3 +LOOP 77 . ; 0 0 3 3 6 77 + * : T 0 20 DO I . I 11 = IF LEAVE THEN I . -3 +LOOP 77 . ; 20 20 17 17 14 14 11 77 */ + CHECK(call(t_leave, 0, 3, 2, 10, 0) && SAW(0, 0, 1, 1, 2, 2, 3) && n.mem[LAST] == 77, "v3: LEAVE in LOOP"); + CHECK(call(t_pleave, 3, 6, 2, 12, 0) && SAW(0, 0, 3, 3, 6) && n.mem[LAST] == 77, "LEAVE in +LOOP, limit below 16"); + CHECK(call(t_pleave, 3, 6, 2, 20, 0) && SAW(0, 0, 3, 3, 6) && n.mem[LAST] == 77, "v3: LEAVE in +LOOP, up"); + CHECK(call(t_pleave, -3, 11, 2, 0, 20) && SAW(20, 20, 17, 17, 14, 14, 11) && n.mem[LAST] == 77, + "v3: LEAVE in +LOOP, down"); + + /* : T 10 0 DO I 3 = IF UNLOOP EXIT THEN I . LOOP 99 . ; 0 1 2 */ + CHECK(call(t_unloop, 0, 3, 2, 10, 0) && SAW(0, 1, 2) && n.mem[LAST] == 0, "v3: UNLOOP EXIT"); + CHECK(call(t_unloop, 0, 55, 2, 4, 0) && SAW(0, 1, 2, 3) && n.mem[LAST] == 99, "a loop that never meets UNLOOP runs out"); + + /* : T IF 1 ELSE 2 THEN . ; 5 T 0 T -1 T 1 2 1 */ + { + static const v4_cell f[] = { 5, 0, -1, 1, MINS, MAXS }; + for (i = 0; i < 6; i++) { + prepare(0, 0); + v4_dstack_push(&n.ds, CANARY); + v4_dstack_push(&n.ds, f[i]); + CHECK(v4_test_call(&n, &es, &h, t_if, 1000) > 0 && v4_dstack_pop(&n.ds) == (f[i] ? 1 : 2) + && v4_dstack_pop(&n.ds) == CANARY, "%sIF ELSE THEN [%u]", i < 3 ? "v3: " : "", i); + } + } + + /* ---- where v4 parts from v3: LEAVE inside an outer loop ---- */ + CHECK(call(t_nestleave, 0, 0, 0, 0, 0) && SAW(0, 1, 0, 0, 1, 1, 0, 1, 2) && n.mem[LAST] == 77, + "LEAVE leaves the inner loop only (v3: 0 1 10 and the outer loop stops)"); + + /* J leaves the cells under it alone */ + prepare(0, 0); + v4_dstack_push(&n.ds, CANARY); + v4_dstack_push(&n.ds, 111); + v4_dstack_push(&n.ds, 222); + CHECK(v4_test_call(&n, &es, &h, t_j3, 1000) > 0 && v4_dstack_pop(&n.ds) == 3 && v4_dstack_pop(&n.ds) == 222 + && v4_dstack_pop(&n.ds) == 111 && v4_dstack_pop(&n.ds) == CANARY, "J is the outer index"); + + /* ---- against C: every pair of loop ends, and every step ---- */ + for (i = 0; i < NENDS; i++) + for (j = 0; j < NENDS; j++) { + v4_cell limit = ends[i], start = ends[j]; + for (k = 0; k < 2; k++) { + len = ref_loop(limit, start, (int)k, 0, 0, want); + if (len < 0) { skipped++; continue; } + runs++; + CHECK(call(k ? t_qdo : t_do, 0, 0, 2, limit, start) && saw(want, (unsigned)len), + "%s LOOP [%u,%u]: %d times", k ? "?DO" : "DO", i, j, len); + } + for (k = 0; k < NSTEPS; k++) { + unsigned q; + for (q = 0; q < 2; q++) { + len = ref_loop(limit, start, (int)q, 1, steps[k], want); + if (len < 0) { skipped++; continue; } + runs++; + CHECK(call(q ? t_pqdo : t_ploop, steps[k], 0, 2, limit, start) && saw(want, (unsigned)len), + "%s +LOOP [%u,%u] step [%u]: %d times", q ? "?DO" : "DO", i, j, k, len); + } + } + } + printf(" loops run against C: %u (%u more would run past %d times and were left out)\n", runs, skipped, TCAP - 1); + CHECK(runs > 2000, "enough loops were run"); + + /* LEAVE and UNLOOP EXIT at every index of a short loop */ + for (i = 0; i < 12; i++) { + unsigned m; + for (m = 0, j = 0; j < 12; j++) { want[m++] = (v4_cell)j; if (j == i) break; want[m++] = (v4_cell)j; } + CHECK(call(t_leave, 0, (v4_cell)i, 2, 12, 0) && saw(want, m) && n.mem[LAST] == 77, "LEAVE at %u", i); + for (m = 0, j = 0; j < i; j++) want[m++] = (v4_cell)j; + CHECK(call(t_unloop, 0, (v4_cell)i, 2, 12, 0) && saw(want, m) && n.mem[LAST] == 0, "UNLOOP EXIT at %u", i); + } + + /* nested: every pair of small limits */ + for (i = 1; i <= 4; i++) + for (j = 11; j <= 14; j++) { + unsigned m = 0, a, b; + for (a = 0; a < i; a++) for (b = 10; b < j; b++) { want[m++] = (v4_cell)b; want[m++] = (v4_cell)a; } + CHECK(call(t_nest, 0, 0, 2, (v4_cell)i, (v4_cell)j) && saw(want, m), "nested [%u,%u]", i, j); + } + + /* What a loop leaves the code around it (D-2): a word with one loop, and + * with two nested. */ + headroom("DO .. LOOP", t_do, 0, 0, 2, 5, 0, 5, 6); + headroom("DO .. +LOOP", t_ploop, 2, 0, 2, 10, 0, 5, 6); + headroom("?DO .. LOOP", t_qdo, 0, 0, 2, 5, 2, 5, 6); + headroom("DO .. LEAVE .. LOOP", t_leave, 0, 3, 2, 10, 0, 5, 6); + headroom("nested DO, I and J", t_nest, 0, 0, 2, 3, 12, 5, 4); + + CHECK(v4_node_guards_intact(&n), "guards intact"); + + printf(" %d checks, %d failures\n", checks, failures); + return failures ? 1 : 0; +}