admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
644bfc0a25bfe7795b09e844881299ab38bb0a07
LithosAnanake/v4/tests/test_host_quit.c
T
rajamesandClaude Opus 5.5 644bfc0a25 feat(v4.0.0): number output in the capsule, and .S 
- capsule/numout.v4: <# # #S HOLD SIGN #>, . .R U. U.R D. D.R, ?, SPACES,
  DECIMAL HEX OCTAL -- the definitions DECOMPOSITION.md 5.8 gives and the
  mesh-node tests execute, now words of the host node's vocabulary.
- .S, which D-16 makes possible again: as v3, the depth, then every value
  from the deepest, then a new line.  It needs six cells of the stack
  free.
- tests/test_host_quit.c: printed from the prompt, with 14 more sessions
  that are transcripts of the v3 binary, and the ends of the number range
  at each cell width.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-04 18:50:12 -04:00

572 lines
34 KiB
C
Raw Blame History

/* 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).
* - control words that do not match give ERROR alone; v3 names the word.
* - 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 <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)
#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;
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_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 },
/* 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", " 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 },
{ "PAD PAD -1 CMOVE 65 EMIT\n66 EMIT\n", "A 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" };
CHECK(host_load(&tx, &n, files, 8), "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"), " ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W,
"a word that sets NODE-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): the last is dropped and the line is an error */
CHECK(is(say("2 BASE ! -1 U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ERROR\nok> "), "in binary, 63 of its 64 digits and ERROR");
CHECK(is(say("9223372036854775807 2 BASE ! U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ok\nok> "), "a 63-digit number prints whole");
#endif
/* .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");
}
/* ---- the fault table: five words, each a jump to its handler ---- */
{
static const char *const handler[] = { "(FAULT)", "(D-OVER)", "(D-UNDER)", "(R-OVER)", "(R-UNDER)" };
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;
}
Reference in New Issue View Git Blame Copy Permalink