diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index cdda7453..b542dcce 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -147,8 +147,8 @@ 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! 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 TYPE SEND RECV`. Words that clobber `B`: -`Q./ Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS <# HOLD SIGN # #S #> . .R U. U.R D. D.R EMIT CR SPACE SPACES TYPE SEND RECV`. +document that clobber `A`: `@ ! +! -! 2@ 2! C@ C! 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`: +`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. @@ -457,8 +457,9 @@ All output reaches the console through `EMIT` (DEV). | `.` `.R` `U.` `U.R` `D.` `D.R` | CAP | Built on pictured output and `TYPE`; definitions below. As v3: the number in the current base, then one space; the `.R` words right-justify it in `width` columns first, print a wider number whole, and pad nothing for `width <= 0`. (The space after the `.R` words is not FORTH-79; it is what v3 prints.) Where v4 parts from v3: a double is `( lo hi )`, where v3's `D.` took the low cell on top; `D.` prints the whole double, where v3 printed `DOUBLE-OVERFLOW` unless it fitted one signed cell (they agree whenever it does); printing honours the `BASE` variable, where v3 printed in a host copy that only `DECIMAL`, `HEX` and `OCTAL` set, so `n BASE !` changed v3's input base but not its output; and the number is built in the 63-character hold buffer, so a longer one — a 64-bit cell in base 2, a large double in a small base — loses its leading characters and sets `NODE-ERROR` (D-13), where v3 printed from a private 80-character buffer. Executed on the golden model (2026-10-03) against a C reference in the ten bases of the pictured-output test and eleven field widths, and against five transcripts of the v3 binary (a sixth, the extreme cells, at 64-bit cells). Each leaves its caller 4 data cells and 2 return entries. All clobber `A` and `B`. | | `(W)` | CAP | Variable: the field width of the `.R` words. Like `BASE` and `HLD`, it lives in node memory, so the width is on neither stack while the picture runs. | | `.S` | RET | No visible stack pointer (D-2). | -| `?` | CAP | `@ .` | -| `DUMP` | CAP | Loop over `@`/`C@` with pictured output. | +| `?` | CAP | `( addr -- )`: `a! @ jump .` — the cell at word address `addr` (D-1), printed as `.` prints it. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | +| `DUMP` | CAP | `( baddr u -- )`: `u` bytes from byte address `baddr`, sixteen to a line, in v3's format: the address in hex, `": "`, each byte as two hex digits and a space (three spaces where the line runs out), `" \|"`, the bytes as characters with `.` for anything outside 32–126, `"\|"` and a new line. Always hex, whatever `BASE` is, and `BASE` is put back. The address is two hex digits per byte of a cell — 8 at 32-bit cells, 16 at 64, which is v3's width. Nothing for `u = 0`; for `u < 0` nothing is printed and `NODE-ERROR` is set, as `TYPE` does, where v3 raised its error flag. Addresses are not range-checked (open, `node.h`). Definition below. Executed on the golden model (2026-10-03) against a C reference at six alignments and every length 0–50, and at 64-bit cells against a transcript of the v3 binary, byte for byte. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | +| `(DP)` | CAP | Variable, 4 cells: `DUMP`'s saved `BASE`, address, count and column. | | `BASE` | CAP | Variable. | | `DECIMAL` `HEX` `OCTAL` | CAP | `10 BASE !` and so on. | @@ -500,6 +501,42 @@ return stack. `-ROT` is in line (`SWAP push SWAP pop`). : D. ( d -- ) 0 jump D.R ``` +```forth +\ DUMP. DIGITS is two per byte of a cell. +: (DB) ( -- c ) (DP) 1 + b! @b (DP) 3 + b! @b + jump C@ \ the byte in this column +: DUMP ( baddr u -- ) + -if OK drop drop NODE-ERROR b! -1 !b ; \ u < 0 + OK: (DP) 2 + b! !b (DP) 1 + b! !b \ count, address + BASE b! @b (DP) b! !b 16 BASE b! !b \ hex + LINE: (DP) 2 + b! @b if DONE drop + (DP) 1 + b! @b 0 <# DIGITS (DP) 3 + b! !b \ the address + AD: # (DP) 3 + b! @b -1 + dup !b if ADX drop jump AD + ADX: drop #> TYPE 58 EMIT SPACE + 0 (DP) 3 + b! !b \ the bytes in hex + HX: (DP) 2 + b! @b (DP) 3 + b! @b inv + -if HAVE \ count - column - 1 + drop SPACE SPACE SPACE jump HN + HAVE: drop (DB) 0 <# # # #> TYPE SPACE + HN: (DP) 3 + b! @b 1 + dup !b -16 + -if HXX drop jump HX + HXX: drop SPACE 124 EMIT + 0 (DP) 3 + b! !b \ the bytes as characters + CH: (DP) 2 + b! @b (DP) 3 + b! @b inv + -if HAVC jump CHX + HAVC: drop (DB) + dup -32 + -if GE drop drop 46 jump EM + GE: drop dup -127 + -if BIG drop jump EM + BIG: drop drop 46 + EM: EMIT + (DP) 3 + b! @b 1 + dup !b -16 + -if CHX drop jump CH + CHX: drop 124 EMIT CR + (DP) 1 + b! @b 16 + !b \ next line + (DP) 2 + b! @b -16 + -if MORE jump DONE + MORE: !b jump LINE + DONE: drop (DP) b! @b BASE b! !b ; +``` + +Everything `DUMP` keeps between words — the address, the count, the column and the saved `BASE` — is +in the variable `(DP)`, so the stacks carry only what each picture and `TYPE` need, and no loop count +sits on the return stack across a call. + There is one picture for signed singles, one for unsigned and one for doubles; each plain word is its `.R` word with a width of 0, entered by a jump, and all six share one tail, which ends in a jump to `SPACE`. The width is tested for sign before `width - u`, which could wrap for a very negative @@ -731,7 +768,8 @@ word. Per D-10 it occupies two cells on a 64-bit node too. Per D-8, v4 Q values | `Q.TO-INT` | CAP | `push a! 0 pop 15 FOR +* UNEXT drop drop a` — the same `+*` shift, 16 bits at every cell width, leaving the low cell in `A`. Rounds toward minus infinity, as v3's arithmetic shift does (−1.5 gives −2). Executed on the golden model (2026-10-02): v3's `q48_to_u64` exactly at 64-bit cells, its low cell at 32. Clobbers `A`. | | `Q.1` `Q.0` `Q.SCALE` | IN | Double-cell constants, placed in line as two literals, low cell first: `Q.1` and `Q.SCALE` are `65536 0` (1.0), `Q.0` is `0 0`. v3's are 65536, 0 and 65536. Executed on the golden model (2026-10-03): the values match v3's, `Q.1 Q.TO-INT` is 1, `1 Q.FROM-INT` is `Q.1`, and `q Q.1 Q.*` and `q Q.0 Q.+` return `q`. | | `Q.=` `Q.<` `Q.>` `Q.0=` `Q.MAX` `Q.MIN` | CAP | `D=`, `D<`, `2SWAP D<` (for `Q.>`), `D0=`, `DMAX`, `DMIN`. Signed (D-8); v3 compared unsigned, so v3 agrees only when both values have the same sign. Executed on the golden model (2026-10-02). `Q.>` was given here as `SWAP D<`, which swaps single cells, not Q values, and gave a wrong answer in 11702 of 20169 test cases. | -| `Q.PRINT` | CAP | Pictured output, five fractional digits. | +| `Q.PRINT` | CAP | `( q -- )`: the integer part, a point, the five digits `floor(frac * 100000 / 65536)`, then one space, as v3; always decimal, whatever `BASE` is, and `BASE` is put back. Signed (D-8): a negative value prints `-` and its magnitude (−1.5 prints `-1.50000`), where v3 printed it as a large unsigned number. `dup (QP) 3 + b! !b -if A DNEGATE A: (QP) 2 + b! !b dup (QP) 1 + b! !b BASE b! @b (QP) b! !b 10 BASE b! !b 65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT 0 <# # # # # # drop drop 46 HOLD (QP) 1 + b! @b (QP) 2 + b! @b dup push push a! 0 pop 15 FOR +* UNEXT drop drop a pop 15 FOR 2/ UNEXT HIMASK and #S (QP) 3 + b! @b SIGN #> (QP) b! @b BASE b! !b jump OUT` — `OUT` is the `TYPE jump SPACE` at the end of `.R`. The fraction is `frac * 3125 / 2048`, which stays inside a 32-bit cell where `frac * 100000` would not; times 3125 is times 5 five times. The integer part is `|q|` shifted right 16 as a double: its low cell by `Q.TO-INT`'s `+*` shift in line, its high cell by `2/` and `HIMASK`, which clears the top 16 bits. Executed on the golden model (2026-10-03) against a C reference, on every seventh fraction, and against a transcript of the v3 binary for non-negative values. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | +| `(QP)` | CAP | Variable, 4 cells: `Q.PRINT`'s saved `BASE`, `|q|` and the sign. | ### 5.27 Inference engine diff --git a/v4/tests/test_printing.c b/v4/tests/test_printing.c new file mode 100644 index 00000000..9ab4365d --- /dev/null +++ b/v4/tests/test_printing.c @@ -0,0 +1,829 @@ +/* test_printing.c -- `?`, Q.PRINT and DUMP, executed. + * + * DECOMPOSITION.md 5.8 and 5.26. These are built on the number-output + * words of test_numout.c, so that file's words are assembled again here, + * opcode for opcode, on a node of its own with the console attached. + * + * v3 (v3/src/word_source/format_words.c, q48_words.c): + * ? ( addr -- ) the cell at addr, as `.` prints it + * Q.PRINT ( q -- ) the integer part, a point, five decimal digits + * floor(frac * 100000 / 65536), then one space; + * always decimal, whatever BASE is + * DUMP ( addr u -- ) u bytes from addr, sixteen to a line: + * the address in hex, two digits per byte of a + * cell, ": ", each byte as two hex digits and a + * space (three spaces where the line runs out), + * " |", the bytes as characters with '.' for + * anything outside 32..126, "|" and a new line; + * always hex; nothing for u = 0 + * + * Where v4 parts from v3: + * - `?` takes a word address (D-1); DUMP takes a byte address, as C@ does; + * - Q.PRINT is signed (D-8): a negative value prints "-" and its + * magnitude; v3 printed it as a large unsigned number; + * - DUMP with u < 0 prints nothing and sets NODE-ERROR, as TYPE does; v3 + * raised its error flag. Addresses are not range-checked (open, node.h). + * + * Three transcripts of the real v3 binary are recorded below as expected + * output, taken on 2026-10-03 as in test_numout.c. v3's DUMP address is 16 + * digits because its cell is 64 bits, so the DUMP transcript is compared at + * 64-bit cells only; the test data sits at byte address 0xD0 as it did in v3. + */ +#include "v4/asm.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 puts the variables at the top of + * the node, where test_pictured.c and test_terminal.c put them. */ +#define NODE_ERROR ((v4_cell)(V4_NODE_WORDS - 2u)) +#define CONSOLE_TX ((v4_cell)(V4_NODE_WORDS - 4u)) +#define HBUF ((v4_cell)(V4_NODE_WORDS - 32u)) /* 16 cells = 64 bytes */ +#define HEND ((v4_cell)(HBUF * 4 + 64)) /* byte address past the buffer */ +#define HLD ((v4_cell)(V4_NODE_WORDS - 35u)) +#define BASE ((v4_cell)(V4_NODE_WORDS - 34u)) +#define FIELD ((v4_cell)(V4_NODE_WORDS - 36u)) /* (W): the field width of the .R words */ +#define HCAP 63 +#define QP ((v4_cell)(V4_NODE_WORDS - 40u)) /* (QP): Q.PRINT's BASE, |q| and sign */ +#define DP ((v4_cell)(V4_NODE_WORDS - 44u)) /* (DP): DUMP's BASE, address, count, column */ +#define XVAR ((v4_cell)(V4_NODE_WORDS - 45u)) /* a variable for `?` */ +#define CODE0 64 /* code starts here */ +#define DATA0 ((v4_cell)32) /* 32 cells of bytes to dump, below the code */ +#define DATA_BADDR ((v4_cell)(DATA0 * 4)) +#define V3_BADDR ((v4_cell)0xD0) /* where v3's VARIABLE X was */ + +static v4_node n; +static v4_exec_state es; +static v4_heat h; +static v4_asm as; + +static v4_cell w_swap, w_or, w_ummod, w_lshift, w_rshift, w_cstore, w_cfetch, + w_dnegate, w_base, w_begin, w_hold, w_sign, w_hash, w_hashs, w_end, + w_emit, w_space, w_type, + w_spaces, w_dot, w_dotr, w_udot, w_udotr, w_ddot, w_ddotr, + w_cr, w_query, w_qprint, w_dbyte, w_dump, t_v3q, t_v3p, l_out; + +#define O(name) v4_asm_op(&as, V4_OP_##name) +#define LIT(v) v4_asm_lit(&as, (v4_cell)(v)) +#define CALL(w) v4_asm_branch(&as, V4_OP_CALL, (w)) +#define JUMP(w) v4_asm_branch(&as, V4_OP_JUMP, (w)) +#define FWD(op) v4_asm_branch_fwd(&as, V4_OP_##op) +#define HERE_(r) v4_asm_resolve(&as, (r), v4_asm_label(&as)) +#define VGET(a) do { LIT(a); O(BANG_B); O(FETCH_B); } while (0) +#define VSET(a) do { LIT(a); O(BANG_B); O(STORE_B); } while (0) +#define SWAP_INLINE() do { O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); } while (0) +#define NROT_INLINE() do { SWAP_INLINE(); O(PUSH); SWAP_INLINE(); O(RPOP); } while (0) +#define SUB_INLINE() do { O(PUSH); O(INV); O(RPOP); O(ADD); O(INV); } while (0) + +/* The words these rest on, as in test_foundation.c, test_pictured.c and + * test_terminal.c, where each is tested on its own. */ +static void build_dependencies(void) +{ + /* : SWAP over push push drop pop pop ; */ + w_swap = v4_asm_label(&as); + O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI); + + /* : OR over inv and xor ; */ + w_or = v4_asm_label(&as); + O(OVER); O(INV); O(AND); O(XOR); O(SEMI); + + /* : UM/MOD ( ulo uhi ud -- urem uquot ) section 4, call-free */ + { + v4_cell loop, l_sub, l_setbit, l_nosub; + v4_asm_ref r0, r1, r2, r3, r4, r5, r6, to_sub1, to_sub2, to_nosub1, + to_nosub2, to_setbit; + + w_ummod = v4_asm_label(&as); + O(BANG_A); LIT(V4_CELL_BITS - 1); O(PUSH); + loop = v4_asm_label(&as); + r0 = FWD(MINUS_IF); + O(TWO_STAR); O(OVER); + r1 = FWD(MINUS_IF); + O(DROP); LIT(1); O(ADD); + r2 = FWD(JUMP); + HERE_(r1); + O(DROP); + HERE_(r2); + O(PUSH); O(TWO_STAR); O(RPOP); + to_sub1 = FWD(JUMP); + HERE_(r0); + O(TWO_STAR); O(OVER); + r3 = FWD(MINUS_IF); + O(DROP); LIT(1); O(ADD); + r4 = FWD(JUMP); + HERE_(r3); + O(DROP); + HERE_(r4); + O(PUSH); O(TWO_STAR); O(RPOP); + O(DUP); O(PUSH_A); O(XOR); + r5 = FWD(MINUS_IF); + O(DROP); + to_nosub1 = FWD(MINUS_IF); + to_sub2 = FWD(JUMP); + HERE_(r5); + O(DROP); O(DUP); O(INV); O(PUSH_A); O(ADD); O(INV); + r6 = FWD(MINUS_IF); + O(DROP); + to_nosub2 = FWD(JUMP); + HERE_(r6); + O(PUSH); O(DROP); O(RPOP); + to_setbit = FWD(JUMP); + l_sub = v4_asm_label(&as); + O(INV); O(PUSH_A); O(ADD); O(INV); + l_setbit = v4_asm_label(&as); + O(PUSH); LIT(1); O(ADD); O(RPOP); + l_nosub = v4_asm_label(&as); + v4_asm_branch(&as, V4_OP_NEXT, loop); + O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI); + + v4_asm_resolve(&as, to_sub1, l_sub); + v4_asm_resolve(&as, to_sub2, l_sub); + v4_asm_resolve(&as, to_setbit, l_setbit); + v4_asm_resolve(&as, to_nosub1, l_nosub); + v4_asm_resolve(&as, to_nosub2, l_nosub); + } + + /* : LSHIFT BEGIN dup WHILE 1- SWAP 2* SWAP REPEAT drop ; + * : RSHIFT BEGIN dup WHILE 1- SWAP 2/ MSB inv and SWAP REPEAT drop ; */ + { + v4_cell l0; + v4_asm_ref l1; + w_lshift = v4_asm_label(&as); + l0 = v4_asm_label(&as); + O(DUP); l1 = FWD(IF); + O(DROP); LIT(-1); O(ADD); CALL(w_swap); O(TWO_STAR); CALL(w_swap); + v4_asm_branch(&as, V4_OP_JUMP, l0); + HERE_(l1); + O(DROP); O(DROP); O(SEMI); + + w_rshift = v4_asm_label(&as); + l0 = v4_asm_label(&as); + O(DUP); l1 = FWD(IF); + O(DROP); LIT(-1); O(ADD); CALL(w_swap); + O(TWO_SLASH); LIT((v4_cell)V4_MSB); O(INV); O(AND); CALL(w_swap); + v4_asm_branch(&as, V4_OP_JUMP, l0); + HERE_(l1); + O(DROP); O(DROP); O(SEMI); + } + + /* C!, call-free, as in test_foundation.c. + * : C! ( c baddr -- ) call-free + * dup 2/ 2/ a! 3 and push 255 and pop c' k A: word address + * if K0 -1 + if K1 -1 + if K2 + * drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ; byte 3 + * K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ; byte 2 + * K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ; byte 1 + * K0: drop @ -256 and + ! ; byte 0 + * One case per byte position: the byte is shifted up, that byte of the + * cell cleared with a constant mask, and the two added. */ + { + v4_asm_ref k0, k1, k2; + w_cstore = v4_asm_label(&as); + O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); + LIT(3); O(AND); O(PUSH); LIT(255); O(AND); O(RPOP); + k0 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); k1 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); k2 = v4_asm_branch_fwd(&as, V4_OP_IF); + O(DROP); LIT(23); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_STAR); O(UNEXT); + O(FETCH_A); LIT((v4_cell)(v4_ucell)0xFF000000u); O(INV); O(AND); O(ADD); O(STORE_A); O(SEMI); + v4_asm_resolve(&as, k2, v4_asm_label(&as)); + O(DROP); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_STAR); O(UNEXT); + O(FETCH_A); LIT(-16711681); O(AND); O(ADD); O(STORE_A); O(SEMI); + v4_asm_resolve(&as, k1, v4_asm_label(&as)); + O(DROP); LIT(7); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_STAR); O(UNEXT); + O(FETCH_A); LIT(-65281); O(AND); O(ADD); O(STORE_A); O(SEMI); + v4_asm_resolve(&as, k0, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(-256); O(AND); O(ADD); O(STORE_A); O(SEMI); + } +} + +/* Pictured output, 5.8. */ +static void build_pictured(void) +{ + v4_asm_ref a, b, c; + v4_cell l; + + /* : (BASE) ( -- b ) BASE, or 10 when it is outside 2..36 + * BASE b! @b dup -2 + -if L1 drop drop 10 ; + * L1: drop dup -37 + -if L2 drop ; + * L2: drop drop 10 ; */ + w_base = v4_asm_label(&as); + VGET(BASE); O(DUP); LIT(-2); O(ADD); a = FWD(MINUS_IF); + O(DROP); O(DROP); LIT(10); O(SEMI); + HERE_(a); + O(DROP); O(DUP); LIT(-37); O(ADD); b = FWD(MINUS_IF); + O(DROP); O(SEMI); + HERE_(b); + O(DROP); O(DROP); LIT(10); O(SEMI); + + /* : <# ( -- ) HEND HLD b! !b ; */ + w_begin = v4_asm_label(&as); + LIT(HEND); VSET(HLD); O(SEMI); + + /* : HOLD ( c -- ) D-13 + * dup -256 and if OKC drop jump ERR c outside 0..255 + * OKC: drop HLD b! @b -(HEND-62) + -if ROOM drop 63 held already + * ERR: drop NODE-ERROR b! -1 !b ; + * ROOM: drop HLD b! @b -1 + dup !b jump C! + * The last step is a jump, not a call: C! returns to HOLD's caller. */ + w_hold = v4_asm_label(&as); + O(DUP); LIT(-256); O(AND); a = FWD(IF); + O(DROP); b = FWD(JUMP); + HERE_(a); + O(DROP); VGET(HLD); LIT(-(HEND - 62)); O(ADD); c = FWD(MINUS_IF); + O(DROP); + HERE_(b); + O(DROP); LIT(NODE_ERROR); O(BANG_B); LIT(-1); O(STORE_B); O(SEMI); + HERE_(c); + O(DROP); VGET(HLD); LIT(-1); O(ADD); O(DUP); O(STORE_B); + v4_asm_branch(&as, V4_OP_JUMP, w_cstore); + + /* : SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ; */ + w_sign = v4_asm_label(&as); + a = FWD(MINUS_IF); + O(DROP); LIT(45); v4_asm_branch(&as, V4_OP_JUMP, w_hold); + HERE_(a); + O(DROP); O(SEMI); + + /* : # ( ud1 -- ud2 ) + * ud1 / base in two UM/MOD steps, the high cell first and its remainder + * leading the low cell; the last remainder is the digit. + * 0 (BASE) UM/MOD -ROT qhi lo rem1 + * (BASE) UM/MOD -ROT qlo qhi rem + * The high quotient waits under the second division on the data stack, + * not on the return stack. -ROT in line is SWAP push SWAP pop. + * dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD */ + w_hash = v4_asm_label(&as); + LIT(0); CALL(w_base); CALL(w_ummod); NROT_INLINE(); + CALL(w_base); CALL(w_ummod); NROT_INLINE(); + O(DUP); LIT(-10); O(ADD); a = FWD(MINUS_IF); + O(DROP); LIT(48); O(ADD); b = FWD(JUMP); + HERE_(a); + O(DROP); LIT(55); O(ADD); + HERE_(b); + v4_asm_branch(&as, V4_OP_JUMP, w_hold); + + /* : #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ; */ + w_hashs = v4_asm_label(&as); + l = v4_asm_label(&as); + CALL(w_hash); O(OVER); O(OVER); CALL(w_or); a = FWD(IF); + O(DROP); v4_asm_branch(&as, V4_OP_JUMP, l); + HERE_(a); + O(DROP); O(SEMI); + + /* : #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ; */ + w_end = v4_asm_label(&as); + O(DROP); O(DROP); VGET(HLD); LIT(HEND); O(OVER); SUB_INLINE(); O(SEMI); + +} + +/* Number output, 5.8 and 5.10. */ +static void build_output(void) +{ + v4_asm_ref a, b, c, d, done1, done2; + v4_cell l, l_tail, l_line; + + /* : C@ ( baddr -- c ) as written in 5.3 + * dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; */ + w_cfetch = v4_asm_label(&as); + O(DUP); LIT(3); O(AND); LIT(3); CALL(w_lshift); + CALL(w_swap); LIT(2); CALL(w_rshift); O(BANG_A); O(FETCH_A); + CALL(w_swap); CALL(w_rshift); LIT(255); O(AND); O(SEMI); + + /* : DNEGATE ( d -- -d ) inv over if L1 drop push inv 1 + pop ; L1: drop 1 + ; */ + w_dnegate = v4_asm_label(&as); + O(INV); O(OVER); a = FWD(IF); + O(DROP); O(PUSH); O(INV); LIT(1); O(ADD); O(RPOP); O(SEMI); + HERE_(a); + O(DROP); LIT(1); O(ADD); O(SEMI); + + /* : EMIT ( c -- ) CONSOLE-TX b! !b ; : SPACE ( -- ) 32 jump EMIT */ + w_emit = v4_asm_label(&as); + LIT(CONSOLE_TX); O(BANG_B); O(STORE_B); O(SEMI); + w_space = v4_asm_label(&as); + LIT(32); JUMP(w_emit); + + /* : TYPE ( baddr u -- ) + * -if OK drop drop NODE-ERROR b! -1 !b ; + * OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK + * DONE: drop drop ; */ + w_type = v4_asm_label(&as); + a = FWD(MINUS_IF); + O(DROP); O(DROP); LIT(NODE_ERROR); O(BANG_B); LIT(-1); O(STORE_B); O(SEMI); + HERE_(a); + l = v4_asm_label(&as); + b = FWD(IF); + O(OVER); CALL(w_cfetch); CALL(w_emit); + O(PUSH); LIT(1); O(ADD); O(RPOP); LIT(-1); O(ADD); + JUMP(l); + HERE_(b); + O(DROP); O(DROP); O(SEMI); + + /* ---- the words under test ---- */ + + /* : SPACES ( n -- ) + * -if L drop ; n < 0 + * L: if DONE SPACE -1 + jump L + * DONE: drop ; */ + w_spaces = v4_asm_label(&as); + a = FWD(MINUS_IF); + O(DROP); O(SEMI); + HERE_(a); + l = v4_asm_label(&as); + b = FWD(IF); + CALL(w_space); LIT(-1); O(ADD); JUMP(l); + HERE_(b); + O(DROP); O(SEMI); + + /* : .R ( n width -- ) + * (W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> baddr u + * TAIL: (W) b! @b -if POS drop jump OUT width < 0 + * POS: over - SPACES + * OUT: TYPE jump SPACE + * The width waits in the variable (W), on neither stack, so the picture + * runs as deep as it does on its own. A negative width is dropped before + * the subtraction, which could otherwise wrap. U.R and D.R jump to TAIL, + * and SPACE returns to the caller. */ + w_dotr = v4_asm_label(&as); + VSET(FIELD); O(DUP); O(PUSH); + a = FWD(MINUS_IF); O(INV); LIT(1); O(ADD); HERE_(a); + LIT(0); CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end); + l_tail = v4_asm_label(&as); + VGET(FIELD); a = FWD(MINUS_IF); + O(DROP); b = FWD(JUMP); + HERE_(a); + O(OVER); SUB_INLINE(); CALL(w_spaces); + HERE_(b); + l_out = v4_asm_label(&as); + CALL(w_type); JUMP(w_space); + + /* : . ( n -- ) 0 jump .R */ + w_dot = v4_asm_label(&as); + LIT(0); JUMP(w_dotr); + + /* : U.R ( u width -- ) (W) b! !b 0 <# #S #> jump TAIL */ + w_udotr = v4_asm_label(&as); + VSET(FIELD); LIT(0); CALL(w_begin); CALL(w_hashs); CALL(w_end); JUMP(l_tail); + + /* : U. ( u -- ) 0 jump U.R */ + w_udot = v4_asm_label(&as); + LIT(0); JUMP(w_udotr); + + /* : D.R ( d width -- ) + * (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */ + w_ddotr = v4_asm_label(&as); + VSET(FIELD); O(DUP); O(PUSH); + a = FWD(MINUS_IF); CALL(w_dnegate); HERE_(a); + CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end); JUMP(l_tail); + + /* : D. ( d -- ) 0 jump D.R */ + w_ddot = v4_asm_label(&as); + LIT(0); JUMP(w_ddotr); + /* ---- the words under test ---- */ + + /* : CR ( -- ) 10 jump EMIT */ + w_cr = v4_asm_label(&as); + LIT(10); JUMP(w_emit); + + /* : ? ( addr -- ) a! @ jump . */ + w_query = v4_asm_label(&as); + O(BANG_A); O(FETCH_A); JUMP(w_dot); + + /* : Q.PRINT ( q -- ) + * dup (QP) 3 + b! !b -if A DNEGATE A: |q|, its sign saved + * (QP) 2 + b! !b dup (QP) 1 + b! !b lo + * BASE b! @b (QP) b! !b 10 BASE b! !b decimal + * 65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT frac * 3125 / 2048 + * 0 <# # # # # # drop drop 46 HOLD + * (QP) 1 + b! @b (QP) 2 + b! @b dup push lo hi R: hi + * push a! 0 pop 15 FOR +* UNEXT drop drop a low cell of |q| >> 16 + * pop 15 FOR 2/ UNEXT HIMASK and high cell of |q| >> 16 + * #S (QP) 3 + b! @b SIGN #> + * (QP) b! @b BASE b! !b + * jump OUT TYPE jump SPACE, in .R + * frac * 100000 / 65536 is frac * 3125 / 2048, which stays inside a + * 32-bit cell; times 3125 is times 5 five times. HIMASK clears the top + * 16 bits, making the 2/ shift a logical one. */ + w_qprint = v4_asm_label(&as); + O(DUP); VSET(QP + 3); + a = FWD(MINUS_IF); CALL(w_dnegate); HERE_(a); + VSET(QP + 2); O(DUP); VSET(QP + 1); + VGET(BASE); VSET(QP); LIT(10); VSET(BASE); + LIT(65535); O(AND); + LIT(4); O(PUSH); + (void)v4_asm_label(&as); + O(DUP); O(TWO_STAR); O(TWO_STAR); O(ADD); O(UNEXT); + LIT(10); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(0); CALL(w_begin); + CALL(w_hash); CALL(w_hash); CALL(w_hash); CALL(w_hash); CALL(w_hash); + O(DROP); O(DROP); LIT(46); CALL(w_hold); + VGET(QP + 1); VGET(QP + 2); O(DUP); O(PUSH); + O(PUSH); O(BANG_A); LIT(0); O(RPOP); + LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(MUL_STEP); O(UNEXT); + O(DROP); O(DROP); O(PUSH_A); + O(RPOP); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT((v4_cell)(MAXU >> 16)); O(AND); + CALL(w_hashs); VGET(QP + 3); CALL(w_sign); CALL(w_end); + VGET(QP); VSET(BASE); + JUMP(l_out); + + /* : (DB) ( -- c ) (DP) 1 + b! @b (DP) 3 + b! @b + jump C@ + * The byte in the current column of DUMP's current line. */ + w_dbyte = v4_asm_label(&as); + VGET(DP + 1); VGET(DP + 3); O(ADD); JUMP(w_cfetch); + + /* : DUMP ( baddr u -- ) + * -if OK drop drop NODE-ERROR b! -1 !b ; u < 0 + * OK: (DP) 2 + b! !b (DP) 1 + b! !b count, address + * BASE b! @b (DP) b! !b 16 BASE b! !b hex + * LINE: (DP) 2 + b! @b if DONE drop + * (DP) 1 + b! @b 0 <# DIGITS (DP) 3 + b! !b the address + * AD: # (DP) 3 + b! @b -1 + dup !b if ADX drop jump AD + * ADX: drop #> TYPE 58 EMIT SPACE + * 0 (DP) 3 + b! !b the bytes in hex + * HX: (DP) 2 + b! @b (DP) 3 + b! @b inv + -if HAVE count - column - 1 + * drop SPACE SPACE SPACE jump HN + * HAVE: drop (DB) 0 <# # # #> TYPE SPACE + * HN: (DP) 3 + b! @b 1 + dup !b -16 + -if HXX drop jump HX + * HXX: drop SPACE 124 EMIT + * 0 (DP) 3 + b! !b the bytes as characters + * CH: (DP) 2 + b! @b (DP) 3 + b! @b inv + -if HAVC jump CHX + * HAVC: drop (DB) + * dup -32 + -if GE drop drop 46 jump EM + * GE: drop dup -127 + -if BIG drop jump EM + * BIG: drop drop 46 + * EM: EMIT + * (DP) 3 + b! @b 1 + dup !b -16 + -if CHX drop jump CH + * CHX: drop 124 EMIT CR + * (DP) 1 + b! @b 16 + !b next line + * (DP) 2 + b! @b -16 + -if MORE jump DONE + * MORE: !b jump LINE + * DONE: drop (DP) b! @b BASE b! !b ; + * DIGITS is two per byte of a cell. Everything DUMP keeps between words + * is in the variable (DP), so the stacks carry only what each picture + * and TYPE need. */ + w_dump = v4_asm_label(&as); + a = FWD(MINUS_IF); + O(DROP); O(DROP); LIT(NODE_ERROR); O(BANG_B); LIT(-1); O(STORE_B); O(SEMI); + HERE_(a); + VSET(DP + 2); VSET(DP + 1); + VGET(BASE); VSET(DP); LIT(16); VSET(BASE); + l_line = v4_asm_label(&as); + VGET(DP + 2); done1 = FWD(IF); O(DROP); + + VGET(DP + 1); LIT(0); CALL(w_begin); LIT(V4_CELL_BITS / 4); VSET(DP + 3); + l = v4_asm_label(&as); + CALL(w_hash); VGET(DP + 3); LIT(-1); O(ADD); O(DUP); O(STORE_B); + a = FWD(IF); O(DROP); JUMP(l); + HERE_(a); O(DROP); + CALL(w_end); CALL(w_type); LIT(58); CALL(w_emit); CALL(w_space); + + LIT(0); VSET(DP + 3); + l = v4_asm_label(&as); + VGET(DP + 2); VGET(DP + 3); O(INV); O(ADD); a = FWD(MINUS_IF); + O(DROP); CALL(w_space); CALL(w_space); CALL(w_space); b = FWD(JUMP); + HERE_(a); + O(DROP); CALL(w_dbyte); LIT(0); CALL(w_begin); CALL(w_hash); CALL(w_hash); + CALL(w_end); CALL(w_type); CALL(w_space); + HERE_(b); + VGET(DP + 3); LIT(1); O(ADD); O(DUP); O(STORE_B); LIT(-16); O(ADD); + a = FWD(MINUS_IF); O(DROP); JUMP(l); + HERE_(a); O(DROP); + CALL(w_space); LIT(124); CALL(w_emit); + + LIT(0); VSET(DP + 3); + l = v4_asm_label(&as); + VGET(DP + 2); VGET(DP + 3); O(INV); O(ADD); a = FWD(MINUS_IF); + c = FWD(JUMP); + HERE_(a); + O(DROP); CALL(w_dbyte); + O(DUP); LIT(-32); O(ADD); a = FWD(MINUS_IF); + O(DROP); O(DROP); LIT(46); b = FWD(JUMP); + HERE_(a); + O(DROP); O(DUP); LIT(-127); O(ADD); a = FWD(MINUS_IF); + O(DROP); d = FWD(JUMP); + HERE_(a); + O(DROP); O(DROP); LIT(46); + HERE_(b); HERE_(d); + CALL(w_emit); + VGET(DP + 3); LIT(1); O(ADD); O(DUP); O(STORE_B); LIT(-16); O(ADD); + a = FWD(MINUS_IF); O(DROP); JUMP(l); + HERE_(a); HERE_(c); + O(DROP); LIT(124); CALL(w_emit); CALL(w_cr); + + VGET(DP + 1); LIT(16); O(ADD); O(STORE_B); + VGET(DP + 2); LIT(-16); O(ADD); a = FWD(MINUS_IF); + done2 = FWD(JUMP); + HERE_(a); + O(STORE_B); JUMP(l_line); + HERE_(done1); HERE_(done2); + O(DROP); VGET(DP); VSET(BASE); O(SEMI); + + /* ---- the v3 transcripts ---- */ +#define EM(ch) do { LIT(ch); CALL(w_emit); } while (0) +#define QPR(lo) do { LIT(lo); LIT(0); CALL(w_qprint); } while (0) + + /* VARIABLE X 1234 X ! X ? -77 X ! X ? HEX X ? DECIMAL 91 EMIT */ + t_v3q = v4_asm_label(&as); + LIT(1234); VSET(XVAR); LIT(XVAR); CALL(w_query); + LIT(-77); VSET(XVAR); LIT(XVAR); CALL(w_query); + LIT(16); VSET(BASE); LIT(XVAR); CALL(w_query); + LIT(10); VSET(BASE); EM(91); O(SEMI); + + /* 65536 Q.PRINT 98304 Q.PRINT 0 Q.PRINT 1 Q.PRINT 65535 Q.PRINT 205887 Q.PRINT 91 EMIT */ + t_v3p = v4_asm_label(&as); + QPR(65536); QPR(98304); QPR(0); QPR(1); QPR(65535); QPR(205887); EM(91); O(SEMI); +} + +/* ---- running ---------------------------------------------------------- */ + +static void prepare(v4_cell base) +{ + v4_dstack_reset(&n.ds); + v4_rstack_reset(&n.rs); + v4_exec_reset(&es); + v4_heat_reset(&h); + v4_node_console_attach(&n, CONSOLE_TX); + v4_node_store(&n, NODE_ERROR, 0); + v4_node_store(&n, BASE, base); +} + +static int call(v4_cell word, v4_cell base, unsigned argc, v4_cell a, v4_cell b) +{ + prepare(base); + 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, word, 4000000) > 0 && n.ds.t == CANARY + && v4_node_load(&n, BASE) == base; +} + +static int printed(const char *want) +{ + size_t len = strlen(want); + return n.console_len == len && n.console_dropped == 0 + && (len == 0 || memcmp(n.console, want, len) == 0); +} + +/* Stack headroom, as in test_foundation.c. */ +static int fits(v4_cell word, unsigned argc, v4_cell a, v4_cell b, + const char *want, unsigned dfill, unsigned rfill) +{ + unsigned i; + prepare(10); + 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, 4000000) <= 0) return 0; + if (!printed(want)) 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, unsigned argc, v4_cell a, v4_cell b, + const char *want, int *dh, int *rh) +{ + int d, r; + for (d = 0; d < V4_DATA_DEPTH; d++) if (!fits(word, argc, a, b, want, (unsigned)d + 1u, 0)) break; + for (r = 0; r < V4_RET_DEPTH; r++) if (!fits(word, argc, a, b, want, 0, (unsigned)r + 1u)) break; + *dh = d; *rh = r; + printf(" %s headroom: data %d below canary, return %d below its return address\n", name, d, r); +} + +/* ---- the C reference ---------------------------------------------------- */ + +#define LIMBS (2 * V4_CELL_BITS / 16) +#define BUFSZ 4096 + +/* The digits of the unsigned double hi:lo in `base` (2..36), most + * significant first, "0" for zero, by short division on 16-bit limbs. */ +static void ref_digits(v4_ucell lo, v4_ucell hi, unsigned base, char *out) +{ + uint32_t l[LIMBS]; + char tmp[2 * V4_CELL_BITS + 1]; + unsigned i, len = 0; + for (i = 0; i < LIMBS / 2; i++) { + l[i] = (uint32_t)((lo >> (16 * i)) & 0xFFFFu); + l[i + LIMBS / 2] = (uint32_t)((hi >> (16 * i)) & 0xFFFFu); + } + for (;;) { + uint32_t rem = 0; + int nonzero = 0; + for (i = LIMBS; i-- > 0; ) { + uint32_t v = (rem << 16) | l[i]; + l[i] = v / base; + rem = v % base; + if (l[i]) nonzero = 1; + } + tmp[len++] = (char)(rem < 10 ? '0' + rem : 'A' + (rem - 10)); + if (!nonzero) break; + } + for (i = 0; i < len; i++) out[i] = tmp[len - 1 - i]; + out[len] = 0; +} + +/* What Q.PRINT prints for the signed double hi:lo. */ +static void ref_qprint(v4_ucell lo, v4_ucell hi, char *out) +{ + uint32_t frac; + if (hi & V4_MSB) { + lo = (v4_ucell)0 - lo; + hi = ~hi + (lo == 0 ? 1u : 0u); + *out++ = '-'; + } + frac = (uint32_t)(((uint64_t)(lo & 0xFFFFu) * 100000u) / 65536u); + ref_digits((lo >> 16) | (hi << (V4_CELL_BITS - 16)), hi >> 16, 10, out); + sprintf(out + strlen(out), ".%05u ", (unsigned)frac); +} + +static unsigned char node_byte(v4_cell baddr) +{ + return (unsigned char)(((v4_ucell)n.mem[baddr >> 2] >> (8u * (unsigned)(baddr & 3))) & 0xFFu); +} + +/* What DUMP prints: v3's format_word_dump, with the address two hex digits + * per byte of a cell. */ +static void ref_dump(v4_cell baddr, v4_cell u, char *out) +{ + v4_cell i, j; + *out = 0; + for (i = 0; i < u; i += 16) { + out += sprintf(out, "%0*lX: ", V4_CELL_BITS / 4, (unsigned long)(baddr + i)); + for (j = 0; j < 16 && i + j < u; j++) out += sprintf(out, "%02X ", node_byte(baddr + i + j)); + for (; j < 16; j++) out += sprintf(out, " "); + out += sprintf(out, " |"); + for (j = 0; j < 16 && i + j < u; j++) { + unsigned char ch = node_byte(baddr + i + j); + *out++ = (ch >= 32 && ch <= 126) ? (char)ch : '.'; + } + out += sprintf(out, "|\n"); + } +} + +static void put_bytes(v4_cell baddr, const unsigned char *s, unsigned len) +{ + unsigned i; + for (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]; + w = (w & ~((v4_ucell)0xFFu << sh)) | ((v4_ucell)s[i] << sh); + n.mem[ba >> 2] = (v4_cell)w; + } +} + +static const v4_cell vec[] = { + 0, 1, 2, 9, 10, 35, 36, 255, 12345, 32768, 65535, 65536, 98304, -1, -2, -12345, -65536, + (v4_cell)(V4_MSB - 1u), (v4_cell)V4_MSB, (v4_cell)(MAXU / 3u) +}; +#define NVEC (sizeof vec / sizeof vec[0]) + +int main(void) +{ + static char want[BUFSZ]; + unsigned char bytes[128]; + unsigned i, j; + + printf("v4 printing tests (? Q.PRINT DUMP): V4_CELL_BITS=%d\n", V4_CELL_BITS); + + v4_node_reset(&n); + v4_asm_begin(&as, &n, CODE0); + build_dependencies(); + build_pictured(); + build_output(); + CHECK(v4_asm_ok(&as), "printing words assemble"); + CHECK(v4_asm_label(&as) < XVAR, "code stays below the variables"); + printf(" code: %ld of %u words\n", (long)v4_asm_label(&as) - CODE0, (unsigned)V4_NODE_WORDS); + + /* 128 bytes to dump: every kind of byte, with v3's twenty at 0xD0. */ + for (i = 0; i < sizeof bytes; i++) bytes[i] = (unsigned char)(i * 37u + 11u); + for (i = 0; i < 16; i++) bytes[i] = (unsigned char)(i < 8 ? 28 + i : 123 + i - 8); /* around 32 and 126 */ + put_bytes(DATA_BADDR, bytes, sizeof bytes); + put_bytes(V3_BADDR, (const unsigned char *)"abcd\0\0\0\0__heat_fetch", 20); + + /* ---- ? ---- */ + CHECK(call(t_v3q, 10, 0, 0, 0) && printed("1234 -77 -4D ["), "v3: ?"); + for (i = 0; i < NVEC; i++) { + char num[4 * V4_CELL_BITS]; + v4_ucell mag = vec[i] < 0 ? (v4_ucell)0 - (v4_ucell)vec[i] : (v4_ucell)vec[i]; + static const v4_cell qb[] = { 10, 16, 2 }; + for (j = 0; j < 3; j++) { + ref_digits(mag, 0, (unsigned)qb[j], num); + if (strlen(num) + (vec[i] < 0) > HCAP) continue; /* test_numout.c covers overflow */ + sprintf(want, "%s%s ", vec[i] < 0 ? "-" : "", num); + v4_node_store(&n, XVAR, vec[i]); + CHECK(call(w_query, qb[j], 1, XVAR, 0) && printed(want), "? base %ld [%u]: want \"%s\"", (long)qb[j], i, want); + CHECK(v4_node_load(&n, XVAR) == vec[i], "? leaves the cell [%u]", i); + } + } + + /* ---- Q.PRINT ---- */ + CHECK(call(t_v3p, 10, 0, 0, 0) && printed("1.00000 1.50000 0.00000 0.00001 0.99998 3.14158 ["), + "v3: Q.PRINT"); + CHECK(call(w_qprint, 10, 2, -65536, -1) && printed("-1.00000 "), "Q.PRINT of -1.0"); + CHECK(call(w_qprint, 10, 2, -98304, -1) && printed("-1.50000 "), "Q.PRINT of -1.5"); + CHECK(call(w_qprint, 10, 2, -1, -1) && printed("-0.00001 "), "Q.PRINT of -1 ulp"); + for (i = 0; i < NVEC; i++) + for (j = 0; j < NVEC; j++) { + static const v4_cell qb[] = { 10, 16, 2, 0 }; + unsigned k; + ref_qprint((v4_ucell)vec[i], (v4_ucell)vec[j], want); + for (k = 0; k < 4; k++) { + CHECK(call(w_qprint, qb[k], 2, vec[i], vec[j]) && printed(want), + "Q.PRINT [%u,%u] BASE %ld: want \"%s\"", i, j, (long)qb[k], want); + CHECK(v4_node_load(&n, NODE_ERROR) == 0, "Q.PRINT sets no error [%u,%u]", i, j); + } + } + /* every fraction's five digits */ + for (i = 0; i < 65536; i += 7) { + ref_qprint((v4_ucell)i, 0, want); + CHECK(call(w_qprint, 10, 2, (v4_cell)i, 0) && printed(want), "Q.PRINT fraction %u: want \"%s\"", i, want); + } + + /* ---- DUMP ---- */ +#if V4_CELL_BITS == 64 + /* VARIABLE X 1684234849 X ! X 8 DUMP X 3 DUMP X 20 DUMP */ + CHECK(call(w_dump, 10, 2, V3_BADDR, 8) + && printed("00000000000000D0: 61 62 63 64 00 00 00 00 |abcd....|\n"), + "v3: 8 DUMP"); + CHECK(call(w_dump, 10, 2, V3_BADDR, 3) + && printed("00000000000000D0: 61 62 63 |abc|\n"), + "v3: 3 DUMP"); + CHECK(call(w_dump, 10, 2, V3_BADDR, 20) + && printed("00000000000000D0: 61 62 63 64 00 00 00 00 5F 5F 68 65 61 74 5F 66 |abcd....__heat_f|\n" + "00000000000000E0: 65 74 63 68 |etch|\n"), + "v3: 20 DUMP"); +#else + CHECK(call(w_dump, 10, 2, V3_BADDR, 20) + && printed("000000D0: 61 62 63 64 00 00 00 00 5F 5F 68 65 61 74 5F 66 |abcd....__heat_f|\n" + "000000E0: 65 74 63 68 |etch|\n"), + "20 DUMP at 32 bits"); +#endif + for (i = 0; i < 6; i++) + for (j = 0; j <= 50; j++) { + static const v4_cell db[] = { 10, 16, 2 }; + ref_dump(DATA_BADDR + (v4_cell)i, (v4_cell)j, want); + CHECK(call(w_dump, db[(i + j) % 3], 2, DATA_BADDR + (v4_cell)i, (v4_cell)j) && printed(want), + "DUMP [%u,%u]", i, j); + CHECK(v4_node_load(&n, NODE_ERROR) == 0, "DUMP sets no error [%u,%u]", i, j); + } + ref_dump(DATA_BADDR, 128, want); + CHECK(call(w_dump, 10, 2, DATA_BADDR, 128) && printed(want), "DUMP of 128 bytes"); + ref_dump(DATA_BADDR + 1, 113, want); + CHECK(call(w_dump, 10, 2, DATA_BADDR + 1, 113) && printed(want), "DUMP of 113 bytes"); + + /* a negative count: nothing printed, NODE-ERROR set */ + { + static const v4_cell neg[] = { -1, -16, -12345, (v4_cell)V4_MSB }; + for (i = 0; i < 4; i++) { + CHECK(call(w_dump, 10, 2, DATA_BADDR, neg[i]) && printed(""), "DUMP negative count prints nothing [%u]", i); + CHECK(v4_node_load(&n, NODE_ERROR) == -1, "DUMP negative count sets NODE-ERROR [%u]", i); + } + } + + /* DUMP writes nothing it dumps */ + for (i = 0; i < sizeof bytes; i++) + if (i < (unsigned)(V3_BADDR - DATA_BADDR) || i >= (unsigned)(V3_BADDR - DATA_BADDR) + 20u) + if (node_byte(DATA_BADDR + (v4_cell)i) != bytes[i]) break; + CHECK(i == sizeof bytes, "the dumped bytes are untouched"); + + /* What they leave their caller (D-2). */ + { + int dh, rh; + v4_node_store(&n, XVAR, -12345); + headroom("?", w_query, 1, XVAR, 0, "-12345 ", &dh, &rh); + CHECK(dh >= 2 && rh >= 2, "? leaves room"); + headroom("Q.PRINT", w_qprint, 2, -98304, -1, "-1.50000 ", &dh, &rh); + CHECK(dh >= 2 && rh >= 2, "Q.PRINT leaves room"); + ref_dump(DATA_BADDR + 3, 21, want); + headroom("DUMP", w_dump, 2, DATA_BADDR + 3, 21, want, &dh, &rh); + CHECK(dh >= 2 && rh >= 2, "DUMP leaves room"); + } + + CHECK(v4_node_guards_intact(&n), "guards intact"); + + printf(" %d checks, %d failures\n", checks, failures); + return failures ? 1 : 0; +}