admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
01c447f9ab59d38187cd5badc0ebb8ab119de31f
LithosAnanake/v4/tests/test_host_quit.c
T
rajamesandClaude Opus 5.5 01c447f9ab feat(v4.0.0): a node is handed a line -- ENGINE.md step 1 
A v4 node no longer reads its own command line or prints a prompt.  Its
host puts a line of text in the node's input buffer and starts it at
(LINE); the node interprets it and stops at (IDLE), leaving in
(LINE-STATUS) how it ended: completed, an error, or QUIT.  The host says
" ok" or " ERROR" and prompts, as the kernel's REPL does for a v3 VM.  A
line may be 1024 characters, a block, as v3's.  Ruled 2026-10-05
(V3-PARITY.md 1b); design ENGINE.md 3.1.

- quit.v4: (REPL), the node's prompt loop, is gone; (LINE) (IDLE) (DONE)
- image.h/.c: v4_line_begin, v4_line_done, v4_line_status; the node is
  idle at switch-on
- boot.c: v4_boot_line, the one loop the hosted binary, the kernel and the
  capsule loader hand a line with; the code that took " ok" and the prompt
  back out of the node's output is gone
- hosted.c, sk_v4.c: the prompt and the line editing are the host's
- test_host_quit.c: the tests are the node's host; two tests of the old
  80-character prompt line now test a whole line, 1024 and 1025 characters

Verified: make -C v4 test passes at both widths; hosted-check passes on
three ISAs; clean qemu with STARFORTH_V4=1 on amd64, aarch64 and riscv64
passes POST (550 of 550) with the same hashes as hosted, and three lines
typed at each bare-metal prompt through the serial port are answered
correctly (logs/20261005-180922, -181152, -181541).

Still the lone node: kernel_main.c starts it before the fleet tables.

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

1360 lines
97 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).
* - LOAD goes on with the rest of its line afterwards, and there is BLK
* (both FORTH-79); v3's LOAD drops the rest of the line and it has no
* BLK. A block number that does not exist says so.
* - vocabularies are FORTH-79's: a word defined in one is found only when
* that vocabulary is CONTEXT, and FORTH is searched after it. v3 finds
* every word everywhere, and a word redefined in a vocabulary replaces
* FORTH's for good.
* - 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/image.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_key, w_key_end, w_fault, capsule_latest;
static v4_image img; /* where a line is handed to the node: v4/include/v4/image.h */
static char out[V4_CONSOLE_CAP + 1];
/* The storage device's blocks: zeros at every switch-on. */
#define DISK_BLOCKS 64u
static unsigned char disk[DISK_BLOCKS * V4_BLOCK_BYTES];
/* A block holding `text`, the rest of it blanks. */
static void put_block(unsigned num, const char *text)
{
memset(disk + num * V4_BLOCK_BYTES, ' ', V4_BLOCK_BYTES);
memcpy(disk + num * V4_BLOCK_BYTES, text, strlen(text));
}
static long last_steps;
/* THE HOST. A node is handed a line and prints no prompt (ENGINE.md 3.1);
* these tests are its host, and do what tools/hosted.c does: take what is
* typed a line at a time, hand each line over, and say " ok" or " ERROR" and
* the next prompt. What is typed after a line is there for a word in it
* that reads the keyboard, and what such a word does not take is the next
* line. */
static char typed[8192]; /* typed and not yet taken */
static unsigned typed_len;
static int line_open; /* a line has been handed over and has not ended */
/* Run until the line ends, or until it has been inside KEY with nothing to
* read for 64 instruction words; or until `max` words. 1: ended, 2: waiting
* for a character, 0: neither. */
static int run_line(long max)
{
long steps = 0;
unsigned idle = 0;
while (steps < max && idle < 64) {
if (v4_line_done(&n, &img)) { last_steps = steps; return 1; }
(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;
if (v4_line_done(&n, &img)) return 1;
return idle >= 64 ? 2 : 0;
}
/* 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[BOOT_CELLS] = n.mem[DP];
n.mem[BOOT_CELLS + 1] = capsule_latest;
n.mem[FENCE] = DICT_W;
n.mem[LOG_LEVEL] = 2;
n.mem[ACL_HOOK] = 0;
for (v4_cell xt = capsule_latest; xt != 0; xt = n.mem[xt - 1]) n.mem[xt - 3] &= 31; /* the capsule's words: no access control fields set */
n.mem[CONTEXT] = LATEST;
n.mem[CURRENT] = LATEST;
n.mem[VOC_LINK] = 0;
n.mem[SRC] = TIB;
for (v4_cell k = BVARS; k < BVARS + 14; k++) if (k != SRC) n.mem[k] = 0; /* empty buffers, SCR and BLK 0, no hook */
memset(disk, 0, sizeof disk);
v4_node_storage_attach(&n, STORAGE_REG, disk, DISK_BLOCKS);
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.mem[LINE_STATUS] = V4_LINE_COMPLETED;
n.p = img.idle; /* idle, waiting to be handed a line */
typed_len = 0;
line_open = 0;
}
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;
}
/* Type `input` and return what the console then shows: what each line
* printed, the host's " ok" or " ERROR" after it, and the next prompt. A
* line that has not been ended shows nothing; nor does one that is waiting
* for a character. */
static const char *say(const char *input)
{
unsigned ilen = (unsigned)strlen(input), olen = 0;
if (typed_len + ilen > sizeof typed) return "(input queue full)";
memcpy(typed + typed_len, input, ilen);
typed_len += ilen;
out[0] = 0;
for (;;) {
const char *tail;
unsigned took;
int ended;
if (!line_open) {
char *nl = (char *)memchr(typed, '\n', typed_len);
unsigned len;
if (!nl) break;
len = (unsigned)(nl - typed);
if (!v4_line_begin(&n, &img, typed, len)) return "(line too long)";
memmove(typed, nl + 1, typed_len - len - 1);
typed_len -= len + 1;
line_open = 1;
}
v4_node_console_attach(&n, CONSOLE_TX); /* empties the capture */
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST); /* and the keyboard */
if (v4_node_console_feed(&n, typed, typed_len) != typed_len) return "(input queue full)";
ended = run_line(40000000);
took = n.input_pos; /* what a word in the line read */
memmove(typed, typed + took, typed_len - took);
typed_len -= took;
if (n.console_dropped || olen + n.console_len + 16 > sizeof out) return "(too much output)";
memcpy(out + olen, n.console, n.console_len);
olen += n.console_len;
out[olen] = 0;
if (ended == 0) return "(still running)";
if (ended == 2) break;
line_open = 0;
tail = v4_line_status(&n, &img) == V4_LINE_COMPLETED ? " ok\nok> "
: v4_line_status(&n, &img) == V4_LINE_ERROR ? " ERROR\nok> " : "ok> ";
memcpy(out + olen, tail, strlen(tail) + 1);
olen += (unsigned)strlen(tail);
}
return out;
}
/* Feed a file of FORTH source to the prompt, a line at a time, as if typed.
* True if every line was accepted: the node said " ok" and nothing else. */
static int load_source(const char *name)
{
char path[512], line[160];
FILE *f;
unsigned num = 0;
snprintf(path, sizeof path, "%s/%s", V4_CAPSULE_DIR, name);
f = fopen(path, "r");
if (!f) { printf(" cannot open %s\n", path); return 0; }
while (fgets(line, sizeof line, f)) {
size_t len = strlen(line);
num++;
if (len == 0 || line[len - 1] != '\n' || len > 80) { printf(" %s line %u: too long\n", name, num); fclose(f); return 0; }
(void)say(line);
/* every line is accepted: whatever it printed, it ended with " ok" and never with ERROR */
if (strlen(out) < 9 || strcmp(out + strlen(out) - 9, "\n ok\nok> ") != 0 || strstr(out, " ERROR\n")) {
if (strcmp(out, " ok\nok> ") != 0) { printf(" %s line %u: %s", name, num, line); printf(" -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; }
}
}
fclose(f);
return n.mem[STATE] == 0;
}
/* What the editor's L prints for a screen of blanks. */
static const char *blank_screen(int num)
{
static char text[2048];
size_t at = (size_t)snprintf(text, sizeof text, "Screen %d:\n", num);
for (unsigned k = 0; k < 16; k++) at += (size_t)snprintf(text + at, sizeof text - at, "%2u: %-64s\n", k, "");
snprintf(text + at, sizeof text - at, " ok\nok> ");
return text;
}
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 },
/* qmath.v4: every result printed by Q.PRINT, which shows all sixteen bits of the fraction */
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "0.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "2.71823 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.84147 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.54028 ok\nok> ", 1 },
{ "2 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "2.00000 ok\nok> ", 1 },
{ "2 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.41424 ok\nok> ", 1 },
{ "2 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "0.69314 ok\nok> ", 1 },
{ "2 Q.FROM-INT 1 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "7.38894 ok\nok> ", 1 },
{ "2 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.90930 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.PRINT\n", "1.50000 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.22473 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "0.40550 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "4.48153 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.99748 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.07073 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ Q.PRINT\n", "0.33332 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "0.57733 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "1.39553 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.32719 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.94496 ok\nok> ", 1 },
{ "7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.PRINT\n", "1.75000 ok\nok> ", 1 },
{ "7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.32298 ok\nok> ", 1 },
{ "7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "0.55966 ok\nok> ", 1 },
{ "7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "5.75444 ok\nok> ", 1 },
{ "7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.98399 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "10.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "3.16235 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "2.30261 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "12842.30421 ok\nok> ", 1 },
{ "22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.PRINT\n", "3.14285 ok\nok> ", 1 },
{ "22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.77279 ok\nok> ", 1 },
{ "22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "1.14517 ok\nok> ", 1 },
{ "22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "23.15980 ok\nok> ", 1 },
{ "1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.PRINT\n", "0.00999 ok\nok> ", 1 },
{ "1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "0.09996 ok\nok> ", 1 },
{ "1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "1.01004 ok\nok> ", 1 },
{ "1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.00999 ok\nok> ", 1 },
{ "1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.99995 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ Q.PRINT\n", "15.93750 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "3.99217 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "2.76870 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ Q.PRINT\n", "333.33332 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "18.25744 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "5.80915 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.31947 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.94760 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.PRINT\n", "0.62500 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "0.79055 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "1.86820 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.58511 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.81095 ok\nok> ", 1 },
{ "9 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "9.00000 ok\nok> ", 1 },
{ "9 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "3.00003 ok\nok> ", 1 },
{ "9 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "2.19726 ok\nok> ", 1 },
{ "9 Q.FROM-INT 1 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "5720.68249 ok\nok> ", 1 },
{ "9 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.41204 ok\nok> ", 1 },
{ "15 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "15.00000 ok\nok> ", 1 },
{ "15 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "3.87297 ok\nok> ", 1 },
{ "15 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "2.70808 ok\nok> ", 1 },
{ "15 Q.FROM-INT 1 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "387262.21916 ok\nok> ", 1 },
{ "15 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.65025 ok\nok> ", 1 },
{ "1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.PRINT\n", "0.14285 ok\nok> ", 1 },
{ "1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "0.37799 ok\nok> ", 1 },
{ "1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.EXP Q.PRINT\n", "1.15351 ok\nok> ", 1 },
{ "1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.SIN Q.PRINT\n", "0.14237 ok\nok> ", 1 },
{ "1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.COS Q.PRINT\n", "0.98982 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.* Q.PRINT\n", "2.62500 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "3.25000 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q./ Q.PRINT\n", "0.85713 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "1.75000 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "1.50000 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.< .\n", "-1 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.> .\n", "0 ok\nok> ", 1 },
{ "3 Q.FROM-INT 2 Q.FROM-INT Q./ 7 Q.FROM-INT 4 Q.FROM-INT Q./ Q.= .\n", "0 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.* Q.PRINT\n", "0.99998 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "3.33332 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q./ Q.PRINT\n", "0.11109 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "3.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "0.33332 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.< .\n", "-1 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.> .\n", "0 ok\nok> ", 1 },
{ "1 Q.FROM-INT 3 Q.FROM-INT Q./ 3 Q.FROM-INT 1 Q.FROM-INT Q./ Q.= .\n", "0 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.* Q.PRINT\n", "50.08920 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "19.08035 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q./ Q.PRINT\n", "5.07102 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "15.93750 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "3.14285 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.< .\n", "0 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.> .\n", "-1 ok\nok> ", 1 },
{ "255 Q.FROM-INT 16 Q.FROM-INT Q./ 22 Q.FROM-INT 7 Q.FROM-INT Q./ Q.= .\n", "0 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.* Q.PRINT\n", "3.33149 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "333.34332 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q./ Q.PRINT\n", "33351.65342 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "333.33332 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "0.00999 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.< .\n", "0 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.> .\n", "-1 ok\nok> ", 1 },
{ "1000 Q.FROM-INT 3 Q.FROM-INT Q./ 1 Q.FROM-INT 100 Q.FROM-INT Q./ Q.= .\n", "0 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.* Q.PRINT\n", "0.39062 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "1.25000 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q./ Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "0.62500 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "0.62500 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.< .\n", "0 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.> .\n", "0 ok\nok> ", 1 },
{ "5 Q.FROM-INT 8 Q.FROM-INT Q./ 5 Q.FROM-INT 8 Q.FROM-INT Q./ Q.= .\n", "-1 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.* Q.PRINT\n", "100.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.+ Q.PRINT\n", "20.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q./ Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.MAX Q.PRINT\n", "10.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.MIN Q.PRINT\n", "10.00000 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.< .\n", "0 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.> .\n", "0 ok\nok> ", 1 },
{ "10 Q.FROM-INT 1 Q.FROM-INT Q./ 10 Q.FROM-INT 1 Q.FROM-INT Q./ Q.= .\n", "-1 ok\nok> ", 1 },
{ "Q.1 Q.PRINT Q.0 Q.PRINT Q.SCALE Q.PRINT\n", "1.00000 0.00000 1.00000 ok\nok> ", 1 },
{ "7 Q.FROM-INT 2 Q.FROM-INT Q./ Q.TO-INT . 100 Q.FROM-INT Q.TO-INT .\n", "3 100 ok\nok> ", 1 },
{ "Q.0 Q.0= . Q.1 Q.0= . Q.0 Q.SQRT Q.PRINT Q.1 Q.SQRT Q.PRINT Q.0 Q.EXP Q.PRINT\n", "-1 0 0.00000 1.00000 1.00000 ok\nok> ", 1 },
{ "5 Q.FROM-INT 3 Q.FROM-INT Q.- Q.PRINT Q.1 Q.ABS Q.PRINT\n", "2.00000 1.00000 ok\nok> ", 1 },
{ "HEX 10 Q.FROM-INT Q.PRINT 10 . DECIMAL\n", "16.00000 10 ok\nok> ", 1 },
{ "20 Q.FROM-INT Q.EXP Q.0= . Q.1 Q.LOG Q.PRINT\n", "0 0.00000 ok\nok> ", 1 },
/* v4's own: signed values (D-8), which v3 prints as large unsigned numbers, and the errors */
{ "-3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.PRINT -7 Q.FROM-INT Q.PRINT\n", "-1.50000 -7.00000 ok\nok> ", 0 },
{ "3 Q.FROM-INT -2 Q.FROM-INT Q.* Q.PRINT -3 Q.FROM-INT -2 Q.FROM-INT Q.* Q.PRINT\n", "-6.00000 6.00000 ok\nok> ", 0 },
{ "-5 Q.FROM-INT Q.ABS Q.PRINT 5 Q.FROM-INT Q.NEG Q.PRINT\n", "5.00000 -5.00000 ok\nok> ", 0 },
{ "-1 Q.FROM-INT Q.1 Q.< . -1 Q.FROM-INT Q.1 Q.MAX Q.PRINT\n-1 Q.FROM-INT Q.1 Q.MIN Q.PRINT\n", "-1 1.00000 ok\nok> -1.00000 ok\nok> ", 0 },
{ "-1 Q.FROM-INT Q.EXP Q.PRINT -3 Q.FROM-INT 2 Q.FROM-INT Q./ Q.TO-INT .\n", "0.36787 -2 ok\nok> ", 0 },
{ "4 Q.FROM-INT Q.SIN Q.PRINT 2 Q.FROM-INT Q.COS Q.PRINT\n-1 Q.FROM-INT Q.SIN Q.PRINT\n", "-0.75680 -0.41615 ok\nok> -0.84147 ok\nok> ", 0 },
{ "1 Q.FROM-INT 2 Q.FROM-INT Q./ Q.LOG Q.PRINT\n", "-0.69314 ok\nok> ", 0 },
{ "-1 Q.FROM-INT 3 Q.FROM-INT Q./ -1 Q.FROM-INT 7 Q.FROM-INT Q./ Q.* . .\n", "0 3120 ok\nok> ", 0 },
{ "-4 Q.FROM-INT Q.SIN . . 4 Q.FROM-INT Q.COS . .\n", "0 49598 -1 -42838 ok\nok> ", 0 },
{ "Q.0 Q.0 Q./ 65 EMIT\nDEPTH .\n", "Division by zero\n ERROR\nok> 2 ok\nok> ", 0 },
{ "7 Q.1 Q.0 Q./ 65 EMIT\nDEPTH .\n", "Division by zero\n ERROR\nok> 3 ok\nok> ", 0 },
{ "7 -4 Q.FROM-INT Q.SQRT 65 EMIT\nDEPTH . . . .\n", "Argument out of range\n ERROR\nok> 3 0 0 7 ok\nok> ", 0 },
{ "Q.0 Q.LOG 65 EMIT\n-1 Q.FROM-INT Q.LOG\n", "Argument out of range\n ERROR\nok> Argument out of range\n ERROR\nok> ", 0 },
{ "7 PAD -1 DUMP 65 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 },
{ "PAD 0 DUMP\n", " ok\nok> ", 1 },
/* acl.v4: the fields of an entry, and the check, as v3 */
{ ": FOO 65 EMIT ; ' FOO ACL-MODE@ . ' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ .\n' FOO ACL-PINNED? .\n", "0 0 -1 ok\nok> 0 ok\nok> ", 1 },
{ ": FOO 65 EMIT ; 1 ' FOO ACL-MODE! 77 ' FOO ACL-TTL! ' FOO ACL-MODE@ .\n' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n", "1 ok\nok> 77 A76 ok\nok> ", 1 },
{ ": FOO 65 EMIT ; ' FOO ACL-PIN ' FOO ACL-PINNED? . 5 ' FOO ACL-TTL!\n0 ' FOO ACL-ALLOW! 1 ' FOO ACL-MODE!\n' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ . ' FOO ACL-MODE@ .\n",
"-1 ok\nok> ok\nok> 0 -1 0 ok\nok> ", 1 },
{ ": A 1 ; : B 2 ; 1 ' A ACL-MODE! ' A ACL-PIN ' B ACL-PIN ' A ' B ACL-INHERIT\n' B ACL-MODE@ . ' B ACL-PINNED? . ' B ACL-TTL@ . ' B ACL-ALLOW@ .\n",
" ok\nok> 1 0 0 -1 ok\nok> ", 1 },
{ "-5 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 3 ' DUP ACL-MODE! ' DUP ACL-MODE@ .\n", "0 3 ok\nok> ", 1 },
{ "' DUP ACL-TTL@ . ' DUP ACL-MODE@ . ' DUP ACL-ALLOW@ . ' DUP ACL-PINNED? .\n", "0 0 -1 0 ok\nok> ", 1 },
{ ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! 1 2 FOO 66 EMIT\n.S ' FOO ACL-TTL@ .\n",
"\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> <0> \n4 ok\nok> ", 1 },
/* v4's own: the TTL is sixteen bits; a denied word cannot be compiled; with no policy a recheck allows */
{ ": BAZ 67 EMIT ; 0 ' BAZ ACL-ALLOW! BAZ ' BAZ ACL-TTL@ . ' BAZ ACL-ALLOW@ .\n", "C65535 -1 ok\nok> ", 0 },
{ ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! : BAR FOO ; 66 EMIT\nBAR\n' FOO ACL-TTL@ .\n",
"\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> UNKNOWN WORD: 'BAR'\n ERROR\nok> 4 ok\nok> ", 0 },
{ ": FOO 65 EMIT ; : BAR FOO ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! BAR\n", "A ok\nok> ", 0 },
{ "99999 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 65535 ' DUP ACL-TTL! ' DUP ACL-TTL@ .\n", "65535 65535 ok\nok> ", 0 },
{ "258 ' DUP ACL-MODE! ' DUP ACL-MODE@ . 0 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ .\n7 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ . ' DUP ACL-TTL@ .\n", "2 0 ok\nok> -1 0 ok\nok> ", 0 },
{ "7 0 ACL-MODE@ 65 EMIT\n0 ACL-PIN\n1 0 ACL-TTL!\n.S\n", "Not a word\n ERROR\nok> Not a word\n ERROR\nok> Not a word\n ERROR\nok> <2> 7 1 \n ok\nok> ", 0 },
{ ": W1 ; ' W1 ACL-WORD-ID ' W1 = . ' W1 ACL-HEAT@ .\n", "-1 0 ok\nok> ", 0 },
{ ": IM 65 EMIT ; IMMEDIATE 3 ' IM ACL-TTL! 0 ' IM ACL-ALLOW! : U IM ;\n", "\033[33mWARN: \033[0mACL: denied 'IM'\n ERROR\nok> ", 0 },
{ ": P1 ; : P2 ; VOCABULARY VV VV DEFINITIONS : P3 ; FORTH DEFINITIONS\n9 ' P1 ACL-TTL! 1 ' P2 ACL-MODE! ' P2 ACL-PIN VV 9 ' P3 ACL-TTL!\nACL-INIT-PRIMITIVES ' P1 ACL-TTL@ . ' P2 ACL-MODE@ . ' P3 ACL-TTL@ . FORTH\n",
" ok\nok> ok\nok> 0 1 0 ok\nok> ", 0 },
/* log.v4: v3's lines, colours and all, without its time of day */
{ "LOG-LEVEL@ . LOG-ERROR . LOG-WARN . LOG-INFO . LOG-TEST . LOG-DEBUG .\n",
"2 0 1 2 3 4 ok\nok> ", 1 },
{ "LOG-INFO\" hello info\"\nLOG-WARN\" careful\"\nLOG-ERROR\" bad\"\nLOG-DEBUG\" dbg\"\nLOG-TEST\" tst\"\n",
"\033[32mINFO: \033[0mhello info\n ok\nok> \033[33mWARN: \033[0mcareful\n ok\nok> \033[31mERROR: \033[0mbad\n ok\nok> ok\nok> ok\nok> ", 1 },
{ ": T LOG-INFO\" from a word\" 65 EMIT ; T\n",
"\033[32mINFO: \033[0mfrom a word\nA ok\nok> ", 1 },
{ "S\" a string\" LOG-INFO-STR\nS\" w\" LOG-WARN-STR S\" e\" LOG-ERROR-STR\nS\" d\" LOG-DEBUG-STR S\" t\" LOG-TEST-STR\n",
"\033[32mINFO: \033[0ma string\n ok\nok> \033[33mWARN: \033[0mw\n\033[31mERROR: \033[0me\n ok\nok> ok\nok> ", 1 },
{ "0 LOG-LEVEL! LOG-LEVEL@ . LOG-ERROR\" e0\" LOG-WARN\" w0\"\n",
/* v3 prints the 0 after the message: its log goes to stderr at once and its numbers to stdout when the line ends */
"0 \033[31mERROR: \033[0me0\n ok\nok> ", 0 },
{ "99 LOG-LEVEL! LOG-LEVEL@ . 4 LOG-LEVEL! LOG-DEBUG\" d\" 5 LOG-LEVEL! LOG-LEVEL@ .\n", "4 \033[34mDEBUG: \033[0md\n4 ok\nok> ", 0 },
{ "7 S\" abc\" LOG-DEBUG-STR 8 PAD -1 LOG-DEBUG-STR .S\n", "<2> 7 8 \n ok\nok> ", 0 },
{ "7 PAD -1 LOG-ERROR-STR 65 EMIT\n.S\n", "\033[31mERROR: \033[0mNegative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 },
{ "LOG-WARN\" no closing quote\n", "\033[33mWARN: \033[0mno closing quote\n ok\nok> ", 0 },
{ ": L3 LOG-INFO\" abcd\" 65 EMIT LOG-DEBUG\" hidden\" 66 EMIT ; L3 .S\n", "\033[32mINFO: \033[0mabcd\nAB<0> \n ok\nok> ", 0 },
{ "(LOG\")\n", "(LOG\"): compile-only\n ERROR\nok> ", 0 },
{ "1 LOG-LEVEL! LOG-ERROR\" e1\" LOG-WARN\" w1\" LOG-INFO\" i1\"\n",
"\033[31mERROR: \033[0me1\n\033[33mWARN: \033[0mw1\n ok\nok> ", 1 },
{ "2 LOG-LEVEL! LOG-ERROR\" e2\" LOG-WARN\" w2\" LOG-INFO\" i2\" LOG-TEST\" t2\"\n",
"\033[31mERROR: \033[0me2\n\033[33mWARN: \033[0mw2\n\033[32mINFO: \033[0mi2\n ok\nok> ", 1 },
{ "3 LOG-LEVEL! LOG-INFO\" i3\" LOG-TEST\" t3\" LOG-DEBUG\" d3\"\n",
"\033[32mINFO: \033[0mi3\n\033[35mTEST: \033[0mt3\n ok\nok> ", 1 },
{ "-1 LOG-LEVEL! LOG-LEVEL@ .\n",
"0 ok\nok> ", 1 },
{ "LOG-INFO\" \"\n",
"\033[32mINFO: \033[0m\n ok\nok> ", 1 },
{ ": W LOG-ERROR\" e\" LOG-WARN\" w\" LOG-TEST\" t\" ; W 3 LOG-LEVEL! W\n",
"\033[31mERROR: \033[0me\n\033[33mWARN: \033[0mw\n\033[31mERROR: \033[0me\n\033[33mWARN: \033[0mw\n\033[35mTEST: \033[0mt\n ok\nok> ", 1 },
/* blocks.v4 */
{ "20 BLOCK 1024 BLANK 65 20 BLOCK C! UPDATE SAVE-BUFFERS 20 BLOCK C@ .\n",
"65 ok\nok> ", 1 },
{ "20 BLOCK 1024 BLANK 20 BLOCK 16 65 FILL UPDATE 20 LIST\nSCR @ .\n",
"\nBlock 20\n00: AAAAAAAAAAAAAAAA \n01: \n02: \n03: \n04: \n05: \n06: \n07: \n08: \n09: \n10: \n11: \n12: \n13: \n14: \n15: \n\n ok\nok> 20 ok\nok> ", 1 },
{ "30 BLOCK 1024 BLANK S\" 65 EMIT 66 EMIT\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n",
"AB ok\nok> ", 1 },
{ "30 BLOCK 1024 BLANK S\" 65 EMIT -->\" 30 BLOCK SWAP CMOVE UPDATE\n31 BLOCK 1024 BLANK S\" 66 EMIT\" 31 BLOCK SWAP CMOVE UPDATE 30 LOAD\n",
" ok\nok> AB ok\nok> ", 1 },
{ "30 BLOCK 1024 BLANK S\" 65 EMIT\" 30 BLOCK SWAP CMOVE UPDATE\n31 BLOCK 1024 BLANK S\" 66 EMIT\" 31 BLOCK SWAP CMOVE UPDATE 30 31 THRU\n",
" ok\nok> AB ok\nok> ", 1 },
{ "30 BLOCK 1024 BLANK S\" : SQ DUP * ;\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n7 SQ .\n",
" ok\nok> 49 ok\nok> ", 1 },
{ "30 BLOCK 1024 BLANK S\" 1 2 NOSUCH 3\" 30 BLOCK SWAP CMOVE UPDATE 30 LOAD\n.S\n",
"UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> <2> 1 2 \n ok\nok> ", 1 },
{ "20 BLOCK 16 65 FILL EMPTY-BUFFERS 20 BLOCK C@ .\n",
"0 ok\nok> ", 1 },
{ "20 BLOCK 1024 66 FILL UPDATE FLUSH 20 BLOCK C@ .\n",
"66 ok\nok> ", 1 },
{ "20 BLOCK 1024 BLANK 66 20 BLOCK C! UPDATE 21 BLOCK DROP 22 BLOCK DROP\n20 BLOCK C@ .\n",
" ok\nok> 66 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", "qmath.v4", "blocks.v4", "log.v4", "acl.v4" };
CHECK(host_load(&tx, &n, files, 14), "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; }
img.line = v4_text_word(&tx, "(LINE)");
img.idle = v4_text_word(&tx, "(IDLE)");
img.line_status = LINE_STATUS;
img.tib = TIB;
img.tib_bytes = 1025u;
img.span = SPAN;
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(v4_line_done(&n, &img) && n.console_len == 0, "the node is idle and has printed nothing: the prompt is its host's");
CHECK(run_line(5000) == 1 && last_steps == 0, "and goes on waiting to be handed a line");
CHECK(canary_under_expect(), "with the data stack as it found it");
(void)v4_exec_step_word(&n, &es, &h);
CHECK(v4_line_done(&n, &img), "it stays idle however long it is run");
/* ---- 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);
}
/* 76 characters after ." and a space make a line of 80. That was the most
* the node's own QUERY would take; a line the host hands over is whole. */
{
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> ", 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");
}
/* ---- a line is handed over whole, up to 1024 characters: a block, as v3 ---- */
boot();
{
static char line[1100];
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), "ABCD ok\nok> "), "a line of 100 characters is one line");
boot();
memset(line, ' ', 1024);
memcpy(line, "65 EMIT", 7);
memcpy(line + 1017, "66 EMIT", 7);
line[1024] = '\n'; line[1025] = 0;
CHECK(is(say(line), "AB ok\nok> "), "a line of 1024 characters is interpreted to its end");
boot();
memset(line, ' ', 1025);
memcpy(line, "65 EMIT", 7);
line[1025] = '\n'; line[1026] = 0;
CHECK(is(say(line), "(line too long)"), "one of 1025 is not taken: the node's input buffer holds a block");
CHECK(v4_line_done(&n, &img) && n.console_len == 0, "and nothing of it was run");
}
/* ---- 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");
}
/* ---- blocks: text loaded from storage ---- */
boot_bare();
put_block(5, "65 EMIT 66 EMIT");
CHECK(is(say("5 LOAD 67 EMIT BLK @ .\n"), "ABC0 ok\nok> "), "LOAD interprets the block and then the rest of the line");
put_block(6, "BLK @ . 7 LOAD BLK @ .");
put_block(7, "BLK @ . 68 EMIT");
CHECK(is(say("6 LOAD BLK @ .\n"), "6 7 D6 0 ok\nok> "), "a block may LOAD another; BLK is the block being interpreted");
put_block(8, "65 EMIT 9 LOAD 66 EMIT");
put_block(9, "67 EMIT 10 LOAD 68 EMIT");
put_block(10, "69 EMIT");
CHECK(is(say("8 LOAD\n"), "ACEDB ok\nok> "), "three deep, with two buffers: each block is fetched again when it is come back to");
put_block(11, ": W1 1 ; -->");
put_block(12, ": W2 W1 1+ ; W2 . -->");
put_block(13, "W2 W2 + .");
CHECK(is(say("11 LOAD 70 EMIT\n"), "2 4 F ok\nok> "), "--> goes on with the next block");
CHECK(is(say("11 13 THRU 9 8 THRU 71 EMIT\n"), "2 4 2 4 4 G ok\nok> "), "THRU loads each in turn (here the --> chain from 11 and 12, then 13); an empty range loads nothing");
memset(disk + 14 * V4_BLOCK_BYTES, ' ', V4_BLOCK_BYTES);
memcpy(disk + 14 * V4_BLOCK_BYTES, "65 EMIT \\ 66 EMIT and the rest of this line", 43);
memcpy(disk + 14 * V4_BLOCK_BYTES + 64, "67 EMIT ( a comment", 19);
memcpy(disk + 14 * V4_BLOCK_BYTES + 128, "over two lines ) 68 EMIT : LONGDEF", 34);
memcpy(disk + 14 * V4_BLOCK_BYTES + 192, "69 EMIT ; LONGDEF", 17);
CHECK(is(say("14 LOAD\n"), "ACDE ok\nok> "), "in a block \\ skips to the next 64-character line; ( and : run across lines");
put_block(15, "1 16 LOAD 2");
put_block(16, "3 NOSUCH 4");
CHECK(is(say("15 LOAD 99 .\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> "), "an error in a loaded block ends everything");
CHECK(is(say("BLK @ . .S\n"), "0 <2> 1 3 \n ok\nok> ") && n.mem[SRC] == TIB, "and the terminal is the input again");
put_block(17, ": HALFDONE 1 2");
CHECK(is(say("17 LOAD\n"), " ok\nok> ") && n.mem[STATE] != 0 && is(say("+ ; HALFDONE .\n"), "3 ok\nok> "), "a definition begun in a block can be finished at the terminal");
/* errors */
CHECK(is(say("ABORT\n"), " ok\nok> "), "(an empty stack)");
CHECK(is(say("7 0 BLOCK 65 EMIT\n"), "Block out of range\n ERROR\nok> ") && is(say("-1 BLOCK\n"), "Block out of range\n ERROR\nok> ")
&& is(say("64 BLOCK\n"), "Block out of range\n ERROR\nok> ") && is(say("63 BLOCK DROP .S\n"), "<1> 7 \n ok\nok> "), "a block number below 1 or past the device's last");
CHECK(is(say("0 LOAD\n"), "Block out of range\n ERROR\nok> ") && is(say("-5 LOAD\n"), "Block out of range\n ERROR\nok> ")
&& is(say("0 BUFFER\n"), "Block out of range\n ERROR\nok> ") && is(say("99 LIST\n"), "Block out of range\n ERROR\nok> "), "LOAD, BUFFER and LIST the same");
CHECK(is(say("-->\n"), "No block is being loaded\n ERROR\nok> ") && is(say("65 EMIT\n"), "A ok\nok> "), "--> at the terminal");
put_block(18, "1 99 LOAD 2");
CHECK(is(say("ABORT\n"), " ok\nok> "), "(an empty stack)");
CHECK(is(say("18 LOAD\n.S\n"), "Block out of range\n ERROR\nok> <1> 1 \n ok\nok> "), "a block that loads one that is not there");
/* ---- blocks: what is written, and when ---- */
boot_bare();
CHECK(is(say("3 BLOCK 1024 BLANK 72 3 BLOCK C! 73 3 BLOCK 1023 + C! UPDATE\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 0,
"an UPDATEd block is not written yet");
CHECK(is(say("FLUSH\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'H' && disk[3 * V4_BLOCK_BYTES + 1] == ' ' && disk[3 * V4_BLOCK_BYTES + 1023] == 'I'
&& disk[2 * V4_BLOCK_BYTES + 1023] == 0 && disk[4 * V4_BLOCK_BYTES] == 0, "FLUSH writes it, all 1024 bytes and no others");
CHECK(is(say("74 3 BLOCK C! UPDATE 4 BLOCK DROP\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'H', "with two buffers a second block does not disturb it");
CHECK(is(say("5 BLOCK DROP\n"), " ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'J', "a third takes its buffer, and it is written first");
CHECK(is(say("3 BLOCK C@ . 75 3 BLOCK C! UPDATE EMPTY-BUFFERS FLUSH 3 BLOCK C@ .\n"), "74 74 ok\nok> ") && disk[3 * V4_BLOCK_BYTES] == 'J',
"EMPTY-BUFFERS forgets a change without writing it");
CHECK(is(say("76 3 BLOCK C! 5 BLOCK DROP 6 BLOCK DROP 3 BLOCK C@ .\n"), "74 ok\nok> "), "a change without UPDATE is lost when the buffer is taken");
CHECK(is(say("3 BLOCK 4 BLOCK 1024 CMOVE UPDATE SAVE-BUFFERS\n"), " ok\nok> ") && memcmp(disk + 3 * V4_BLOCK_BYTES, disk + 4 * V4_BLOCK_BYTES, V4_BLOCK_BYTES) == 0
&& disk[4 * V4_BLOCK_BYTES] == 'J', "two blocks in memory at once: one copied to the other");
put_block(40, "this is on the device");
CHECK(is(say("40 BUFFER 1024 65 FILL UPDATE FLUSH\n"), " ok\nok> ") && disk[40 * V4_BLOCK_BYTES] == 'A' && disk[40 * V4_BLOCK_BYTES + 1023] == 'A',
"BUFFER gives a buffer for a block without reading it");
{
v4_cell k, wide = 0;
(void)say("3 BLOCK DROP\n");
for (k = 0; k < 2 * 256; k++) if ((v4_ucell)n.mem[BUF0_W + k] > 0xFFFFFFFFu) wide = 1;
CHECK(!wide, "a block's bytes are four to a cell at every cell width");
}
{
v4_cell before[8], k;
CHECK(is(say("VOCABULARY KEEP KEEP DEFINITIONS : KEPT 75 EMIT ; FORTH DEFINITIONS\n"), " ok\nok> "), "a vocabulary, before blocks are listed and loaded");
for (k = 0; k < 8; k++) before[k] = n.mem[TOP - 56 + k]; /* the cells around (Q)'s old place */
put_block(41, "66 EMIT");
(void)say("41 LIST 41 LOAD\n");
for (k = 0; k < 8; k++) CHECK(n.mem[TOP - 56 + k] == before[k], "LIST and LOAD leave cell TOP-%d alone", (int)(56 - k));
CHECK(is(say("KEEP KEPT FORTH\n"), "K ok\nok> ") && n.mem[VOC_LINK] != 0, "and the vocabulary is intact");
}
CHECK(strncmp(say("50 LIST\n"), "\nBlock 50\n00: \n01: ", 81) == 0 && n.mem[SCR] == 50,
"a block of zeros lists as blanks, and SCR is the block listed");
/* ---- the editor: FORTH source, compiled by the node ---- */
boot_bare();
CHECK(load_source("editor.fth"), "editor.fth compiles, every line of it");
CHECK(is(say("ORDER .S\n"), "Search order: FORTH \nCurrent: FORTH\n<0> \n ok\nok> "), "and leaves FORTH as it found it");
{
char want[2048], blank[65];
size_t at;
unsigned k;
memset(blank, ' ', 64); blank[64] = 0;
#define SCREEN(num, ...) do { static const char *const t_[] = { __VA_ARGS__ }; \
at = (size_t)snprintf(want, sizeof want, "Screen %d:\n", num); \
for (k = 0; k < 16; k++) at += (size_t)snprintf(want + at, sizeof want - at, "%2u: %-64s\n", k, k < sizeof t_ / sizeof t_[0] ? t_[k] : ""); \
snprintf(want + at, sizeof want - at, " ok\nok> "); } while (0)
SCREEN(9, "");
CHECK(is(say("9 EDIT\n"), want), "EDIT lists the screen");
CHECK(is(say("ORDER\n"), "Search order: EDITOR FORTH\nCurrent: FORTH\n ok\nok> ") && n.mem[SCR] == 9, "and the editor's words are now found first");
CHECK(is(say("0 P first line\n"), " ok\nok> ") && is(say("1 P second, with blanks before it\n"), " ok\nok> ")
&& is(say("3 P fourth\n"), " ok\nok> ") && is(say("15 P last\n"), " ok\nok> "), "P puts text on a line");
SCREEN(9, "first line", " second, with blanks before it", "", "fourth", "", "", "", "", "", "", "", "", "", "", "", "last");
CHECK(is(say("L\n"), want), "L lists it");
CHECK(is(say("1 T 2 T\n"), " 1: second, with blanks before it \n 2: \n ok\nok> "), "T types a line");
CHECK(is(say("2 S\n"), " ok\nok> ") && is(say("2 P put in the gap\n"), " ok\nok> "), "S spreads");
SCREEN(9, "first line", " second, with blanks before it", "put in the gap", "", "fourth", "", "", "", "", "", "", "", "", "", "", "");
CHECK(is(say("L\n"), want), "the lines below move down and the last is lost");
CHECK(is(say("1 D\n"), " ok\nok> "), "D deletes");
SCREEN(9, "first line", "put in the gap", "", "fourth");
CHECK(is(say("L\n"), want), "the lines below move up");
CHECK(is(say("5 I 0 H 7 R 2 E\n"), " ok\nok> "), "I inserts the deleted line; H and R copy one; E erases one");
SCREEN(9, "first line", "put in the gap", "", "fourth", "", " second, with blanks before it", "", "first line");
CHECK(is(say("L\n"), want), "as it should be");
CHECK(is(say("0 D 0 D 0 D 0 D 0 D 15 S 15 D 0 S 0 D\n"), " ok\nok> "), "at the ends");
SCREEN(9, " second, with blanks before it", "", "first line");
CHECK(is(say("L\n"), want), "nothing is disturbed");
CHECK(disk[9 * V4_BLOCK_BYTES] == 0, "nothing has reached storage yet");
CHECK(is(say("16 T\n"), "Line out of range\n ok\nok> ") && is(say("-1 E\n"), "Line out of range\n ok\nok> ") && is(say("16 P x\n"), "Line out of range\n ok\nok> "),
"a line that is not there");
CHECK(is(say("9 EDIT\n"), want), "(ABORT left FORTH as CONTEXT; EDIT again)");
CHECK(is(say("DONE ORDER\n"), "Search order: FORTH \nCurrent: FORTH\n ok\nok> ") && memcmp(disk + 9 * V4_BLOCK_BYTES, " second, with blanks", 21) == 0
&& disk[9 * V4_BLOCK_BYTES + 128] == 'f' && disk[9 * V4_BLOCK_BYTES + 1023] == ' ', "DONE writes the screen and goes back to FORTH");
/* text typed into a screen is a programme */
CHECK(is(say("20 EDIT\n"), blank_screen(20)) && is(say("0 P : HELLO .\" Hello from a block\" ;\n"), " ok\nok> ")
&& is(say("1 P HELLO \\ and say it\n"), " ok\nok> ") && is(say("2 P 3 4 + .\n"), " ok\nok> ") && is(say("DONE 20 LOAD\n"), "Hello from a block7 ok\nok> "),
"a screen that has been edited can be loaded");
CHECK(is(say("9 21 COPY 21 LIST\n"), out) && strstr(out, "Block 21\n00: second, with blanks before it") && strstr(out, "02: first line "), "COPY copies a screen");
CHECK(is(say("FLUSH\n"), " ok\nok> ") && memcmp(disk + 21 * V4_BLOCK_BYTES, disk + 9 * V4_BLOCK_BYTES, V4_BLOCK_BYTES) == 0, "and the copy reaches storage");
/* each change on its own reaches storage */
CHECK(is(say("30 EDIT\n"), blank_screen(30)) && is(say("0 P only this\n"), " ok\nok> ") && is(say("DONE\n"), " ok\nok> ")
&& memcmp(disk + 30 * V4_BLOCK_BYTES, "only this ", 10) == 0, "P alone is written");
CHECK(is(say("30 EDIT\n"), out) && is(say("0 E DONE\n"), " ok\nok> ") && disk[30 * V4_BLOCK_BYTES] == ' ', "E alone is written");
/* D and I with every line in use */
CHECK(is(say("31 EDIT\n"), blank_screen(31)), "another screen");
for (k = 0; k < 16; k++) {
char line[32];
snprintf(line, sizeof line, "%u P line %c\n", k, 'A' + k);
CHECK(is(say(line), " ok\nok> "), "line %u", k);
}
CHECK(is(say("3 D\n"), " ok\nok> "), "delete line 3 of a full screen");
SCREEN(31, "line A", "line B", "line C", "line E", "line F", "line G", "line H", "line I", "line J", "line K", "line L", "line M", "line N", "line O", "line P", "");
CHECK(is(say("L\n"), want), "every line below moved up, the last is blank");
CHECK(is(say("1 I\n"), " ok\nok> "), "insert the deleted line at 1");
SCREEN(31, "line A", "line D", "line B", "line C", "line E", "line F", "line G", "line H", "line I", "line J", "line K", "line L", "line M", "line N", "line O", "line P");
CHECK(is(say("L DONE\n"), want), "every line from 1 moved down");
CHECK(is(say("21 EDIT\n"), out) && is(say("WIPE N\n"), blank_screen(22)) && is(say("B\n"), blank_screen(21)), "WIPE blanks it; N and B move to the next and back");
CHECK(is(say("99 EDIT\n"), "Block out of range\n ERROR\nok> ") && n.mem[SCR] == 21, "EDIT of a block that is not there");
/* v3's three, in FORTH */
CHECK(is(say("FORTH 9 SCR ! 0 L 3 L\n"), " second, with blanks before it \n \n ok\nok> "),
"FORTH's L shows a line, as v3's");
CHECK(is(say("S\" a much longer line than hello\" 3 S\n"), " ok\nok> ")
&& is(say("S\" hello world\" 3 S 3 L\n"), "hello world \n ok\nok> "), "and S sets one from a string, blanks after it");
SCREEN(9, " second, with blanks before it", "", "first line", "hello world");
CHECK(is(say("SHOW\n"), want), "and SHOW shows the screen");
CHECK(is(say("7 PAD 3 16 S\n"), "Line out of range\n ok\nok> "), "a line out of range");
#undef SCREEN
}
/* ---- SEE: FORTH source too ---- */
boot_bare();
CHECK(load_source("tools.fth"), "tools.fth compiles, every line of it");
CHECK(is(say(": SQ DUP * ; SEE SQ\n"), ": SQ\n dup call * \n ; \n ok\nok> "), "a definition: an in-line word, a call by name, the return");
CHECK(is(say("SEE DUP\n"), ": DUP\n dup ; \n ok\nok> ") && is(say("SEE EMIT\n"), out) && strncmp(out, ": EMIT\n @p ", 12) == 0 && strstr(out, " b! !b ; \n"),
"the capsule's own words; a literal's value follows its @p");
CHECK(is(say("VARIABLE V 7 V ! SEE V\n"), ": V\n data: 7 \n ok\nok> ") && is(say("5 CONSTANT K SEE K\n"), ": K\n data: 5 \n ok\nok> "), "a variable and a constant show what they hold");
CHECK(is(say(": IM 1 ; IMMEDIATE SEE IM\n"), ": IM\n @p 1 ; \nIMMEDIATE\n ok\nok> "), "an immediate word says so");
CHECK(is(say(": ST .\" hi\" 300 + ; SEE ST\n"), ": ST\n call (.\") \"hi\" \n @p 300 + ; \n ok\nok> "), "text in a definition is shown as text, and the code after it as code");
CHECK(is(say(": S3 S\" abcdefg\" 0 ABORT\" x\" ; SEE S3\n"), ": S3\n call (S\") \"abcdefg\" \n @p 0 call (ABORT\") \"x\" \n ; \n ok\nok> "), "S\" and ABORT\" the same");
{
/* branches: the addresses are this node's, so they are read back rather than written here */
const char *o = say(": AB DUP 0< IF NEGATE THEN ; SEE AB\n");
long a1, a2;
CHECK(sscanf(o, ": AB\n dup call 0< \n if %ld \n drop inv @p 1 + \n jump %ld \n drop \n ; \n ok", &a1, &a2) == 2 && a2 == a1 + 1
&& a1 > (long)DICT_W && a1 < (long)DICT_END_W, "IF and THEN: the if goes to the drop, the jump to the word after it");
CHECK(is(say("7 AB -7 AB + .\n"), "14 ok\nok> "), "(and the word works)");
o = say(": LP 10 0 DO I . LOOP ; SEE LP\n");
CHECK(strstr(o, ": LP\n @p 10 @p 0 over push push drop \n pop dup push \n call . \n") == o && strstr(o, "\n drop drop drop ; \n ok\nok> "),
"a loop runs to its last return, past the returns inside it");
o = say("SEE SEE\n");
CHECK(strstr(o, ": SEE\n call FIND \n dup call 0= \n call (ABORT\") \"SEE: not found\" \n call (.\") \": \" \n") == o
&& strstr(o, "call (SEE-CODE) ") && strstr(o, "\"IMMEDIATE\" \n call CR \n") && strlen(o) < 700, "SEE shows itself");
}
CHECK(is(say(": S4 .\" abcd\" 65 EMIT ; SEE S4\n"), ": S4\n call (.\") \"abcd\" \n @p 65 call EMIT \n ; \n ok\nok> "), "text that fills its last cell but for the count");
CHECK(is(say("SEE *\n"), out) && strstr(out, " +* unext drop drop a ; \n"), "the longest opcode name, in the capsule's multiply");
CHECK(is(say(": LG LOG-WARN\" look\" 65 EMIT ; SEE LG\n"), ": LG\n @p 1 call (LOG\") \"look\" \n @p 65 call EMIT \n ; \n ok\nok> "), "a logged message is shown as text, after its level");
CHECK(is(say("SEE NOSUCH\n"), "SEE: not found\n ok\nok> ") && is(say("SEE\n"), "SEE: not found\n ok\nok> "), "a word that is not there");
CHECK(is(say("(.\")\n"), "(.\"): compile-only\n ERROR\nok> ") && is(say("(S\")\n"), "(S\"): compile-only\n ERROR\nok> "), "the string run-time words have names but cannot be run from the prompt");
/* ---- access control with its policy loaded: ACL.fth, FORTH source ---- */
boot_bare();
CHECK(load_source("ACL.fth"), "ACL.fth compiles, every line of it");
CHECK(strstr(out, "\033[32mINFO: \033[0mACL: active\n") == out && n.mem[ACL_HOOK] != 0, "and its last line switches access control on");
CHECK(is(say(": FOO 65 EMIT ; FOO ' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n"), "A256 A255 ok\nok> "), "a word's first use is rechecked and earns it a TTL, which is then counted down");
CHECK(is(say(": SFOO 66 EMIT ; ' SFOO ACL-STRICT SFOO SFOO ' SFOO ACL-TTL@ .\n"), "BB0 ok\nok> ") && is(say("' SFOO ACL-MODE@ .\n"), "1 ok\nok> "),
"a strict word is rechecked every time: its TTL stays 0");
CHECK(is(say("' SFOO ACL-TTL-MODE SFOO ' SFOO ACL-TTL@ . ' SFOO ACL-MODE@ .\n"), "B256 0 ok\nok> "), "and can be put back in TTL mode");
CHECK(is(say("' ACL-RECHECK ACL-PINNED? . ' ACL-BOOT ACL-PINNED? .\n"), "-1 -1 ok\nok> ") && is(say("' ACL-INIT-PRIMITIVES ACL-PINNED? .\n"), "-1 ok\nok> "),
"the policy's own words are pinned");
CHECK(is(say("0 ' ACL-RECHECK ACL-ALLOW! ' ACL-RECHECK ACL-STRICT ' ACL-RECHECK ACL-ALLOW@ .\n"), "-1 ok\nok> ")
&& is(say("' ACL-RECHECK ACL-MODE@ . FOO\n"), "0 A ok\nok> "), "so they cannot be denied or changed");
CHECK(is(say("0 ' FOO ACL-ALLOW! 67 EMIT FOO 68 EMIT\n"), "C\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> "), "a denied word is refused while its TTL lasts");
CHECK(is(say("0 ' FOO ACL-TTL! FOO\n"), "A ok\nok> "), "and when its TTL runs out the policy is asked again: this one allows");
CHECK(is(say(": NOFOO DUP ['] FOO = IF 0 SWAP ACL-ALLOW! ELSE ACL-RECHECK THEN ;\n"), " ok\nok> ")
&& is(say("' NOFOO ACL-HOOK ! 0 ' FOO ACL-TTL!\n"), " ok\nok> "), "a policy that denies one word");
CHECK(is(say("69 EMIT FOO\n"), "E\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ") && is(say("SFOO : G FOO ;\n"), "B\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ")
&& is(say("1 2 + . SFOO\n"), "3 B ok\nok> "), "that word is refused, interpreted or compiled, and nothing else is");
CHECK(is(say("1 2 HERMES-CHANNEL-OPEN? . ACL-CA-KEY-LO . ' DUP ACL-ENTRY ' DUP = .\n"), "1 0 -1 ok\nok> "), "the rest of v3's policy file is there");
CHECK(is(say("COLD\n"), "FORTH-79 Cold Start\nSystem initialized.\n ok\nok> ") && n.mem[ACL_HOOK] == 0 && is(say("ACL-BOOT\n"), "UNKNOWN WORD: 'ACL-BOOT'\n ERROR\nok> "),
"COLD takes the policy away with everything else that was loaded");
/* ---- the small system words ---- */
boot_bare();
CHECK(is(say("79-STANDARD .S\n"), "<0> \n ok\nok> "), "79-STANDARD is satisfied, and says nothing");
{
char want[64];
snprintf(want, sizeof want, "StarForth v4.0.0 F18 %d-bit\n ok\nok> ", V4_CELL_BITS);
CHECK(is(say("VERSION\n"), want), "VERSION");
}
CHECK(is(say("65 EMIT PAGE 66 EMIT\n"), "A\x1b[2J\x1b[HB ok\nok> "), "PAGE, as v3");
CHECK(is(say(": KEEPME 1 ; 1 2 3 WARM 65 EMIT\n.S KEEPME .\n"), "FORTH-79 Warm Start\nSystem restarted.\n ok\nok> <0> \n1 ok\nok> "), "WARM empties the stacks and keeps the dictionary");
{
v4_cell dp = n.mem[BOOT_CELLS];
CHECK(is(say("VOCABULARY VV VV DEFINITIONS : INVV 1 ; HEX 20 BLOCK DROP UPDATE 5 SCR !\n"), " ok\nok> ")
&& is(say("4 LOG-LEVEL!\n"), " ok\nok> "), "a vocabulary, a base, a block, a screen, a log level");
CHECK(is(say("1 2 COLD 65 EMIT\n"), "FORTH-79 Cold Start\nSystem initialized.\n ok\nok> "), "COLD says so");
CHECK(n.mem[DP] == dp && n.mem[LATEST] == capsule_latest && n.mem[CONTEXT] == LATEST && n.mem[CURRENT] == LATEST && n.mem[VOC_LINK] == 0
&& n.mem[BASE] == 10 && n.mem[SCR] == 0 && n.mem[BVARS] == 0 && n.mem[FENCE] == dp / 4 && n.mem[LOG_LEVEL] == 2, "and everything is as the loader left it");
CHECK(is(say("KEEPME\n"), "UNKNOWN WORD: 'KEEPME'\n ERROR\nok> ") && is(say("VV\n"), "UNKNOWN WORD: 'VV'\n ERROR\nok> ")
&& is(say(".S : NEW 16 . ; NEW\n"), "<0> \n16 ok\nok> "), "what was defined is gone, and the system works");
}
/* deferred words */
boot_bare();
CHECK(is(say("DEFER FOO : BAR 65 EMIT ; ' BAR IS FOO FOO\n"), "A ok\nok> "), "a deferred word does what it is given");
CHECK(is(say("DEFER@ FOO ' BAR = .\n"), "-1 ok\nok> "), "DEFER@ leaves it");
CHECK(is(say(": BAZ 66 EMIT ; : U FOO FOO ; U ' BAZ IS FOO U\n"), "AABB ok\nok> "), "a word that uses it follows the change");
CHECK(is(say(": SETB ['] BAR IS FOO ; : GET DEFER@ FOO ; SETB FOO GET ' BAR = .\n"), "A-1 ok\nok> "), "IS and DEFER@ in a definition");
CHECK(is(say("7 DEFER QUX QUX 65 EMIT\n.S\n"), "Deferred word not set\n ERROR\nok> <1> 7 \n ok\nok> "), "a deferred word with nothing set");
CHECK(is(say(": D3 1 2 3 ; ' D3 IS QUX QUX + + .\n"), "6 ok\nok> ") && is(say("DEFER\n"), "Name missing\n ERROR\nok> ") && is(say("' BAR IS NOSUCH\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> "),
"its stack effect is the word's; and the errors");
{
/* a deferred word is no deeper than the word it runs */
char line[64];
CHECK(is(say("VARIABLE V VARIABLE C DEFER RR\n"), " ok\nok> ")
&& is(say(": R1 C @ 1- DUP C ! IF RR EXIT THEN 65 EMIT ; ' R1 IS RR\n"), " ok\nok> "), "a word that runs itself through a deferred word");
snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)(V4_RET_DEPTH - 4u));
CHECK(is(say(line), "A ok\nok> "), "each level takes one return entry, as a plain call does");
snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)V4_RET_DEPTH);
CHECK(is(say(line), "Return stack overflow\n ERROR\nok> "), "and too many is an overflow, as for any word");
}
/* ---- vocabularies (FORTH-79) ---- */
boot_bare();
CHECK(is(say("CONTEXT @ CURRENT @ = . ORDER\n"), "-1 Search order: FORTH \nCurrent: FORTH\n ok\nok> "), "at switch-on there is FORTH");
CHECK(is(say("VOCABULARY ANIMALS ANIMALS DEFINITIONS : CAT 65 EMIT ; CAT FORTH CAT\n"), "AUNKNOWN WORD: 'CAT'\n ERROR\nok> "),
"a word defined in a vocabulary is found there and not in FORTH");
CHECK(is(say("ORDER\n"), "Search order: FORTH \nCurrent: ANIMALS\n ok\nok> "), "FORTH is CONTEXT; ANIMALS is still CURRENT");
CHECK(is(say("ANIMALS CAT 1 2 + . ORDER\n"), "A3 Search order: ANIMALS FORTH\nCurrent: ANIMALS\n ok\nok> "), "with ANIMALS as CONTEXT, FORTH is searched after it");
CHECK(is(say(": DUP 66 EMIT ; DUP FORTH 5 DUP . . ANIMALS DUP\n"), "B5 5 B ok\nok> "), "a name in both: each vocabulary has its own");
CHECK(is(say("FORTH DEFINITIONS VOCABULARY PLANTS PLANTS DEFINITIONS : CAT 67 EMIT ; CAT\n"), "C ok\nok> "), "a second vocabulary with the same name in it");
CHECK(is(say("ANIMALS CAT PLANTS CAT FORTH DEFINITIONS\n"), "AC ok\nok> "), "each finds its own");
CHECK(is(say("ANIMALS WORDS PLANTS WORDS FORTH\n"), "DUP CAT \nCAT \n ok\nok> "), "WORDS lists the CONTEXT vocabulary");
CHECK(is(say("ANIMALS CONTEXT @ CURRENT @ = . : X 1 ; CONTEXT @ CURRENT @ = .\n"), "0 -1 ok\nok> "), ": makes the CURRENT vocabulary CONTEXT");
CHECK(is(say(": T1 ANIMALS ; : T2 FORTH 68 EMIT ; T1 CAT T2 ORDER\n"), "ADSearch order: ANIMALS FORTH\nCurrent: FORTH\n ok\nok> "),
"a vocabulary's name can be compiled; FORTH is immediate");
CHECK(is(say("VOCABULARY\nFORTH\n"), "Name missing\n ERROR\nok> ok\nok> "), "VOCABULARY needs a name");
/* FORGET across vocabularies */
boot_bare();
CHECK(is(say("VOCABULARY V1 V1 DEFINITIONS : A1 1 ; FORTH DEFINITIONS : B1 2 ;\n"), " ok\nok> ")
&& is(say("V1 DEFINITIONS : A2 3 ; FORTH DEFINITIONS\n"), " ok\nok> "), "words in two vocabularies, defined turn about");
CHECK(is(say("FORGET B1 V1 A1 . A2\n"), "1 UNKNOWN WORD: 'A2'\n ERROR\nok> "), "FORGET takes what was defined later out of every vocabulary");
CHECK(is(say("B1\n"), "UNKNOWN WORD: 'B1'\n ERROR\nok> ") && is(say("V1 DEFINITIONS : A3 4 ; A1 A3 + . FORTH DEFINITIONS\n"), "5 ok\nok> "), "and the vocabulary goes on");
{
v4_cell dp;
CHECK(is(say("HERE . \n"), out) && n.mem[VOC_LINK] != 0, "(one vocabulary)");
dp = n.mem[DP];
CHECK(is(say("VOCABULARY V2 V2 DEFINITIONS : Z 1 ; VOCABULARY V3 ORDER\n"), "Search order: V2 FORTH\nCurrent: V2\n ok\nok> "), "a vocabulary that is CONTEXT and CURRENT");
CHECK(is(say("FORGET V2 ORDER\n"), "Search order: FORTH \nCurrent: FORTH\n ok\nok> ") && n.mem[DP] == dp,
"forgotten, FORTH takes its place and the space is back");
CHECK(is(say("V2\n"), "UNKNOWN WORD: 'V2'\n ERROR\nok> ") && is(say("V3\n"), "UNKNOWN WORD: 'V3'\n ERROR\nok> ")
&& is(say("V1 A1 . FORTH : OK1 65 EMIT ; OK1\n"), "1 A ok\nok> "), "its words and the vocabulary defined inside it are gone; the rest works");
CHECK(is(say("FORGET V1 FORGET V1\n"), "UNKNOWN WORD: 'V1'\n ERROR\nok> ") && n.mem[VOC_LINK] == 0, "and with V1 forgotten there is none");
}
/* ---- 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");
}
/* ---- DUMP: v3's layout, with this node's address ---- */
{
char want[256];
size_t at;
boot_bare();
CHECK(is(say("PAD 24 ERASE PAD 16 65 FILL 126 PAD 17 + C! 200 PAD 18 + C! 127 PAD 19 + C!\n"), " ok\nok> "), "sixteen A's, a zero, a tilde, a byte above 127, a DEL");
at = (size_t)snprintf(want, sizeof want, "%0*llX: ", V4_CELL_BITS / 4, (unsigned long long)PAD);
at += (size_t)snprintf(want + at, sizeof want - at, "41 41 41 41 41 41 41 41 41 41 41 41 41 41 41 41 |AAAAAAAAAAAAAAAA|\n");
at += (size_t)snprintf(want + at, sizeof want - at, "%0*llX: ", V4_CELL_BITS / 4, (unsigned long long)PAD + 16);
at += (size_t)snprintf(want + at, sizeof want - at, "00 7E C8 7F |.~..|\n");
snprintf(want + at, sizeof want - at, " ok\nok> ");
CHECK(is(say("PAD 20 DUMP\n"), want), "a line and four bytes, in hex though BASE is ten");
CHECK(is(say("BASE @ 48 + EMIT\n"), ": ok\nok> "), "and BASE is put back");
CHECK(is(say("8 BASE ! PAD 24 DUMP DECIMAL\n"), want), "the same from octal");
}
/* ---- 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;
}
Reference in New Issue View Git Blame Copy Permalink