admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
31fcdcd0a3d12876df7b1d709ac35e1dc15b9bc5
LithosAnanake/v4/tests/test_text.c
T
rajamesandClaude Opus 5.5 7b710aa322 feat(v4.0.0): assemble definitions written as text 
Test support, beside the slot packer: reads definitions in the notation
DECOMPOSITION.md uses -- words, opcodes, literals, constants, labels,
branches, FOR NEXT and FOR UNEXT, in-line macros, comments -- and lays
them down through the slot packer, so they no longer have to be retyped
opcode by opcode in C.

Tested by assembling SWAP, UM/MOD, C@ and C! both ways on two nodes and
comparing memory word for word, by running what is assembled, and on
every error it reports, each with its line number.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-03 21:13:32 -04:00

444 lines
23 KiB
C
Raw Blame History

/* test_text.c -- the text assembler (text.h).
*
* Its job is to produce, from a definition written as text, the words the
* slot packer (asm.h) produces from the same definition written by hand. So
* the first test assembles four real definitions both ways, on two nodes,
* and compares the memory word for word; the rest check each piece of the
* notation, that what is assembled runs, and every error it reports.
*/
#include "v4/text.h"
#include "v4/testcode.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 ORIGIN 16
#define VARS ((v4_cell)(V4_NODE_WORDS - 16u))
static v4_node na, nb; /* by hand, by text */
static v4_exec_state es;
static v4_heat h;
static v4_asm as;
static v4_text tx; /* large: not on the stack */
/* ---- four definitions by hand, as the other tests write them ----------- */
#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 FWD(op) v4_asm_branch_fwd(&as, V4_OP_##op)
#define HERE_(r) v4_asm_resolve(&as, (r), v4_asm_label(&as))
static v4_cell hand_swap, hand_ummod, hand_cfetch, hand_cstore, hand_roundtrip, hand_end;
static void build_by_hand(void)
{
v4_node_reset(&na);
v4_asm_begin(&as, &na, ORIGIN);
hand_swap = v4_asm_label(&as);
O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
{
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;
hand_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);
}
{
v4_asm_ref f0, f1, f2;
hand_cfetch = v4_asm_label(&as);
O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND);
f0 = FWD(IF);
LIT(-1); O(ADD); f1 = FWD(IF);
LIT(-1); O(ADD); f2 = FWD(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);
HERE_(f2);
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);
HERE_(f1);
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);
HERE_(f0);
O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI);
}
{
v4_asm_ref k0, k1, k2;
hand_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 = FWD(IF);
LIT(-1); O(ADD); k1 = FWD(IF);
LIT(-1); O(ADD); k2 = FWD(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);
HERE_(k2);
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);
HERE_(k1);
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);
HERE_(k0);
O(DROP); O(FETCH_A); LIT(-256); O(AND); O(ADD); O(STORE_A); O(SEMI);
}
/* ( c baddr -- c' ) dup push C! pop C@ ; calls, one of them backward */
hand_roundtrip = v4_asm_label(&as);
O(DUP); O(PUSH); CALL(hand_cstore); O(RPOP); v4_asm_branch(&as, V4_OP_JUMP, hand_cfetch);
hand_end = v4_asm_label(&as);
CHECK(v4_asm_ok(&as), "the hand-written words assemble");
}
/* The same four, as DECOMPOSITION.md writes them. */
static const char source[] =
"\\ four words from DECOMPOSITION.md sections 4 and 5.3\n"
"macro SWAP over push push drop pop pop endmacro\n"
"\n"
": SWAP' ( a b -- b a ) SWAP ;\n"
"\n"
": UM/MOD ( ulo uhi ud -- urem uquot )\n"
" a! N-1 FOR\n"
" -if L0 \\ hi's top bit set\n"
" 2* over -if L1 drop 1 + jump L2\n"
" L1: drop L2: push 2* pop\n"
" jump SUB\n"
" L0:\n"
" 2* over -if L3 drop 1 + jump L4\n"
" L3: drop L4: push 2* pop\n"
" dup a xor -if L5\n"
" drop -if NOSUB jump SUB\n"
" L5: drop dup inv a + inv -if L6\n"
" drop jump NOSUB\n"
" L6: push drop pop jump SETBIT\n"
" SUB: inv a + inv\n"
" SETBIT: push 1 + pop\n"
" NOSUB:\n"
" NEXT\n"
" SWAP ;\n"
"\n"
": C@ ( baddr -- c )\n"
" dup 2/ 2/ a! 3 and\n"
" if K0 -1 + if K1 -1 + if K2\n"
" drop @ 23 FOR 2/ UNEXT 255 and ;\n"
" K2: drop @ 15 FOR 2/ UNEXT 255 and ;\n"
" K1: drop @ 7 FOR 2/ UNEXT 255 and ;\n"
" K0: drop @ 255 and ;\n"
"\n"
": C! ( c baddr -- )\n"
" dup 2/ 2/ a! 3 and push 255 and pop\n"
" if K0 -1 + if K1 -1 + if K2\n"
" drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;\n"
" K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;\n"
" K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;\n"
" K0: drop @ -256 and + ! ;\n"
"\n"
": ROUNDTRIP ( c baddr -- c' ) dup push C! pop jump C@\n";
/* ---- running on the text-assembled node -------------------------------- */
static int call(v4_node *n, v4_cell word, unsigned argc, v4_cell a, v4_cell b, v4_cell c)
{
v4_dstack_reset(&n->ds);
v4_rstack_reset(&n->rs);
v4_exec_reset(&es);
v4_heat_reset(&h);
v4_dstack_push(&n->ds, CANARY);
if (argc > 0) v4_dstack_push(&n->ds, a);
if (argc > 1) v4_dstack_push(&n->ds, b);
if (argc > 2) v4_dstack_push(&n->ds, c);
return word >= 0 && v4_test_call(n, &es, &h, word, 100000) > 0;
}
static v4_cell pop(v4_node *n) { return v4_dstack_pop(&n->ds); }
/* Assemble `src` on a fresh node; 1 if it assembles and finishes. */
static int ok(const char *src)
{
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
v4_text_constant(&tx, "VAR", VARS);
return v4_text_assemble(&tx, src) && v4_text_finish(&tx);
}
/* Assemble `src`; 1 if it is refused with a message holding `what`, and,
* when `line` is not 0, naming that line. */
static int refused(const char *src, const char *what, unsigned line)
{
char want[32];
if (ok(src)) return 0;
snprintf(want, sizeof want, "line %u:", line);
if (strstr(v4_text_error(&tx), what) == NULL) { printf(" message was: %s\n", v4_text_error(&tx)); return 0; }
if (line && strncmp(v4_text_error(&tx), want, strlen(want)) != 0) { printf(" message was: %s\n", v4_text_error(&tx)); return 0; }
return 1;
}
/* Run the word NAME of the last assembly on up to two arguments; its one result. */
static v4_cell result(const char *name, unsigned argc, v4_cell a, v4_cell b)
{
v4_cell r;
if (!call(&nb, v4_text_word(&tx, name), argc, a, b, 0)) return (v4_cell)0x0BADBAD;
r = pop(&nb);
return pop(&nb) == CANARY ? r : (v4_cell)0x0BADBAD;
}
int main(void)
{
unsigned i;
printf("v4 text assembler tests: V4_CELL_BITS=%d\n", V4_CELL_BITS);
/* ---- the same words by hand and by text ---- */
build_by_hand();
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
v4_text_constant(&tx, "N-1", V4_CELL_BITS - 1);
CHECK(v4_text_assemble(&tx, source), "the text assembles: %s", v4_text_error(&tx));
CHECK(v4_text_finish(&tx), "and finishes: %s", v4_text_error(&tx));
CHECK(v4_text_error(&tx)[0] == 0, "with no error message");
CHECK(v4_text_word(&tx, "SWAP'") == hand_swap, "SWAP' is where the hand-written one is");
CHECK(v4_text_word(&tx, "UM/MOD") == hand_ummod, "UM/MOD is where the hand-written one is");
CHECK(v4_text_word(&tx, "C@") == hand_cfetch, "C@ is where the hand-written one is");
CHECK(v4_text_word(&tx, "C!") == hand_cstore, "C! is where the hand-written one is");
CHECK(v4_text_word(&tx, "ROUNDTRIP") == hand_roundtrip, "ROUNDTRIP is where the hand-written one is");
CHECK(v4_text_here(&tx) == hand_end, "the text ends where the hand-written code ends: %ld, %ld",
(long)v4_text_here(&tx), (long)hand_end);
CHECK(hand_end - ORIGIN > 60, "the comparison covers a real amount of code: %ld words", (long)(hand_end - ORIGIN));
for (i = 0; i < V4_NODE_WORDS; i++) if (na.mem[i] != nb.mem[i]) break;
CHECK(i == V4_NODE_WORDS, "every word of memory is the same; first difference at %u", i);
CHECK(v4_text_word(&tx, "SWAP") == -1 && v4_text_word(&tx, "N-1") == -1 && v4_text_word(&tx, "NOPE") == -1,
"a macro, a constant and an unknown name are not words");
/* and they run */
CHECK(call(&nb, v4_text_word(&tx, "UM/MOD"), 3, 100, 0, 7) && pop(&nb) == 14 && pop(&nb) == 2 && pop(&nb) == CANARY,
"100 0 7 UM/MOD is 2 14");
for (i = 0; i < 8; i++) {
v4_cell baddr = VARS * 4 + (v4_cell)i;
CHECK(call(&nb, v4_text_word(&tx, "ROUNDTRIP"), 2, (v4_cell)(0x341 + i), baddr, 0)
&& pop(&nb) == (v4_cell)((0x41 + i) & 0xFF) && pop(&nb) == CANARY, "C! then C@ at byte %u", i);
}
/* ---- the notation, piece by piece ---- */
/* numbers */
CHECK(ok(": T 123 ;") && result("T", 0, 0, 0) == 123, "a decimal literal");
CHECK(ok(": T -5 ;") && result("T", 0, 0, 0) == -5, "a negative literal");
CHECK(ok(": T $FF ;") && result("T", 0, 0, 0) == 255, "a hex literal");
CHECK(ok(": T $ff $Ab + ;") && result("T", 0, 0, 0) == 255 + 0xAB, "hex in either case");
CHECK(ok(": T 0 ;") && result("T", 0, 0, 0) == 0, "zero");
CHECK(ok(": T 1 2 3 4 5 6 7 + + + + + + ;") && result("T", 0, 0, 0) == 28, "seven literals in a row");
#if V4_CELL_BITS == 32
CHECK(ok(": T 4294967295 ;") && result("T", 0, 0, 0) == -1, "the largest unsigned number is all ones");
CHECK(ok(": T -2147483648 ;") && result("T", 0, 0, 0) == (v4_cell)V4_MSB, "the most negative number");
CHECK(ok(": T $FFFFFFFF ;") && result("T", 0, 0, 0) == -1, "eight hex digits");
CHECK(refused(": T 4294967296 ;", "does not fit a cell", 1), "one more than fits is refused");
CHECK(refused(": T -2147483649 ;", "does not fit a cell", 1), "one less than fits is refused");
CHECK(refused(": T $100000000 ;", "does not fit a cell", 1), "nine hex digits are refused");
#else
CHECK(ok(": T 18446744073709551615 ;") && result("T", 0, 0, 0) == -1, "the largest unsigned number is all ones");
CHECK(ok(": T -9223372036854775808 ;") && result("T", 0, 0, 0) == (v4_cell)V4_MSB, "the most negative number");
CHECK(ok(": T $FFFFFFFFFFFFFFFF ;") && result("T", 0, 0, 0) == -1, "sixteen hex digits");
CHECK(refused(": T 18446744073709551616 ;", "does not fit a cell", 1), "one more than fits is refused");
CHECK(refused(": T -9223372036854775809 ;", "does not fit a cell", 1), "one less than fits is refused");
CHECK(refused(": T $10000000000000000 ;", "does not fit a cell", 1), "seventeen hex digits are refused");
#endif
CHECK(refused(": T 99999999999999999999999999 ;", "does not fit a cell", 1), "a very long number is refused");
/* constants */
CHECK(ok(": T VAR ;") && result("T", 0, 0, 0) == VARS, "a constant is a literal");
CHECK(ok(": ST ( x -- ) VAR a! ! ; : LD ( -- x ) VAR a! @ ;")
&& call(&nb, v4_text_word(&tx, "ST"), 1, 4321, 0, 0) && pop(&nb) == CANARY
&& result("LD", 0, 0, 0) == 4321 && nb.mem[VARS] == 4321, "a constant used as an address");
/* comments */
CHECK(ok("\\ a line comment\n: T ( a stack comment ) 7 \\ another\n ( and\n one over two lines ) 8 + ; \\ the end")
&& result("T", 0, 0, 0) == 15, "comments are skipped");
CHECK(ok(": (T) 5 ; : T (T) (T) + ;") && result("T", 0, 0, 0) == 10, "a name in parentheses is a name, not a comment");
CHECK(refused(": T 1 ( never closed", "comment not closed", 0), "an open comment is refused");
/* every opcode has its mnemonic */
{
static const char *const m[V4_OPCODE_COUNT] = {
";", "ex", "jump", "call", "unext", "next", "if", "-if", "@p", "@+", "@b", "@", "!p", "!+", "!b", "!",
"+*", "2*", "2/", "inv", "+", "and", "xor", "drop", "dup", "pop", "over", "a", "nop", "push", "b!", "a!" };
for (i = 0; i < V4_OPCODE_COUNT; i++) {
char src[64];
unsigned op;
if (v4_op_is_branch(i) || i == V4_OP_FETCH_P) continue;
snprintf(src, sizeof src, ": T %s", m[i]);
CHECK(ok(src), "opcode %s assembles", m[i]);
op = (unsigned)(((v4_ucell)nb.mem[ORIGIN] >> V4_SLOT_LOW_BIT(0)) & 0x1Fu);
CHECK(op == i, "%s is opcode %u, got %u", m[i], i, op);
}
}
CHECK(refused(": T @p ;", "write the number", 1), "@p cannot be written");
/* calls: backward, forward, and across calls to v4_text_assemble */
CHECK(ok(": A 3 ; : T A A + ;") && result("T", 0, 0, 0) == 6, "a call to an earlier word");
CHECK(ok(": T A A + ; : A 4 ;") && result("T", 0, 0, 0) == 8, "a call to a later word");
CHECK(ok(": T jump A : A 9 ;") && result("T", 0, 0, 0) == 9, "a jump to a later word");
CHECK(ok(": T call A 1 + ; : A 9 ;") && result("T", 0, 0, 0) == 10, "call NAME is the same as NAME");
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
CHECK(v4_text_assemble(&tx, ": T B 1 + ;") && v4_text_assemble(&tx, "macro TWICE dup + endmacro : B 20 TWICE ;")
&& v4_text_finish(&tx) && result("T", 0, 0, 0) == 41, "a word defined in a later assembly; macros carry over");
CHECK(v4_text_assemble(&tx, ": U T TWICE ;") && v4_text_finish(&tx) && result("U", 0, 0, 0) == 82,
"assembling goes on after a finish");
CHECK(ok(": A 1 ; : B A A + ; : C B B + ; : T C C + ;") && result("T", 0, 0, 0) == 8, "calls three deep");
CHECK(ok(": T 5 \n : U 1 + ;") && result("T", 0, 0, 0) == 6, "a word with no ; runs on into the next");
/* labels */
CHECK(ok(": T ( n -- 1|2 ) if Z drop 1 ; Z: drop 2 ;") && result("T", 1, 5, 0) == 1 && result("T", 1, 0, 0) == 2,
"a forward label");
CHECK(ok(": T ( n -- 0 ) L: if DONE -1 + jump L DONE: ;") && result("T", 1, 9, 0) == 0, "a backward label");
CHECK(ok(": T ( n -- f ) -if P drop -1 ; P: drop 0 ;") && result("T", 1, -3, 0) == -1 && result("T", 1, 3, 0) == 0,
"-if to a label");
CHECK(ok(": A ( n -- 1|2 ) if L drop 1 ; L: drop 2 ; : T ( n -- 3|4 ) if L drop 3 ; L: drop 4 ;")
&& result("A", 1, 0, 0) == 2 && result("T", 1, 0, 0) == 4 && result("T", 1, 1, 0) == 3,
"the same label name in two words");
CHECK(ok(": L 50 ; : T ( n -- x ) if L drop 1 ; L: drop 2 ;") && result("T", 1, 0, 0) == 2,
"a label of this word comes before a word of the same name, even defined after the branch");
CHECK(ok(": L 50 ; : T ( n -- x ) L: if DONE -1 + jump L DONE: drop 3 ;") && result("T", 1, 4, 0) == 3,
"and defined before it");
CHECK(ok(": L drop 50 ; : T ( n -- x ) if L drop 1 ; : U 2 ;") && result("T", 1, 0, 0) == 50,
"with no such label the branch goes to the word");
CHECK(ok(": L drop 50 ; : T ( n -- x ) if L drop 1 ;") && result("T", 1, 0, 0) == 50,
"also when the text ends there");
CHECK(ok(": T ( n -- x ) if OUT drop 1 ; : OUT drop 77 ;") && result("T", 1, 0, 0) == 77 && result("T", 1, 4, 0) == 1,
"a branch target that is no label of its word is a word");
CHECK(refused(": T L: 1 L: 2 ;", "label already defined", 1), "a label twice in one word is refused");
CHECK(refused(": T if NOWHERE ;\n: U 1 ;", "never defined", 1), "a branch to nothing is refused, with its line");
CHECK(refused("\n\n: T 1 MISSING + ;", "never defined", 3), "a call to nothing is refused, with its line");
CHECK(refused(": T jump", "branch without a target", 1), "a branch with nothing after it is refused");
CHECK(refused(": T jump 5 ;", "not something to branch to", 1), "a branch to a number is refused");
CHECK(refused(": T jump VAR ;", "not something to branch to", 1), "a branch to a constant is refused");
CHECK(refused(": T jump dup ;", "not something to branch to", 1), "a branch to an opcode is refused");
/* FOR ... NEXT and FOR ... UNEXT */
CHECK(ok(": T ( n -- n+5 ) 4 FOR 1 + NEXT ;") && result("T", 1, 10, 0) == 15, "FOR NEXT runs its body n+1 times");
CHECK(ok(": T ( n -- n*8 ) 2 FOR 2* UNEXT ;") && result("T", 1, 3, 0) == 24, "FOR UNEXT runs its body n+1 times");
CHECK(ok(": T ( n -- x ) 1 FOR 2 FOR 2* UNEXT NEXT ;") && result("T", 1, 1, 0) == 64, "UNEXT inside NEXT");
CHECK(ok(": T ( n -- x ) 2 FOR 2* UNEXT 1 + ;") && result("T", 1, 1, 0) == 9, "code after UNEXT shares its word");
CHECK(ok(": T ( n -- x ) 2 FOR dup + 2* nop UNEXT ;") && result("T", 1, 1, 0) == 64, "a body of four slots and unext fit");
CHECK(refused(": T 2 FOR dup + 2* nop nop nop UNEXT ;", "must fit one instruction word", 1), "a body of six slots does not");
CHECK(refused(": T 2 FOR 1 + UNEXT ;", "must fit one instruction word", 1), "a literal in an UNEXT body is refused");
CHECK(refused(": T NEXT ;", "NEXT without FOR", 1), "NEXT alone is refused");
CHECK(refused(": T UNEXT ;", "UNEXT without FOR", 1), "UNEXT alone is refused");
CHECK(refused(": T 3 FOR 1 + ;\n: U ;", "FOR without NEXT", 2), "FOR left open is refused");
CHECK(refused(": T 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR ;", "nested too deep", 1), "nine FORs deep is refused");
/* macros */
CHECK(ok("macro SWAP over push push drop pop pop endmacro : T ( a b -- b ) SWAP drop ;")
&& result("T", 2, 3, 10) == 10, "a macro is laid down in line");
CHECK(ok("macro 1+ 1 + endmacro macro 2+ 1+ 1+ endmacro : T 2+ 2+ ;") && result("T", 1, 5, 0) == 9, "macros in macros");
CHECK(ok("macro TEN ( a comment ) 10 \\ and another\n endmacro : T TEN TEN + ;") && result("T", 0, 0, 0) == 20,
"comments inside a macro are dropped");
CHECK(ok("macro SHL3 2 FOR 2* UNEXT endmacro : T SHL3 ;") && result("T", 1, 1, 0) == 8, "FOR UNEXT in a macro");
CHECK(ok(": A 6 ; macro CALLS A A + endmacro : T CALLS ;") && result("T", 0, 0, 0) == 12, "a macro that calls words");
CHECK(ok("macro NOTHING endmacro : T 5 NOTHING ;") && result("T", 0, 0, 0) == 5, "an empty macro");
CHECK(refused("macro M L: endmacro", "not allowed in a macro", 1), "a label in a macro is refused");
CHECK(refused("macro M : X ; endmacro", "not allowed in a macro", 1), "a word in a macro is refused");
CHECK(refused("macro M macro N endmacro endmacro", "not allowed in a macro", 1), "a macro in a macro is refused");
CHECK(refused("macro M 1 2 3", "macro without endmacro", 1), "a macro left open is refused");
CHECK(refused("macro", "macro without a name", 0), "macro with no name is refused");
CHECK(refused(": T endmacro ;", "endmacro without macro", 1), "endmacro alone is refused");
CHECK(refused("macro M M endmacro : T M ;", "nested too deep", 1), "a macro that uses itself is refused");
/* names */
CHECK(refused(": A 1 ;\n: A 2 ;", "already defined", 2), "a word defined twice is refused");
CHECK(refused(": VAR 1 ;", "already defined", 1), "a word named like a constant is refused");
CHECK(refused("macro A 1 endmacro : A 2 ;", "already defined", 1), "a word named like a macro is refused");
CHECK(refused(": dup 1 ;", "cannot be used as a name", 1), "a word named like an opcode is refused");
CHECK(refused(": 12 1 ;", "cannot be used as a name", 1), "a word named like a number is refused");
CHECK(refused(": FOR 1 ;", "cannot be used as a name", 1), "a word named FOR is refused");
CHECK(refused("macro + 1 endmacro", "cannot be used as a name", 1), "a macro named like an opcode is refused");
CHECK(refused(": X: 1 ;", "cannot be used as a name", 1), "a word named like a label is refused");
CHECK(refused(":", ": without a name", 0), ": with no name is refused");
CHECK(refused(": T THIS-NAME-IS-MUCH-TOO-LONG-TO-BE-A-NAME-IN-THIS-ASSEMBLER-BY-A-WIDE-MARGIN ;", "name too long", 1),
"a name of more than 63 characters is refused");
CHECK(ok(": Dup 3 ; : T Dup Dup + ;") && result("T", 0, 0, 0) == 6, "names are case sensitive");
CHECK(ok(": 2DUP over over ; : 1+ 1 + ; : T ( a b -- 2a+2b+1 ) 2DUP + + + 1+ ;") && result("T", 2, 2, 3) == 11,
"names that begin with digits");
/* once it has failed it stays failed, and says why */
CHECK(!ok(": T 1 ;\n: T 2 ;") && !v4_text_assemble(&tx, ": U 3 ;") && !v4_text_finish(&tx)
&& strstr(v4_text_error(&tx), "line 2: already defined: T") != NULL, "the first error is kept: %s", v4_text_error(&tx));
/* a full node */
{
static char big[8 * V4_NODE_WORDS + 64];
size_t at = 0;
at += (size_t)sprintf(big + at, ": T ");
for (i = 0; i < V4_NODE_WORDS; i++) at += (size_t)sprintf(big + at, "1 2 3 ");
CHECK(refused(big, "does not fit", 1), "text that overflows the node is refused");
CHECK(v4_node_guards_intact(&nb), "and wrote nothing outside it");
}
/* a branch always reaches: fill most of the node, then branch across it */
{
static char far[8 * V4_NODE_WORDS + 256];
size_t at = 0;
at += (size_t)sprintf(far + at, ": T ( n -- x ) nop nop nop if FAR drop 7 ; ");
at += (size_t)sprintf(far + at, ": PAD ");
for (i = 0; i < V4_NODE_WORDS - 200u; i++) at += (size_t)sprintf(far + at, "nop ; ");
at += (size_t)sprintf(far + at, ": FAR drop 99 ; ");
CHECK(ok(far) && result("T", 1, 0, 0) == 99 && result("T", 1, 6, 0) == 7,
"a branch from a late slot to the other end of the node: %s", v4_text_error(&tx));
CHECK(v4_text_word(&tx, "FAR") > (v4_cell)(V4_NODE_WORDS - 200u), "FAR is far: %ld", (long)v4_text_word(&tx, "FAR"));
}
CHECK(v4_node_guards_intact(&na) && v4_node_guards_intact(&nb), "guards intact");
printf(" %d checks, %d failures\n", checks, failures);
return failures ? 1 : 0;
}
Reference in New Issue View Git Blame Copy Permalink