/* test_printing.c -- `?`, Q.PRINT, DUMP, and BASE DECIMAL HEX OCTAL HLD, 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 * BASE ( -- addr ) the address of the number base * DECIMAL HEX OCTAL set it to 10, 16, 8 * HLD ( -- addr ) is not a v3 word; it is the address of the pointer the * pictured-output words keep (5.8). * * 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; * - `n BASE !` changes what v4 prints; in v3 it changed only the input * base, because v3 printed in a host copy that DECIMAL, HEX and OCTAL set; * - 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). * * Four 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 TRAIL ((v4_cell)(V4_NODE_WORDS - 46u)) /* (W)+1 in the document: whether a blank follows the number */ #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, w_basevar, w_hldvar, w_decimal, w_hex, w_octal, t_v3b, t_hld1, t_hld2, t_base2; #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_rbody, l_ubody, l_dbody, l_line; /* : C@ ( baddr -- c ) call-free, 5.3 * dup 2/ 2/ a! 3 and k A: word address * if K0 -1 + if K1 -1 + if K2 * drop @ 23 FOR 2/ UNEXT 255 and ; byte 3 * K2: drop @ 15 FOR 2/ UNEXT 255 and ; byte 2 * K1: drop @ 7 FOR 2/ UNEXT 255 and ; byte 1 * K0: drop @ 255 and ; byte 0 */ w_cfetch = v4_asm_label(&as); { v4_asm_ref f0, f1, f2; O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND); f0 = v4_asm_branch_fwd(&as, V4_OP_IF); LIT(-1); O(ADD); f1 = v4_asm_branch_fwd(&as, V4_OP_IF); LIT(-1); O(ADD); f2 = v4_asm_branch_fwd(&as, V4_OP_IF); O(DROP); O(FETCH_A); LIT(23); O(PUSH); (void)v4_asm_label(&as); O(TWO_SLASH); O(UNEXT); LIT(255); O(AND); O(SEMI); v4_asm_resolve(&as, f2, v4_asm_label(&as)); O(DROP); O(FETCH_A); LIT(15); O(PUSH); (void)v4_asm_label(&as); O(TWO_SLASH); O(UNEXT); LIT(255); O(AND); O(SEMI); v4_asm_resolve(&as, f1, v4_asm_label(&as)); O(DROP); O(FETCH_A); LIT(7); O(PUSH); (void)v4_asm_label(&as); O(TWO_SLASH); O(UNEXT); LIT(255); O(AND); O(SEMI); v4_asm_resolve(&as, f0, v4_asm_label(&as)); O(DROP); O(FETCH_A); 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 -- ) FORTH-79: no blank after it * 0 (W) 1 + b! !b * BODY: (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 (W) 1 + b! @b if DONE drop jump SPACE * DONE: drop ; * 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. (W)+1 says whether a blank * follows the number: `.` sets it and enters at BODY with a width of 0; * `.R` clears it. U.R and D.R jump to TAIL. */ w_dotr = v4_asm_label(&as); LIT(0); VSET(TRAIL); l_rbody = 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); VGET(TRAIL); a = FWD(IF); O(DROP); JUMP(w_space); HERE_(a); O(DROP); O(SEMI); /* : . ( n -- ) -1 (W) 1 + b! !b 0 jump BODY a blank after it */ w_dot = v4_asm_label(&as); LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_rbody); /* : U.R ( u width -- ) 0 (W) 1 + b! !b UBODY: (W) b! !b 0 <# #S #> jump TAIL */ w_udotr = v4_asm_label(&as); LIT(0); VSET(TRAIL); l_ubody = v4_asm_label(&as); VSET(FIELD); LIT(0); CALL(w_begin); CALL(w_hashs); CALL(w_end); JUMP(l_tail); /* : U. ( u -- ) -1 (W) 1 + b! !b 0 jump UBODY */ w_udot = v4_asm_label(&as); LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_ubody); /* : D.R ( d width -- ) * 0 (W) 1 + b! !b DBODY: (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */ w_ddotr = v4_asm_label(&as); LIT(0); VSET(TRAIL); l_dbody = 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 -- ) -1 (W) 1 + b! !b 0 jump DBODY */ w_ddot = v4_asm_label(&as); LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_dbody); /* ---- 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 * -1 (W) 1 + b! !b jump OUT TYPE and a blank, 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); LIT(-1); VSET(TRAIL); 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); /* : BASE ( -- addr ) the word address of the variable, a literal * : HLD ( -- addr ) likewise * A variable compiles in line as its address; they are words here so * that they can be called on their own. */ w_basevar = v4_asm_label(&as); LIT(BASE); O(SEMI); w_hldvar = v4_asm_label(&as); LIT(HLD); O(SEMI); /* : DECIMAL 10 BASE ! ; : HEX 16 BASE ! ; : OCTAL 8 BASE ! ; * with `!` in line as a! ! (5.3). */ w_decimal = v4_asm_label(&as); LIT(10); LIT(BASE); O(BANG_A); O(STORE_A); O(SEMI); w_hex = v4_asm_label(&as); LIT(16); LIT(BASE); O(BANG_A); O(STORE_A); O(SEMI); w_octal = v4_asm_label(&as); LIT(8); LIT(BASE); O(BANG_A); O(STORE_A); O(SEMI); /* v3, where a number is read in the current base: * BASE @ . HEX BASE @ DECIMAL . OCTAL BASE @ DECIMAL . 255 HEX . 255 OCTAL . * 255 DECIMAL . 7 BASE ! BASE @ DECIMAL . 91 EMIT * The second 255 was read in hex (597) and the third in octal (173). */ #define BASE_FETCH() do { CALL(w_basevar); O(BANG_A); O(FETCH_A); } while (0) t_v3b = v4_asm_label(&as); BASE_FETCH(); CALL(w_dot); CALL(w_hex); BASE_FETCH(); CALL(w_decimal); CALL(w_dot); CALL(w_octal); BASE_FETCH(); CALL(w_decimal); CALL(w_dot); LIT(255); CALL(w_hex); CALL(w_dot); LIT(597); CALL(w_octal); CALL(w_dot); LIT(173); CALL(w_decimal); CALL(w_dot); LIT(7); CALL(w_basevar); O(BANG_A); O(STORE_A); BASE_FETCH(); CALL(w_decimal); CALL(w_dot); LIT(91); CALL(w_emit); O(SEMI); /* ( -- hld baddr u ) <# 65 HOLD 66 HOLD HLD @ 0 0 #> */ t_hld1 = v4_asm_label(&as); CALL(w_begin); LIT(65); CALL(w_hold); LIT(66); CALL(w_hold); CALL(w_hldvar); O(BANG_A); O(FETCH_A); LIT(0); LIT(0); CALL(w_end); O(SEMI); /* ( u -- baddr u' hld ) 0 <# #S #> HLD @ */ t_hld2 = v4_asm_label(&as); LIT(0); CALL(w_begin); CALL(w_hashs); CALL(w_end); CALL(w_hldvar); O(BANG_A); O(FETCH_A); O(SEMI); /* ( n -- ) 2 BASE ! . */ t_base2 = v4_asm_label(&as); LIT(2); CALL(w_basevar); O(BANG_A); O(STORE_A); JUMP(w_dot); /* ---- 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 BASE HLD): 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) < TRAIL, "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"); /* ---- BASE DECIMAL HEX OCTAL HLD ---- */ { static const struct { v4_cell *w; v4_cell val; const char *name; } setter[] = { { &w_decimal, 10, "DECIMAL" }, { &w_hex, 16, "HEX" }, { &w_octal, 8, "OCTAL" } }; static const v4_cell before[] = { 10, 16, 8, 2, 36, 0, -1, 12345 }; v4_cell hld, baddr, u; prepare(10); v4_dstack_push(&n.ds, CANARY); CHECK(v4_test_call(&n, &es, &h, t_v3b, 4000000) > 0 && n.ds.t == CANARY && printed("10 16 8 FF 1125 173 7 ["), "v3: BASE, HEX, OCTAL, DECIMAL"); CHECK(v4_node_load(&n, BASE) == 10, "the transcript ends in decimal"); prepare(10); v4_dstack_push(&n.ds, CANARY); CHECK(v4_test_call(&n, &es, &h, w_basevar, 1000) > 0 && v4_dstack_pop(&n.ds) == BASE && v4_dstack_pop(&n.ds) == CANARY, "BASE leaves the variable's address"); prepare(10); v4_dstack_push(&n.ds, CANARY); CHECK(v4_test_call(&n, &es, &h, w_hldvar, 1000) > 0 && v4_dstack_pop(&n.ds) == HLD && v4_dstack_pop(&n.ds) == CANARY, "HLD leaves the variable's address"); for (i = 0; i < 3; i++) for (j = 0; j < sizeof before / sizeof before[0]; j++) { v4_cell below = v4_node_load(&n, BASE - 1), above = v4_node_load(&n, BASE + 1); prepare(before[j]); v4_dstack_push(&n.ds, CANARY); CHECK(v4_test_call(&n, &es, &h, *setter[i].w, 1000) > 0 && n.ds.t == CANARY, "%s returns with the stack as it was", setter[i].name); CHECK(v4_node_load(&n, BASE) == setter[i].val, "%s from %ld", setter[i].name, (long)before[j]); CHECK(v4_node_load(&n, BASE - 1) == below && v4_node_load(&n, BASE + 1) == above && n.console_len == 0 && v4_node_load(&n, NODE_ERROR) == 0, "%s touches nothing else", setter[i].name); } /* n BASE ! changes what is printed (v3 printed 5 here). */ prepare(10); v4_dstack_push(&n.ds, CANARY); v4_dstack_push(&n.ds, 5); CHECK(v4_test_call(&n, &es, &h, t_base2, 4000000) > 0 && n.ds.t == CANARY && printed("101 "), "2 BASE ! 5 . prints 101"); /* HLD holds the byte address of the first held character. */ prepare(10); v4_dstack_push(&n.ds, CANARY); CHECK(v4_test_call(&n, &es, &h, t_hld1, 4000000) > 0, "<# 65 HOLD 66 HOLD HLD @ 0 0 #> returns"); u = v4_dstack_pop(&n.ds); baddr = v4_dstack_pop(&n.ds); hld = v4_dstack_pop(&n.ds); CHECK(v4_dstack_pop(&n.ds) == CANARY && u == 2 && baddr == HEND - 2 && hld == baddr, "after two HOLDs HLD @ is HEND - 2, and #> returns it"); CHECK(node_byte(hld) == 66 && node_byte(hld + 1) == 65, "the held characters are at HLD @"); for (i = 0; i < NVEC; i++) { prepare(10); v4_dstack_push(&n.ds, CANARY); v4_dstack_push(&n.ds, vec[i]); CHECK(v4_test_call(&n, &es, &h, t_hld2, 4000000) > 0, "0 <# #S #> HLD @ returns [%u]", i); hld = v4_dstack_pop(&n.ds); u = v4_dstack_pop(&n.ds); baddr = v4_dstack_pop(&n.ds); CHECK(v4_dstack_pop(&n.ds) == CANARY && hld == baddr && baddr + u == HEND, "HLD @ is the address #> returns [%u]", i); } } /* What they leave their caller (D-2). */ { int dh, rh; headroom("DECIMAL", w_decimal, 0, 0, 0, "", &dh, &rh); CHECK(dh >= 6 && rh >= 7, "DECIMAL leaves room"); 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 >= 3 && rh >= 3, "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 >= 3 && rh >= 4, "DUMP leaves room"); } CHECK(v4_node_guards_intact(&n), "guards intact"); printf(" %d checks, %d failures\n", checks, failures); return failures ? 1 : 0; }