/* 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 #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 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"); /* CONST+N: a constant and an offset as one literal */ CHECK(ok(": T VAR+3 ;") && result("T", 0, 0, 0) == VARS + 3, "CONST+N is the constant plus N"); CHECK(ok(": T VAR+0 VAR+10 + ;") && result("T", 0, 0, 0) == 2 * VARS + 10, "any N"); CHECK(nb.mem[ORIGIN + 1] == VARS && nb.mem[ORIGIN + 2] == VARS + 10, "and it is a single literal"); CHECK(ok(": VAR+1 77 ; : T VAR+1 ;") && result("T", 0, 0, 0) == 77, "a word of that very name comes first"); CHECK(refused(": T VAR+ ;", "never defined", 1) && refused(": T VAR+x ;", "never defined", 1) && refused(": T NOPE+1 ;", "never defined", 1), "what is not a constant and a number is just an unknown name"); /* &NAME: a word's address as a literal */ CHECK(ok(": A 5 ; : T &A ;") && result("T", 0, 0, 0) == v4_text_word(&tx, "A"), "&NAME is the word's address"); CHECK(ok(": A 5 ; : T &A push ;") && result("T", 0, 0, 0) == 5, "which can be executed"); CHECK(refused(": T &A ; : A 5 ;", "already defined", 1), "the word must be defined first"); CHECK(refused(": T &VAR ;", "already defined", 1), "and be a word"); CHECK(refused(": &X 1 ;", "cannot be used as a name", 1), "a name cannot begin with &"); /* headers: a dictionary entry in front of a word (capsule/dict.v4) */ CHECK(ok("header DUP : (DUP) dup + ;"), "a header assembles: %s", v4_text_error(&tx)); { v4_cell xt = v4_text_word(&tx, "(DUP)"); CHECK(xt == ORIGIN + 4 && v4_text_latest(&tx) == xt, "the code follows the name cell and three more: %ld", (long)xt); CHECK((v4_ucell)nb.mem[ORIGIN] == (3u | ('D' << 8) | ('U' << 16) | ((v4_ucell)'P' << 24)), "the name: its count, then its characters"); CHECK(nb.mem[xt - 3] == 0 && nb.mem[xt - 2] == ORIGIN && nb.mem[xt - 1] == 0, "flags 0, the name's address, link 0"); CHECK(result("(DUP)", 1, 7, 0) == 14, "and the word runs"); } CHECK(ok(": BEFORE 1 ; header A : A' 2 ; header LONGER-NAM immediate : B' 3 ; : MID 4 ; header + inline compile-only : PLUS + ;") && result("BEFORE", 0, 0, 0) == 1 && result("B'", 0, 0, 0) == 3 && result("MID", 0, 0, 0) == 4, "headers among other words"); { v4_cell a = v4_text_word(&tx, "A'"), b = v4_text_word(&tx, "B'"), c = v4_text_word(&tx, "PLUS"); CHECK(nb.mem[a - 1] == 0 && nb.mem[b - 1] == a && nb.mem[c - 1] == b && v4_text_latest(&tx) == c, "each links to the one before; the newest is the latest"); CHECK(nb.mem[a - 3] == 0 && nb.mem[b - 3] == 1 && nb.mem[c - 3] == 24, "the flags: none, immediate, inline and compile-only"); CHECK(b - a == 2 + 3 + 3 && nb.mem[b - 2] == b - 6, "a ten-character name takes three cells"); CHECK((v4_ucell)nb.mem[b - 4] == (('N') | ('A' << 8) | ('M' << 16)), "and is padded with zeros"); CHECK((v4_ucell)nb.mem[c - 4] == (1u | ('+' << 8)), "an opcode's name is taken as it stands"); } CHECK(ok("header ( immediate : PAREN ; header \\ immediate : BACKSLASH ; header : : COLON ; header ; : SEMI ; header header : H ;"), "names the assembler would otherwise read as its own: %s", v4_text_error(&tx)); CHECK((v4_ucell)nb.mem[v4_text_word(&tx, "PAREN") - 4] == (1u | ('(' << 8)) && (v4_ucell)nb.mem[v4_text_word(&tx, "BACKSLASH") - 4] == (1u | ('\\' << 8)) && (v4_ucell)nb.mem[v4_text_word(&tx, "COLON") - 4] == (1u | (':' << 8)) && (v4_ucell)nb.mem[v4_text_word(&tx, "SEMI") - 4] == (1u | (';' << 8)), "are names like any other"); CHECK(ok("header data-word data : D 1 ;") && nb.mem[v4_text_word(&tx, "D") - 3] == 4, "the data flag"); CHECK(ok("header 1234567890123456789012345678901 : W ;"), "a 31-character name fits"); CHECK(refused("header 12345678901234567890123456789012 : W ;", "at most 31 characters", 1), "a 32-character one is refused"); CHECK(refused("header X 5 : W ;", "header must be followed by :", 1), "something other than a flag or : after a header is refused"); CHECK(refused("header X header Y : W ;", "header must be followed by :", 1), "so is another header"); CHECK(refused("header X", "header must be followed by :", 0), "and the end of the text"); CHECK(refused("header", "header without a name", 0), "header with no name is refused"); CHECK(refused(": T immediate ;", "a flag with no header", 1), "a flag with no header is refused"); CHECK(refused("macro M header X endmacro", "", 0) || 1, "(header inside a macro body is only text until the macro is used)"); CHECK(refused("macro M header X : W ; endmacro", "not allowed in a macro", 1), "a word in a macro is still refused"); CHECK(refused(": immediate 1 ;", "cannot be used as a name", 1), "a flag's name cannot name a word"); CHECK(ok(": T 1 ;") && v4_text_latest(&tx) == 0, "with no header the latest is 0"); /* 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; }