/* test_host_quit.c -- the prompt, executed on the host node. * * capsule/quit.v4 on top of the earlier layers: QUIT, ABORT, ABORT" and ." . * For the first time the node is not handed a line: it is started at QUIT and * left running, characters are fed to its console, and what it prints is * read back. Nothing here calls INTERPRET or pokes TIB. * * A session is some lines of input and everything the node printed until it * was waiting for more. The sessions marked v3 were piped through the v3 * binary on 2026-10-04 and the text is what v3 printed, less its colours and * the time stamp and "ERROR: " its log puts before a message. * * Where v4 parts from v3 here: * - QUIT is FORTH-79's: it stops the line, from inside any word, and says * nothing. v3's goes on with the rest of the line, and cannot be * compiled into a definition at all. * - a line that fails while a definition is open ends the definition. * v3 goes on compiling the lines that follow into it. * - ABORT" at the prompt stops the line when its flag is true. v3 prints * the text and carries on. Compiled into a word, v3's crashes (SIGSEGV). * - every error has a message (D-18), but v4's says what was wrong, not * which word: "Control structure mismatch" where v3 says * "LOOP: missing DO". * - QUERY takes 80 characters (FORTH-79); v3's line is 255. * - an address outside memory says so (D-14); v3 gives ERROR alone. * - M/MOD by zero says so (D-15); v3 gives ERROR alone. * - the host node's stacks hold 32 values and 32 return entries (D-17), * and one more is an error (D-16). This file is written for whatever * size it is built with. A stack fault names the stack, * not the word: "Stack underflow" where v3 says "DROP: Stack underflow". * - any fault empties the data stack; v3 keeps what the failing word had * not taken. * - PICK and ROLL count from one, as FORTH-79 has them: 1 PICK is DUP and * 3 ROLL is ROT. v3's count from zero. */ #include "v4/text.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) #include "host_map.h" static v4_node n; static v4_exec_state es; static v4_heat h; static v4_text tx; static v4_cell w_quit, w_key, w_key_end, w_fault, capsule_latest; static char out[V4_CONSOLE_CAP + 1]; static long last_steps; /* Run until the node has taken all its input and has been inside KEY, waiting, * for 64 instruction words; or until `max` words. True if it is waiting. */ static int run_until_waiting(long max) { long steps = 0; unsigned idle = 0; while (steps < max && idle < 64) { (void)v4_exec_step_word(&n, &es, &h); steps++; if (n.input_pos == n.input_len && n.p >= w_key && n.p < w_key_end) idle++; else idle = 0; } last_steps = steps; return idle >= 64; } /* A node just switched on: an empty dictionary above the capsule's words, * `depth` marked cells and the canary on the data stack, started at QUIT. */ static void boot_with(unsigned depth) { unsigned i; for (v4_cell k = DICT_W; k < DICT_END_W; k++) n.mem[k] = 0; n.mem[DP] = DICT_W * 4; n.mem[LATEST] = capsule_latest; n.mem[STATE] = 0; n.mem[CFP] = CFS_W; n.mem[BASE] = 10; n.mem[NODE_ERROR] = 0; n.mem[FENCE] = DICT_W; v4_node_console_attach(&n, CONSOLE_TX); v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST); v4_node_fault_attach(&n, w_fault); v4_node_error_attach(&n, NODE_ERROR); v4_dstack_reset(&n.ds); v4_rstack_reset(&n.rs); v4_exec_reset(&es); v4_heat_reset(&h); for (i = 0; i < depth; i++) v4_dstack_push(&n.ds, (v4_cell)(0x5A000000 + i)); v4_dstack_push(&n.ds, CANARY); n.p = w_quit; (void)run_until_waiting(100000); } static void boot(void) { boot_with(0); } /* The same with nothing at all on the data stack. */ static void boot_bare(void) { boot(); v4_dstack_reset(&n.ds); } /* While the node waits for a character, EXPECT's own cells are on top of the * data stack. Pop them: true if the canary is under no more than four. */ static int canary_under_expect(void) { unsigned k; for (k = 0; k < 5; k++) if (v4_dstack_pop(&n.ds) == CANARY) return 1; return 0; } /* Feed `input` and return what the node prints until it waits again. */ static const char *say(const char *input) { unsigned len = (unsigned)strlen(input); v4_node_console_attach(&n, CONSOLE_TX); /* empties the capture */ if (v4_node_console_feed(&n, input, len) != len) return "(input queue full)"; if (!run_until_waiting(40000000)) return "(still running)"; if (n.console_dropped) return "(too much output)"; memcpy(out, n.console, n.console_len); out[n.console_len] = 0; return out; } static void show(const char *label, const char *s) { printf(" %s\"", label); for (; *s; s++) if (*s == '\n') printf("\\n"); else putchar(*s); printf("\"\n"); } static int is(const char *got, const char *want) { if (strcmp(got, want) == 0) return 1; show("got: ", got); show("wanted: ", want); return 0; } /* What v3 prints starts with its first prompt; the node's first prompt is * printed at switch-on, before the input, so a v4 session lacks the leading * "ok> " and is otherwise the same. */ typedef struct { const char *in, *want; int v3; } transcript; static const transcript script[] = { { "65 EMIT\n", "A ok\nok> ", 1 }, { "\n \n", " ok\nok> ok\nok> ", 1 }, { ": HI .\" Hello\" ; HI\n", "Hello ok\nok> ", 1 }, { "NOSUCH\n66 EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> B ok\nok> ", 1 }, { "1 2 NOSUCH 3 4\n+ 48 + EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> 3 ok\nok> ", 1 }, { ": T 67 EMIT ABORT 68 EMIT ; T 70 EMIT\n69 EMIT\n", "C ok\nok> E ok\nok> ", 1 }, { ": M 70 EMIT\n71 EMIT ;\nM\n", " ok\nok> ok\nok> FG ok\nok> ", 1 }, { "IF\n72 EMIT\n", "IF: compile-only\n ERROR\nok> H ok\nok> ", 1 }, { ".\" hi there\"\n", "hi there ok\nok> ", 1 }, { "1 2 3\n+ + 48 + EMIT\n", " ok\nok> 6 ok\nok> ", 1 }, { ": T .\" A\" .\" B\" CR .\" C\" ; T\n", "AB\nC ok\nok> ", 1 }, { ": T1 ABORT ; : T2 T1 66 EMIT ; : T3 65 EMIT T2 67 EMIT ; T3\n68 EMIT\n", "A ok\nok> D ok\nok> ", 1 }, { "0 ABORT\" not\" 65 EMIT\n", "A ok\nok> ", 1 }, { ": P .\" two spaces \" 124 EMIT ; P\n", " two spaces | ok\nok> ", 1 }, { "65 EMIT CR 66 EMIT\n", "A\nB ok\nok> ", 1 }, { ": E .\" \" 65 EMIT ; E\n", "A ok\nok> ", 1 }, { "65 EMIT 1 0 / 66 EMIT\n67 EMIT\n", "A/: Division by zero\n ERROR\nok> C ok\nok> ", 1 }, { "1 0 MOD\n", "MOD: Division by zero\n ERROR\nok> ", 1 }, { "1 0 /MOD\n", "/MOD: Division by zero\n ERROR\nok> ", 1 }, { "1 1 0 */\n", "*/: Division by zero\n ERROR\nok> ", 1 }, { "1 1 0 */MOD\n", "*/MOD: Division by zero\n ERROR\nok> ", 1 }, { ": T 1 0 / 65 EMIT ; T 66 EMIT\n67 EMIT\n", "/: Division by zero\n ERROR\nok> C ok\nok> ", 1 }, { "0 0 /\n7 2 / 48 + EMIT\n", "/: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 }, { "DEPTH 48 + EMIT 5 6 DEPTH 48 + EMIT\n", "02 ok\nok> ", 1 }, { "1 2 3 NOSUCH\nDEPTH 48 + EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> 3 ok\nok> ", 1 }, { "5 6 7 1 0 MOD\nDEPTH 48 + EMIT\n", "MOD: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 }, { "5 6 7 1 1 0 */MOD\nDEPTH 48 + EMIT\n", "*/MOD: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 }, { "1 2 3 ABORT\nDEPTH 48 + EMIT\n", " ok\nok> 0 ok\nok> ", 1 }, { "1 2 3 . . .\n", "3 2 1 ok\nok> ", 1 }, { "-5 . 0 . 2147483647 .\n", "-5 0 2147483647 ok\nok> ", 1 }, { "1 2 3 .S\n", "<3> 1 2 3 \n ok\nok> ", 1 }, { ".S\n", "<0> \n ok\nok> ", 1 }, { "1 2 3 .S . . .\n", "<3> 1 2 3 \n3 2 1 ok\nok> ", 1 }, { "7 5 U.R 124 EMIT\n", " 7| ok\nok> ", 0 }, { "HEX FF . DECIMAL 255 .\n", "FF 255 ok\nok> ", 1 }, { "255 HEX . DECIMAL\n", "FF ok\nok> ", 1 }, { "255 OCTAL . DECIMAL\n", "377 ok\nok> ", 1 }, { "VARIABLE X 42 X ! X ?\n", "42 ok\nok> ", 1 }, { "3 SPACES 65 EMIT 0 SPACES 66 EMIT -2 SPACES 67 EMIT\n", " ABC ok\nok> ", 1 }, { "2 BASE ! 5 . DECIMAL\n", "UNKNOWN WORD: '5'\n ERROR\nok> ", 1 }, { ": T 10 0 DO I . LOOP ; T\n", "0 1 2 3 4 5 6 7 8 9 ok\nok> ", 1 }, { "DEPTH . 1 2 DEPTH . . .\n", "0 2 2 1 ok\nok> ", 1 }, /* CASE, ['], S", FORGET */ { ": C1 CASE 1 OF 65 EMIT ENDOF 2 OF 66 EMIT ENDOF 67 EMIT ENDCASE ;\n1 C1 2 C1 3 C1\n.S\n", " ok\nok> ABC ok\nok> <0> \n ok\nok> ", 1 }, { ": C2 CASE 1 OF 10 ENDOF 2 OF 20 ENDOF DUP 100 + SWAP ENDCASE ;\n1 C2 . 2 C2 . 7 C2 .\n.S\n", " ok\nok> 10 20 107 ok\nok> <0> \n ok\nok> ", 1 }, { ": C3 CASE ENDCASE ; 5 C3 .S\n", "<0> \n ok\nok> ", 1 }, { ": T1 11 ; : T2 ['] T1 EXECUTE ; T2 .\n", "11 ok\nok> ", 1 }, { ": S1 S\" hello\" TYPE ; S1\n", "hello ok\nok> ", 1 }, { ": S2 S\" abc\" ; S2 . DROP .S\n", "3 <0> \n ok\nok> ", 1 }, { "S\" xyz\" TYPE\n", "xyz ok\nok> ", 1 }, { ": A1 1 ; : A2 2 ; : A3 3 ; FORGET A2 A1 .\nA3\nA2\n", "1 ok\nok> UNKNOWN WORD: 'A3'\n ERROR\nok> UNKNOWN WORD: 'A2'\n ERROR\nok> ", 1 }, { ": L1 [ 5 ] [LITERAL] ; L1 .\n", "5 ok\nok> ", 1 }, { "CASE\n", "CASE: compile-only\n ERROR\nok> ", 1 }, /* v4's own */ { ": C4 CASE 1 OF 65 EMIT ENDCASE ;\n: C5 1 OF ;\n: C6 CASE ENDOF ;\n: C7 ENDCASE ;\n", "Control structure mismatch\n ERROR\nok> Control structure mismatch\n ERROR\nok> Control structure mismatch\n ERROR\nok> " "Control structure mismatch\n ERROR\nok> ", 0 }, { "7 FORGET DUP 65 EMIT\nFORGET NOSUCH\nDUP . .\n", "Protected word\n ERROR\nok> UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> 7 7 ok\nok> ", 0 }, { ": S3 S\" \" SWAP DROP . S\" ab\" S\" cde\" TYPE TYPE ; S3\n", "0 cdeab ok\nok> ", 0 }, { ": T3 ['] NOSUCH ;\n['] DUP\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> [']: compile-only\n ERROR\nok> ", 0 }, /* words.v4 */ { "1 2 3 4 2SWAP . . . .\n", "2 1 4 3 ok\nok> ", 1 }, { "1 2 3 4 2OVER . . . . . .\n", "2 1 4 3 2 1 ok\nok> ", 1 }, { "1 2 3 4 5 6 2ROT . . . . . .\n", "2 1 6 5 4 3 ok\nok> ", 1 }, { ": T 1 2 2>R 2R@ 2R> . . . . ; T\n", "2 1 2 1 ok\nok> ", 1 }, { "TRUE . FALSE . 5 INVERT . NOP\n", "-1 0 -6 ok\nok> ", 1 }, { "VARIABLE X 0 , 11 22 X 2! X 2@ . . X @ .\n", "22 11 11 ok\nok> ", 1 }, { "VARIABLE Y 10 Y ! 3 Y -! Y @ .\n", "7 ok\nok> ", 1 }, { "0 0<> . 5 0<> . -5 0<> .\n", "0 -1 -1 ok\nok> ", 1 }, { "0 0> . 5 0> . -5 0> .\n", "0 -1 0 ok\nok> ", 1 }, { "1 2 <> . 2 2 <> .\n", "-1 0 ok\nok> ", 1 }, { "1 2 <= . 2 2 <= . 3 2 <= .\n", "-1 -1 0 ok\nok> ", 1 }, { "1 2 >= . 2 2 >= . 3 2 >= .\n", "0 -1 -1 ok\nok> ", 1 }, { "1 2 U< . 2 1 U< . -1 1 U< . 1 -1 U< . 3 3 U< .\n", "-1 0 0 -1 0 ok\nok> ", 1 }, { "1 2 U> . -1 1 U> . 1 -1 U> .\n", "0 -1 0 ok\nok> ", 1 }, { "-5 ABS . 5 ABS . 0 ABS .\n", "5 5 0 ok\nok> ", 1 }, { "3 9 MAX . -3 -9 MAX . 3 9 MIN . -3 -9 MIN .\n", "9 -3 3 -9 ok\nok> ", 1 }, { "5 0 9 WITHIN . 9 0 9 WITHIN . 0 0 9 WITHIN . 5 9 0 WITHIN . -1 0 9 WITHIN .\n", "-1 0 -1 0 0 ok\nok> ", 1 }, { "1 4 LSHIFT . 3 0 LSHIFT . 256 4 RSHIFT . 1 1 RSHIFT .\n", "16 3 16 0 ok\nok> ", 1 }, { "5 0 3 0 D- . . 3 0 5 0 D- . .\n", "0 2 -1 -2 ok\nok> ", 1 }, { "-5 -1 DABS . . 5 0 DABS . .\n", "0 5 0 5 ok\nok> ", 1 }, { "0 0 D0= . 1 0 D0= . 0 1 D0= .\n", "-1 0 0 ok\nok> ", 1 }, { "-1 -1 D0< . 5 0 D0< .\n", "-1 0 ok\nok> ", 1 }, { "5 0 5 0 D= . 5 0 6 0 D= . 5 0 5 1 D= .\n", "-1 0 0 ok\nok> ", 1 }, { "3 0 D2* . . -1 0 D2* . .\n", "0 6 1 -2 ok\nok> ", 1 }, { "6 0 D2/ . . -6 -1 D2/ . .\n", "0 3 -1 -3 ok\nok> ", 1 }, { "1 0 2 0 D< . 2 0 1 0 D< . -1 -1 0 0 D< . 5 0 5 0 D< .\n", "-1 0 -1 0 ok\nok> ", 1 }, { "1 0 2 0 DMAX . . 1 0 2 0 DMIN . . -1 -1 3 0 DMAX . . -1 -1 3 0 DMIN . .\n", "0 2 0 1 0 3 -1 -1 ok\nok> ", 1 }, { "PAD 8 65 FILL PAD 4 + C@ . PAD 7 + C@ .\n", "65 65 ok\nok> ", 1 }, { "PAD 8 65 FILL PAD 4 ERASE PAD C@ . PAD 4 + C@ .\n", "0 65 ok\nok> ", 1 }, { "PAD 8 65 FILL PAD 2 + 3 BLANK PAD 8 TYPE 124 EMIT\n", "AA AAA| ok\nok> ", 1 }, { "PAD 16 32 FILL 97 PAD C! 98 PAD 1+ C! 99 PAD 2+ C!\nPAD 16 -TRAILING . PAD - .\n", " ok\nok> 3 0 ok\nok> ", 1 }, { "PAD 16 32 FILL 97 PAD C! 98 PAD 1+ C! 99 PAD 2+ C!\nPAD 3 PAD 3 COMPARE . PAD 3 PAD 2 COMPARE . PAD 2 PAD 3 COMPARE .\nPAD 3 PAD 1+ 2 COMPARE .\n", " ok\nok> 0 1 -1 ok\nok> -1 ok\nok> ", 1 }, { "PAD 16 32 FILL 97 PAD C! 98 PAD 1+ C! 99 PAD 2+ C!\nPAD 16 98 SCAN . PAD - . PAD 16 97 SKIP . PAD - . PAD 16 122 SCAN . PAD - .\n", " ok\nok> 15 1 15 1 0 16 ok\nok> ", 1 }, { "PAD 16 32 FILL 97 PAD C! 98 PAD 1+ C! 99 PAD 2+ C!\nPAD 16 PAD 1+ 2 SEARCH . . PAD - .\n122 PAD 20 + C! PAD 16 PAD 20 + 1 SEARCH . . PAD - .\n", " ok\nok> -1 15 1 ok\nok> 0 16 0 ok\nok> ", 1 }, { "PAD 16 32 FILL 97 PAD C! 98 PAD 1+ C! 99 PAD 2+ C!\nPAD PAD 1+ 3 CMOVE> PAD 4 TYPE 124 EMIT\n", " ok\nok> aabc| ok\nok> ", 1 }, { "PAD 0 65 FILL PAD 0 -TRAILING . DROP PAD 0 PAD 0 COMPARE .\n", "0 0 ok\nok> ", 1 }, /* v4's own: FORTH-79's MOVE and the standard order for M- (v3's differ), and the errors */ { "VARIABLE A 1 , 2 , VARIABLE B 0 , 0 , 5 A ! A B 3 MOVE B @ . B 1+ @ . B 2+ @ .\n", "5 1 2 ok\nok> ", 0 }, { "VARIABLE A 7 A ! A A 0 MOVE A A -3 MOVE A @ .\n", "7 ok\nok> ", 0 }, { "5 0 3 M- . . 5 0 -7 M- . . 0 0 1 M- . .\n", "0 2 0 12 -1 -1 ok\nok> ", 0 }, { "5 0 3 M+ . . 5 0 -7 M+ . .\n", "0 8 -1 -2 ok\nok> ", 0 }, { "0 -1 D0< . -1 0 D0< .\n", "-1 0 ok\nok> ", 0 }, { "?TERMINAL . 65 EMIT\n?TERMINAL .\n", "-1 A ok\nok> 0 ok\nok> ", 0 }, { "7 1 -1 LSHIFT 65 EMIT\n.S\n", "Shift count out of range\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "7 1 -1 RSHIFT 65 EMIT\n.S\n", "Shift count out of range\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "7 PAD -1 65 FILL 66 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "7 PAD PAD -1 CMOVE> 66 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "PAD 4 65 FILL PAD -5 -TRAILING . DROP PAD -1 PAD -1 COMPARE .\nPAD -3 65 SCAN . DROP\n", "0 0 ok\nok> 0 ok\nok> ", 0 }, /* v4's own */ { "5 3 .R 124 EMIT -5 6 .R 124 EMIT 12345 2 .R 124 EMIT\n", " 5| -5|12345| ok\nok> ", 0 }, { "1234 0 <# # # #S #> TYPE\n", "1234 ok\nok> ", 0 }, { "-7 DUP 0< IF NEGATE THEN 0 <# #S ROT SIGN #> TYPE\n", "IF: compile-only\n ERROR\nok> ", 0 }, { ": SN DUP DUP 0< IF NEGATE THEN 0 <# #S ROT SIGN #> TYPE ; -7 SN 7 SN\n", "-77 ok\nok> ", 0 }, { "65 0 <# 42 HOLD #S 36 HOLD #> TYPE\n", "$65* ok\nok> ", 0 }, { "2 BASE ! 101 1010 + . DECIMAL\n", "1111 ok\nok> ", 0 }, { "5 0 D. -1 -1 D. 7 0 4 D.R 124 EMIT\n", "5 -1 7| ok\nok> ", 0 }, { "36 BASE ! ZZ DECIMAL . 1295 36 BASE ! . DECIMAL\n", "1295 ZZ ok\nok> ", 0 }, { ": S5 1 2 3 4 5 .S 2DROP 2DROP DROP .S ; S5\n", "<5> 1 2 3 4 5 \n<0> \n ok\nok> ", 0 }, { "-1 -2 -3 .S\n", "<3> -1 -2 -3 \n ok\nok> ", 0 }, { "1 2 3 QUIT\nDEPTH 48 + EMIT\n", "\nok> 3 ok\nok> ", 0 }, { "65 EMIT DROP 66 EMIT\n67 EMIT\n", "AStack underflow\n ERROR\nok> C ok\nok> ", 0 }, { "+\n1 +\nDUP\nOVER\n1 OVER\n", "Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> " "Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> ", 0 }, { ": OV 65 EMIT 1000 0 DO I LOOP 66 EMIT ; 7 8 9 OV\nDEPTH 48 + EMIT\n", "AStack overflow\n ERROR\nok> 0 ok\nok> ", 0 }, { "1 2 3 -1 @\nDEPTH 48 + EMIT\n", "Address out of range\n ERROR\nok> 0 ok\nok> ", 0 }, { ": RU R> DROP R> DROP ; 65 EMIT RU 66 EMIT\n67 EMIT\n", "AReturn stack underflow\n ERROR\nok> C ok\nok> ", 0 }, /* a word that runs itself, through EXECUTE, until the return stack is full */ { "VARIABLE V : RR V @ EXECUTE ; ' RR V ! 65 EMIT RR 66 EMIT\n67 EMIT\n", "AReturn stack overflow\n ERROR\nok> C ok\nok> ", 0 }, { ": DEEP 65 EMIT BEGIN 1 >R AGAIN ; DEEP\n", "AReturn stack overflow\n ERROR\nok> ", 0 }, { "65 66 67 1 PICK EMIT EMIT EMIT EMIT\n", "CCBA ok\nok> ", 0 }, { "65 66 67 2 PICK EMIT EMIT EMIT EMIT\n", "BCBA ok\nok> ", 0 }, { "65 66 67 3 PICK EMIT EMIT EMIT EMIT\n", "ACBA ok\nok> ", 0 }, { "65 66 67 1 ROLL EMIT EMIT EMIT\n", "CBA ok\nok> ", 0 }, { "65 66 67 2 ROLL EMIT EMIT EMIT\n", "BCA ok\nok> ", 0 }, { "65 66 67 3 ROLL EMIT EMIT EMIT\nDEPTH 48 + EMIT\n", "ACB ok\nok> 0 ok\nok> ", 0 }, { "65 66 0 PICK\nDEPTH 48 + EMIT\n", "PICK: Invalid index\n ERROR\nok> 2 ok\nok> ", 0 }, { "65 66 -3 ROLL\n65 66 0 ROLL\n", "ROLL: Invalid index\n ERROR\nok> ROLL: Invalid index\n ERROR\nok> ", 0 }, { "65 66 3 PICK\nDEPTH 48 + EMIT\n", "Stack underflow\n ERROR\nok> 0 ok\nok> ", 0 }, { "65 66 5 ROLL\n1 PICK\n", "Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> ", 0 }, { "65 66 67 68 69 5 ROLL EMIT EMIT EMIT EMIT EMIT\n", "AEDCB ok\nok> ", 0 }, { "65 66 67 68 69 4 ROLL EMIT EMIT EMIT EMIT EMIT\n", "BEDCA ok\nok> ", 0 }, { ": P5 65 66 67 68 69 5 PICK EMIT 3 PICK EMIT EMIT EMIT EMIT EMIT EMIT ; P5\n", "ACEDCBA ok\nok> ", 0 }, { ": T1 QUIT ; : T2 1 2 3 4 T1 ; T2\nDEPTH 48 + EMIT\n", "\nok> 4 ok\nok> ", 0 }, { ": T3 1 2 3 4 5 6 7 8 9 ABORT ; T3\nDEPTH 48 + EMIT\n", " ok\nok> 0 ok\nok> ", 0 }, { "1 0 0 M/MOD\n", "M/MOD: Division by zero\n ERROR\nok> ", 0 }, { ": Z0 0 / ; : Z1 65 EMIT 9 Z0 66 EMIT ; Z1\n: Z2 1 IF [ 5 0 MOD ]\nZ2\n", "A/: Division by zero\n ERROR\nok> MOD: Division by zero\n ERROR\nok> UNKNOWN WORD: 'Z2'\n ERROR\nok> ", 0 }, { ": Z3 5 0 DO 9 3 I - / DROP LOOP 65 EMIT ; Z3\n66 EMIT\n", "/: Division by zero\n ERROR\nok> B ok\nok> ", 0 }, { ": BAD 1 NOSUCH 2 ;\nBAD\n65 EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> UNKNOWN WORD: 'BAD'\n ERROR\nok> A ok\nok> ", 0 }, { "1 ABORT\" now\" 65 EMIT\n66 EMIT\n", "now\n ok\nok> B ok\nok> ", 0 }, { ": B1 IF LOOP ;\n65 EMIT\n", "Control structure mismatch\n ERROR\nok> A ok\nok> ", 0 }, { ": A2 0 ABORT\" boom\" 67 EMIT ; A2\n", "C ok\nok> ", 0 }, { ": A1 ABORT\" boom\" 65 EMIT ; 1 A1 66 EMIT\n0 A1\n", "boom\n ok\nok> A ok\nok> ", 0 }, { "1 2 3 QUIT 68 EMIT\n+ + 48 + EMIT\n", "\nok> 6 ok\nok> ", 0 }, { ": Q1 QUIT ; : Q2 65 EMIT Q1 66 EMIT ; : Q3 Q2 67 EMIT ; Q3 68 EMIT\n69 EMIT\n", "A\nok> E ok\nok> ", 0 }, { ": HALF 1 2 [ QUIT\n65 EMIT\nHALF\n", "\nok> A ok\nok> UNKNOWN WORD: 'HALF'\n ERROR\nok> ", 0 }, { ": HALF 1 2 [ ABORT\n65 EMIT\n", " ok\nok> A ok\nok> ", 0 }, /* every error stops the line at once, says what it was, and leaves the data stack (D-18) */ { "1 2 3 PAD PAD -1 CMOVE 65 EMIT\n66 EMIT .S\n", "Negative count\n ERROR\nok> B<3> 1 2 3 \n ok\nok> ", 0 }, { "7 PAD -5 TYPE 65 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, /* NUMBER takes a counted string: "-12" and "-1x", built at PAD */ { "3 PAD C! 45 PAD 1+ C! 49 PAD 2+ C! 50 PAD 3 + C! 0 PAD 4 + C! PAD NUMBER D.\n", "-12 ok\nok> ", 0 }, { "3 PAD C! 45 PAD 1+ C! 49 PAD 2+ C! 120 PAD 3 + C! 7 PAD NUMBER 65 EMIT\n.S\n", "Not a number\n ERROR\nok> <3> 7 0 0 \n ok\nok> ", 0 }, { "7 <# 300 HOLD 65 EMIT\n.S\n", "Not a character\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { ": HH <# 70 0 DO 65 HOLD LOOP ; HH 66 EMIT\n67 EMIT\n", "Number too long\n ERROR\nok> C ok\nok> ", 0 }, { "7 : \n.S\n", "Name missing\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { "VARIABLE\nCREATE\n5 CONSTANT\n", "Name missing\n ERROR\nok> Name missing\n ERROR\nok> Name missing\n ERROR\nok> ", 0 }, { "7 ' NOSUCH 65 EMIT\n.S\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> <1> 7 \n ok\nok> ", 0 }, { ": X1 COMPILE NOSUCH ;\n: X2 [COMPILE] NOPE ;\n65 EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> UNKNOWN WORD: 'NOPE'\n ERROR\nok> A ok\nok> ", 0 }, { ": X3 THEN ;\n: X4 BEGIN IF UNTIL ;\n: X5 DO REPEAT ;\n", "Control structure mismatch\n ERROR\nok> Control structure mismatch\n ERROR\nok> " "Control structure mismatch\n ERROR\nok> ", 0 }, { ": X6 IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF 65 EMIT ;\n66 EMIT\n", "Control structures too deep\n ERROR\nok> B ok\nok> ", 0 }, { ".\" no closing quote\n65 EMIT\n", "no closing quote ok\nok> A ok\nok> ", 0 }, { ".\" \"\n", " ok\nok> ", 0 }, { ": T ABORT\" \" ; 1 T\n", "\n ok\nok> ", 0 }, { "5 >R\n;\n", ">R: compile-only\n ERROR\nok> ;: compile-only\n ERROR\nok> ", 0 }, { "16 BASE ! FF 2/ 2/ EMIT\n", "? ok\nok> ", 0 }, }; #define NSCRIPT (sizeof script / sizeof script[0]) int main(void) { unsigned i; printf("v4 host prompt tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS); { static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4" }; CHECK(host_load(&tx, &n, files, 10), "the capsule assembles"); } CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx)); CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space"); printf(" capsule: %ld words\n", (long)v4_text_here(&tx) - 16); if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; } w_quit = v4_text_word(&tx, "QUIT"); w_key = v4_text_word(&tx, "KEY"); w_key_end = v4_text_word(&tx, "CR"); /* the word after KEY in core.v4 */ w_fault = v4_text_word(&tx, "(FAULTS)"); capsule_latest = v4_text_latest(&tx); CHECK(w_key_end > w_key && w_key_end - w_key <= 12, "KEY is the few words before CR"); /* ---- switch-on ---- */ boot(); CHECK(n.console_len == 5 && memcmp(n.console, "\nok> ", 5) == 0, "QUIT starts a new line and prompts"); CHECK(n.input_pos == n.input_len, "then waits for a line"); CHECK(run_until_waiting(5000) && last_steps == 64 && n.console_len == 5, "and goes on waiting, printing nothing"); CHECK(canary_under_expect(), "with the data stack as it found it"); /* ---- the sessions ---- */ for (i = 0; i < NSCRIPT; i++) { const transcript *t = &script[i]; boot_bare(); CHECK(is(say(t->in), t->want), "%ssession %u", t->v3 ? "v3: " : "", i); CHECK(n.mem[STATE] == 0, "session %u ends interpreting", i); } /* ---- one line at a time: the node keeps its state between them ---- */ boot(); CHECK(is(say("VARIABLE V 7 V !\n"), " ok\nok> "), "a variable is set on one line"); CHECK(is(say(": SHOW V @ 48 + EMIT ;\n"), " ok\nok> "), "a word defined on the next"); CHECK(is(say("SHOW 1 V +! SHOW\n"), "78 ok\nok> "), "and both used on a third"); CHECK(is(say("1 2 3 4 5 6\n"), " ok\nok> ") && is(say("+ + + + + 48 + EMIT\n"), "E ok\nok> "), "six values wait on the stack between lines"); CHECK(is(say("SHOW"), ""), "nothing happens until the line is ended"); CHECK(is(say(" SHOW\n"), "88 ok\nok> "), "and then all of it is read"); CHECK(canary_under_expect(), "the data stack is as it was at switch-on"); /* ---- a definition over several lines, and an error in the middle of one ---- */ boot(); CHECK(is(say(": LONG\n"), " ok\nok> ") && n.mem[STATE] != 0, "a line that leaves a definition open still says ok"); CHECK(is(say("65 EMIT\n"), " ok\nok> ") && is(say("66 EMIT ;\n"), " ok\nok> ") && n.mem[STATE] == 0, "it is finished two lines later"); CHECK(is(say("LONG\n"), "AB ok\nok> "), "and runs"); CHECK(is(say(": BROKEN 1 IF\n"), " ok\nok> ") && n.mem[STATE] != 0 && n.mem[CFP] != CFS_W, "a definition with an IF open"); CHECK(is(say("NOSUCH\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "an error ends it and empties the control-flow stack"); CHECK(is(say("BROKEN\n"), "UNKNOWN WORD: 'BROKEN'\n ERROR\nok> "), "and it was never defined"); CHECK(is(say("LONG\n"), "AB ok\nok> "), "what was defined before is still there"); /* ---- QUIT, ABORT and a failed line each end a definition that is open ---- */ boot(); CHECK(is(say(": IQ QUIT ; IMMEDIATE : IA ABORT ; IMMEDIATE\n"), " ok\nok> "), "QUIT and ABORT as immediate words"); CHECK(is(say(": H1 1 IF IQ\n"), "\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "QUIT while compiling stops compiling"); CHECK(is(say("65 EMIT\n"), "A ok\nok> ") && is(say("H1\n"), "UNKNOWN WORD: 'H1'\n ERROR\nok> "), "and the definition is gone"); CHECK(is(say(": H2 1 IF IA\n"), " ok\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "ABORT while compiling stops compiling"); CHECK(is(say("66 EMIT\n"), "B ok\nok> ") && is(say("H2\n"), "UNKNOWN WORD: 'H2'\n ERROR\nok> "), "and the definition is gone"); CHECK(is(say(": H3 1 IF [ PAD PAD -1 CMOVE ]\n"), "Negative count\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "a word that raises an error while a definition is open ends it"); CHECK(is(say("67 EMIT\n"), "C ok\nok> ") && is(say("H3\n"), "UNKNOWN WORD: 'H3'\n ERROR\nok> "), "and the definition is gone"); CHECK(is(say(": H4 68 EMIT ; H4\n"), "D ok\nok> "), "the next definition compiles and runs"); /* ---- an address outside memory (D-14): a message, ERROR, and the prompt ---- */ { static const char *const lines[] = { "65 EMIT -1 @ 66 EMIT\n", "65 EMIT 5 -1 ! 66 EMIT\n", "65 EMIT 16384 @ 66 EMIT\n", "65 EMIT 5 16384 ! 66 EMIT\n", "65 EMIT 99999999 C@ 66 EMIT\n", "65 EMIT 7 -4 C! 66 EMIT\n", "65 EMIT -1 EXECUTE 66 EMIT\n", "65 EMIT 1 -1 +! 66 EMIT\n", "65 EMIT PAD -8 4 CMOVE 66 EMIT\n", "65 EMIT -9 COUNT 66 EMIT\n", "65 EMIT -9 3 TYPE 66 EMIT\n", ": F0 -1 @ ; : F1 F0 ; : F2 F1 ; : F3 65 EMIT F2 66 EMIT ; F3 67 EMIT\n", ": G0 9 0 DO I 3 = IF 0 -1 ! THEN LOOP ; : G1 65 EMIT G0 66 EMIT ; G1\n", }; boot(); for (i = 0; i < sizeof lines / sizeof lines[0]; i++) { unsigned before = n.faults; CHECK(is(say(lines[i]), "AAddress out of range\n ERROR\nok> "), "fault %u", i); CHECK(n.faults == before + 1 && !n.stopped && n.mem[STATE] == 0, "fault %u: one fault, and the node is at its prompt", i); CHECK(is(say("1 2 + 48 + EMIT\n"), "3 ok\nok> "), "and the next line runs, after fault %u", i); } CHECK(is(say("16383 @ DROP 0 @ DROP 67 EMIT\n"), "C ok\nok> "), "the first and last words of memory are not faults"); CHECK(is(say(": H5 1 IF [ -1 @ ]\n"), "Address out of range\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "a fault while a definition is open ends it"); CHECK(is(say("H5\n"), "UNKNOWN WORD: 'H5'\n ERROR\nok> ") && is(say(": H6 68 EMIT ; H6\n"), "D ok\nok> "), "and the next definition compiles and runs"); CHECK(v4_node_guards_intact(&n), "guards intact after the faults"); } /* ---- the text is in the definition, a counted string after the call ---- */ boot(); for (v4_cell k = n.mem[DP] / 4; k < DICT_END_W; k++) n.mem[k] = (v4_cell)-1; /* memory that was not zero */ CHECK(is(say(": T .\" ABCDE\" ;\n"), " ok\nok> "), "a word that prints five characters"); { v4_cell xt = n.mem[LATEST]; CHECK((uint32_t)n.mem[xt + 1] == (5u | ('A' << 8) | ('B' << 16) | ((uint32_t)'C' << 24)) && (uint32_t)n.mem[xt + 2] == ('D' | ('E' << 8)), "the count and the characters follow the call, four to a cell, zeros after"); CHECK((n.mem[DP] + 3) / 4 == xt + 4, "then the rest of the word: four cells in all"); } /* every length from 0 to 12: the word goes on at the right cell */ for (i = 0; i <= 12; i++) { char line[96], want[32]; boot(); snprintf(line, sizeof line, ": T 60 EMIT .\" %.*s\" 62 EMIT ; T\n", (int)i, "abcdefghijkl"); snprintf(want, sizeof want, "<%.*s> ok\nok> ", (int)i, "abcdefghijkl"); CHECK(is(say(line), want), ".\" with %u characters", i); snprintf(line, sizeof line, ": U 60 EMIT ABORT\" %.*s\" 62 EMIT ; 0 U 1 U 33 EMIT\n", (int)i, "abcdefghijkl"); snprintf(want, sizeof want, "<><%.*s\n ok\nok> ", (int)i, "abcdefghijkl"); CHECK(is(say(line), want), "ABORT\" with %u characters, false then true", i); } /* the longest: 76 characters fit an 80-character line after ." and a space. * EXPECT stops at the 80th character, so that line's new-line is still to * come and is read as an empty line (FORTH-79's EXPECT; see input.v4). */ { char line[128], want[128], text[80]; for (i = 0; i < 76; i++) text[i] = (char)('#' + i); /* no " in it */ text[76] = 0; boot(); snprintf(line, sizeof line, ".\" %s\"\n", text); snprintf(want, sizeof want, "%s ok\nok> ok\nok> ", text); CHECK(is(say(line), want), "a string that fills an 80-character line"); boot(); snprintf(line, sizeof line, ".\" %s\"\n", text + 1); snprintf(want, sizeof want, "%s ok\nok> ", text + 1); CHECK(is(say(line), want), "and one that fills a 79-character line"); } /* ---- QUERY takes 80 characters; what is over is the next line ---- */ boot(); { char line[128]; memset(line, ' ', 100); memcpy(line, "65 EMIT", 7); memcpy(line + 70, "66 EMIT", 7); memcpy(line + 80, "67 EMIT 68 EMIT", 15); line[100] = '\n'; line[101] = 0; CHECK(is(say(line), "AB ok\nok> CD ok\nok> "), "a line of 100 characters is read as 80 and 20"); } /* ---- ABORT and QUIT from deep in a programme, again and again ---- */ boot(); CHECK(is(say(": A0 ABORT ; : A1 A0 ; : A2 A1 ; : A3 A2 ; : A4 A3 ; : A5 A4 ;\n"), " ok\nok> "), "ABORT six calls down"); CHECK(is(say(": Q0 QUIT ; : Q1 Q0 ; : Q2 Q1 ; : Q3 Q2 ; : Q4 Q3 ; : Q5 Q4 ;\n"), " ok\nok> "), "QUIT six calls down"); CHECK(is(say(": L0 10 0 DO I 5 = IF ABORT THEN LOOP ; : L1 3 0 DO L0 LOOP ;\n"), " ok\nok> "), "ABORT inside two loops"); for (i = 0; i < 40; i++) { CHECK(is(say("65 EMIT A5 66 EMIT\n"), "A ok\nok> "), "ABORT from six deep, time %u", i); CHECK(is(say("67 EMIT Q5 68 EMIT\n"), "C\nok> "), "QUIT from six deep, time %u", i); CHECK(is(say("L1 69 EMIT\n"), " ok\nok> "), "ABORT out of two loops, time %u", i); CHECK(is(say(": SQ DUP * ; 7 SQ EMIT\n"), "1 ok\nok> "), "and the next line compiles and runs, time %u", i); } CHECK(is(say("DEPTH 48 + EMIT\n"), "0 ok\nok> "), "ABORT has emptied the data stack"); /* ---- how deep words may call each other from the prompt ---- * The prompt's call of INTERPRET is one return entry, so a chain of words * one shorter than the return stack runs, and the next is a fault. */ { unsigned deepest = 0; char line[64], want[16]; boot(); CHECK(is(say(": N0 1+ ;\n"), " ok\nok> "), "a word that calls nothing"); for (i = 1; i <= V4_RET_DEPTH; i++) { snprintf(line, sizeof line, ": N%u N%u 1+ ;\n", i, i - 1u); CHECK(is(say(line), " ok\nok> "), "and one that calls it, %u deep", i + 1u); } for (i = 0; i <= V4_RET_DEPTH; i++) { snprintf(line, sizeof line, "33 N%u EMIT 33 EMIT\n", i); snprintf(want, sizeof want, "%c! ok\nok> ", (char)(34 + i)); if (strcmp(say(line), want) != 0) break; deepest = i + 1; } printf(" from the prompt, words may call each other %u deep\n", deepest); CHECK(deepest == V4_RET_DEPTH - 1u, "a word run from the prompt has all the return stack but the prompt's one entry"); CHECK(is(out, "Return stack overflow\n ERROR\nok> "), "and one more is reported"); } /* ---- the exits, taken with the return stack full ---- * RR runs itself through EXECUTE; each level holds one return entry, and * EXECUTE one more while it starts the next. With C at its largest and * one >R besides, there is room for exactly the action's own call. An * exit that did not empty the return stack before it printed would * overflow it. */ { static const struct { const char *action, *want; } e[] = { { "1 ABORT\" x\"", "x\n ok\nok> " }, { "5 0 PICK", "PICK: Invalid index\n ERROR\nok> " }, { "5 0 ROLL", "ROLL: Invalid index\n ERROR\nok> " }, { "5 0 /", "/: Division by zero\n ERROR\nok> " }, { "5 5 0 */MOD", "*/MOD: Division by zero\n ERROR\nok> " }, { "ABORT", " ok\nok> " }, { "QUIT", "\nok> " }, }; char line[96]; for (i = 0; i < sizeof e / sizeof e[0]; i++) { boot_bare(); CHECK(is(say("VARIABLE V VARIABLE C\n"), " ok\nok> "), "two variables"); snprintf(line, sizeof line, ": RR C @ 1- DUP C ! IF V @ EXECUTE EXIT THEN 1 >R %s ;\n", e[i].action); CHECK(is(say(line), " ok\nok> "), "a word that runs itself C times and then: %s", e[i].action); snprintf(line, sizeof line, "' RR V ! %u C ! RR\n", (unsigned)(V4_RET_DEPTH - 3u)); CHECK(is(say(line), e[i].want), "%s with the return stack full", e[i].action); CHECK(n.faults == 0, "%s: and it was not a fault", e[i].action); CHECK(is(say("65 EMIT\n"), "A ok\nok> "), "and the next line runs"); /* one level more and the action's own call does not fit */ snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)(V4_RET_DEPTH - 2u)); CHECK(is(say(line), "Return stack overflow\n ERROR\nok> "), "%s one level deeper is a return stack overflow", e[i].action); } } /* ---- the data stack, full ---- * P1 P2 P4 P8 P16 push that many values and call nothing while they do, so * a word can fill the stack to any depth in a short line. */ { char line[128], want[32], fill[64]; unsigned c, bit; #define FILL(count) do { size_t at_ = 0; fill[0] = 0; \ for (c = (count), bit = 16; bit; bit >>= 1) if (c >= bit) { at_ += (size_t)snprintf(fill + at_, sizeof fill - at_, "P%u ", bit); c -= bit; } \ for (; c >= 16; c -= 16) at_ += (size_t)snprintf(fill + at_, sizeof fill - at_, "P16 "); } while (0) boot_bare(); CHECK(is(say(": P1 7 ; : P2 7 7 ; : P4 7 7 7 7 ; : P8 7 7 7 7 7 7 7 7 ;\n"), " ok\nok> ") && is(say(": P16 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 ;\n"), " ok\nok> "), "words that push 1, 2, 4, 8 and 16 values"); /* 65, then DEPTH-2 more, then n = DEPTH-1: the stack is full when PICK and ROLL start */ FILL(V4_DATA_DEPTH - 2u); snprintf(line, sizeof line, ": PF 65 %s%u PICK >R DROP R> EMIT ABORT ; PF\n", fill, (unsigned)(V4_DATA_DEPTH - 1u)); CHECK(is(say(line), "A ok\nok> ") && n.faults == 0, "PICK of the deepest value of a full stack"); snprintf(line, sizeof line, ": RF 65 %s%u ROLL EMIT DROP DEPTH 33 + EMIT ABORT ; RF\n", fill, (unsigned)(V4_DATA_DEPTH - 1u)); snprintf(want, sizeof want, "A%c ok\nok> ", (char)(33 + V4_DATA_DEPTH - 3u)); CHECK(is(say(line), want) && n.faults == 0, "ROLL of the deepest value of a full stack"); /* exactly full is not a fault; one more is */ FILL(V4_DATA_DEPTH); snprintf(line, sizeof line, ": F1 %s2DROP ABORT ; F1\n", fill); CHECK(is(say(line), " ok\nok> ") && n.faults == 0, "a stack exactly full is not a fault"); snprintf(line, sizeof line, ": F2 %s7 ; F2\n", fill); CHECK(is(say(line), "Stack overflow\n ERROR\nok> ") && n.fault_kind == V4_FAULT_DATA_OVER, "one value more is"); CHECK(is(say("DEPTH 48 + EMIT\n"), "0 ok\nok> "), "and the stack is empty afterwards"); #undef FILL } /* and with text printed at the bottom of the chain */ boot(); CHECK(is(say(": P0 .\" deep\" ; : P1 P0 ; : P2 P1 ; : P3 P2 ; : P4 P3 ; P4\n"), "deep ok\nok> "), ".\" five calls down"); /* ---- how many values may wait on the stack from one line to the next ---- */ { unsigned k, most = 0; for (k = 1; k < V4_DATA_DEPTH; k++) { char line[4 * V4_DATA_DEPTH + 16], want[16]; size_t at = 0; unsigned m; boot_bare(); for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "1 "); snprintf(line + at, sizeof line - at, "\n"); if (strcmp(say(line), " ok\nok> ") != 0) break; for (at = 0, m = 1; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "+ "); snprintf(line + at, sizeof line - at, "32 + EMIT\n"); snprintf(want, sizeof want, "%c ok\nok> ", (char)(32 + k)); if (strcmp(say(line), want) != 0) break; most = k; } printf(" %u values may wait on the stack while the next line is typed and interpreted\n", most); CHECK(most + 4u >= V4_DATA_DEPTH, "the prompt and the interpreter take no more than four cells of the stack"); } /* ---- how much of the data stack a line has ---- */ { unsigned d; for (d = 0; d < V4_DATA_DEPTH; d++) { unsigned k, good = 1; boot_with(d + 1); if (strcmp(say(": Z1 .\" x\" 1 2 + ; Z1 Z1 + 48 + EMIT\n"), "xx6 ok\nok> ") != 0) break; if (!canary_under_expect()) break; for (k = d + 1; k-- > 0; ) if (v4_dstack_pop(&n.ds) != (v4_cell)(0x5A000000 + k)) good = 0; if (!good) break; } printf(" defining and running a word from the prompt leaves %u data cells under it untouched\n", d); CHECK(d >= 3, "the prompt leaves room on the data stack"); } /* ---- numbers at the ends of the range, which depend on the cell width ---- */ boot_bare(); #if V4_CELL_BITS == 32 CHECK(is(say("-1 U. -2147483648 . 2147483647 .\n"), "4294967295 -2147483648 2147483647 ok\nok> "), "the largest and smallest numbers"); CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFF ok\nok> ") && is(say("2 BASE ! -1 U. DECIMAL\n"), "11111111111111111111111111111111 ok\nok> "), "in hex and in binary"); #else CHECK(is(say("-1 U.\n"), "18446744073709551615 ok\nok> "), "the largest number (as v3)"); CHECK(is(say("-9223372036854775808 . 9223372036854775807 .\n"), "-9223372036854775808 9223372036854775807 ok\nok> "), "the smallest and largest signed"); CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFFFFFFFFFF ok\nok> "), "in hex"); /* 64 binary digits are one more than the hold buffer's 63 (D-13): an error, and nothing is printed */ CHECK(is(say("2 BASE ! -1 U. DECIMAL\n"), "Number too long\n ERROR\nok> "), "in binary, its 64 digits are one too many"); CHECK(is(say("DECIMAL\n"), " ok\nok> "), "(back to decimal)"); CHECK(is(say("9223372036854775807 2 BASE ! U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ok\nok> "), "a 63-digit number prints whole"); #endif /* the shifts, to the last bit */ { char line[96], want[64]; boot_bare(); snprintf(line, sizeof line, "1 %d LSHIFT .\n", V4_CELL_BITS); CHECK(is(say(line), "Shift count out of range\n ERROR\nok> "), "a shift by the cell's width is out of range"); snprintf(line, sizeof line, "1 %d LSHIFT 0< . -1 %d RSHIFT . -8 1 RSHIFT 2* 8 + .\n", V4_CELL_BITS - 1, V4_CELL_BITS - 1); CHECK(is(say(line), "-1 1 0 ok\nok> "), "a shift by one less reaches the top bit, and RSHIFT brings zeros in"); snprintf(line, sizeof line, "-1 1 RSHIFT .\n"); #if V4_CELL_BITS == 32 snprintf(want, sizeof want, "2147483647 ok\nok> "); #else snprintf(want, sizeof want, "9223372036854775807 ok\nok> "); #endif CHECK(is(say(line), want), "-1 1 RSHIFT is the largest positive number"); } /* .S works on the stack it is printing, so it needs some of it free */ { char line[4 * V4_DATA_DEPTH + 16], want[8 * V4_DATA_DEPTH + 32]; unsigned k, m, most = 0; for (k = 1; k < V4_DATA_DEPTH; k++) { size_t at = 0, wt; boot_bare(); for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "7 "); snprintf(line + at, sizeof line - at, "\n"); if (strlen(line) > 80 || strcmp(say(line), " ok\nok> ") != 0) break; wt = (size_t)snprintf(want, sizeof want, "<%u> ", k); for (m = 0; m < k; m++) wt += (size_t)snprintf(want + wt, sizeof want - wt, "7 "); snprintf(want + wt, sizeof want - wt, "\n ok\nok> "); if (strcmp(say(".S\n"), want) != 0) break; snprintf(want, sizeof want, "%u ok\nok> ", k); CHECK(is(say("DEPTH .\n"), want), "after .S the %u values are still there", k); most = k; } printf(" .S prints a stack of up to %u values; it needs %u cells free\n", most, (unsigned)V4_DATA_DEPTH - most); CHECK(most + 8u >= V4_DATA_DEPTH, ".S works with all but eight cells of the stack in use"); } /* ---- nested CASE, by value ---- */ boot_bare(); CHECK(is(say(": IN CASE 1 OF 65 ENDOF 2 OF 66 ENDOF 63 SWAP ENDCASE ;\n"), " ok\nok> ") && is(say(": OUT CASE 1 OF IN ENDOF 2 OF DROP 90 ENDOF DROP 33 SWAP ENDCASE EMIT ;\n"), " ok\nok> "), "a CASE that calls a CASE"); CHECK(is(say("1 1 OUT 2 1 OUT 9 1 OUT 5 2 OUT 5 7 OUT .S\n"), "AB?Z!<0> \n ok\nok> "), "every path through both"); CHECK(is(say(": NC CASE 1 OF CASE 5 OF 65 ENDOF 66 SWAP ENDCASE ENDOF 67 SWAP ENDCASE EMIT ;\n"), " ok\nok> ") && is(say("5 1 NC 6 1 NC 7 2 NC .S\n"), "ABC<1> 7 \n ok\nok> "), "a CASE inside a clause of a CASE"); /* ---- FORGET gives the space back, and FENCE protects ---- */ boot_bare(); { v4_cell dp0 = n.mem[DP], latest0 = n.mem[LATEST]; CHECK(is(say(": F1 1 ; VARIABLE F2 : F3 F1 F2 ;\n"), " ok\nok> ") && n.mem[DP] > dp0, "three words"); CHECK(is(say("FORGET F1\n"), " ok\nok> ") && n.mem[DP] == dp0 && n.mem[LATEST] == latest0, "FORGET of the first puts HERE and LATEST back where they were"); CHECK(is(say(": G1 65 EMIT ; : G2 66 EMIT ;\n"), " ok\nok> ") && is(say("HERE FENCE ! : G3 67 EMIT ;\n"), " ok\nok> "), "two words, the fence, and a third"); CHECK(is(say("FORGET G2\n"), "Protected word\n ERROR\nok> ") && is(say("G1 G2 G3\n"), "ABC ok\nok> "), "a word below the fence cannot be forgotten"); CHECK(is(say("FORGET G3 G1 G2\n"), "AB ok\nok> ") && is(say("G3\n"), "UNKNOWN WORD: 'G3'\n ERROR\nok> "), "one above it can"); } /* ---- WORDS ---- */ boot_bare(); CHECK(is(say(": ZEBRA ; : YAK ; : HALFWAY 1\n"), " ok\nok> "), "two words and a definition under way"); { const char *w = say("[ WORDS ]\n"); const char *p, *line = w; unsigned longest = 0, names = 0; CHECK(strncmp(w, "YAK ZEBRA ", 10) == 0, "WORDS starts with the newest; a definition under way is not shown"); CHECK(strstr(w, " DUP ") && strstr(w, " WORDS ") && strstr(w, " : ") && strstr(w, " ABORT\" ") && strstr(w, "UM* "), "and goes back to the capsule's first word"); CHECK(strlen(w) > 9 && strcmp(w + strlen(w) - 9, "\n ok\nok> ") == 0, "it ends with a new line"); for (p = w; *p; p++) { if (*p == ' ') names++; if (*p == '\n') { if ((unsigned)(p - line) > longest) longest = (unsigned)(p - line); line = p + 1; } } printf(" WORDS: %u names, longest line %u columns\n", names - 1u, longest); CHECK(longest <= 64u + 32u && names > 200u, "lines are wrapped"); CHECK(is(say(";\n"), " ok\nok> ") && strncmp(say("VLIST\n"), "HALFWAY YAK ZEBRA ", 18) == 0, "VLIST is the same word; a finished definition is shown"); } /* ---- a full dictionary ---- */ boot_bare(); n.mem[DP] = (DICT_END_W - 2) * 4; CHECK(is(say(": FULL 1 2 3 4 5 6 7 8 9 ; 65 EMIT\n"), "Dictionary full\n ERROR\nok> ") && n.mem[STATE] == 0, "a definition that does not fit"); CHECK(is(say("FULL\n"), "UNKNOWN WORD: 'FULL'\n ERROR\nok> "), "is not defined"); n.mem[DP] = (DICT_END_W - 1) * 4; CHECK(is(say("1 , 65 EMIT\n"), "A ok\nok> ") && is(say("2 , 66 EMIT\n"), "Dictionary full\n ERROR\nok> "), "the last cell can be used; the one after it cannot"); CHECK(is(say("5 ALLOT 67 EMIT\n"), "Dictionary full\n ERROR\nok> ") && is(say("-99999 ALLOT\n"), "Dictionary full\n ERROR\nok> "), "nor can ALLOT go past either end"); CHECK(is(say("68 EMIT .S\n"), "D<0> \n ok\nok> "), "and the prompt goes on"); /* ---- the fault table: six words, each a jump to its handler ---- */ { static const char *const handler[] = { "(FAULT)", "(D-OVER)", "(D-UNDER)", "(R-OVER)", "(R-UNDER)", "(RAISED)" }; for (i = 0; i < V4_FAULT_KINDS; i++) { v4_iword w = (v4_iword)((v4_ucell)n.mem[w_fault + (v4_cell)i] & 0xFFFFFFFFu); CHECK(v4_iword_op(w, 0) == V4_OP_JUMP && v4_iword_branch(w_fault + (v4_cell)i + 1, w, 0) == v4_text_word(&tx, handler[i]), "word %u of the fault table jumps to %s", i, handler[i]); } CHECK(n.fault_vector == w_fault, "and the node has it"); } CHECK(v4_node_guards_intact(&n), "guards intact"); printf(" %d checks, %d failures\n", checks, failures); return failures ? 1 : 0; }