admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
7c5be227994f2456c522d7b3c4501adec091beba
LithosAnanake/v4/tests/test_printing.c
T
rajamesandClaude Opus 5.5 7c5be22799 feat(v4.0.0): C@ is call-free 
One case per byte position, like C!: the cell is shifted down with a
2/ loop and masked.  It replaces the version built on LSHIFT, RSHIFT
and SWAP calls.  C@ now leaves its caller 7 return entries (was 4), and
the words above it gain with it: TYPE 6 (was 3), DUMP 4, Q.PRINT, U.
and U.R 3 (were 2).  The signed number words stay at 2: their sign
waits on the return stack.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-03 17:15:57 -04:00

973 lines
41 KiB
C
Raw Blame History

/* 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 <stdint.h>
#include <stdio.h>
#include <string.h>
static int failures = 0, checks = 0;
#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0)
#define CANARY ((v4_cell)0x0C0FFEE5)
#define MAXU ((v4_ucell)~(v4_ucell)0)
/* The memory map is open (D-4); the test 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,
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_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 -- )
* (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);
/* : 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) < 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");
/* ---- 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;
}
Reference in New Issue View Git Blame Copy Permalink