admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
c8dc14897c89084846b3c3ceaad4a8878a311375
LithosAnanake/v4/tests/test_host_quit.c
T
rajamesandClaude Opus 5.5 c8dc14897c feat(v4.0.0): block storage, LOAD and LIST (D-19) 
- The golden model's host node gets a block storage device: four
  memory-mapped registers (number, address, command, status), 1024-byte
  blocks as 256 cells.  tests/test_node.c.
- capsule/blocks.v4: BLOCK BUFFER UPDATE SAVE-BUFFERS EMPTY-BUFFERS LIST
  LOAD SCR BLK (FORTH-79) and v3's FLUSH THRU and -->, over two buffers.
- The text being interpreted is at the address in (SRC), which QUERY makes
  the terminal's buffer and LOAD a block's; LOAD saves and restores it, so
  blocks nest and the rest of LOAD's line runs afterwards.  WORD makes
  sure a loading block is still in a buffer before it reads.
- In a block, \ skips to the next 64-character line.
- A block number that does not exist, and --> at the terminal, are errors
  with messages (D-18).
- tests/test_host_quit.c: ten transcripts of the v3 binary; nesting three
  deep on two buffers; what reaches the device and when.

v3's LOAD drops the rest of its line, and v3 has no BLK.

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

1029 lines
72 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/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];
/* 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;
/* Run until the node has taken all its input and has been inside KEY, waiting,
* for 64 instruction words; or until `max` words. True if it is waiting. */
static int run_until_waiting(long max)
{
long steps = 0;
unsigned idle = 0;
while (steps < max && idle < 64) {
(void)v4_exec_step_word(&n, &es, &h);
steps++;
if (n.input_pos == n.input_len && n.p >= w_key && n.p < w_key_end) idle++; else idle = 0;
}
last_steps = steps;
return idle >= 64;
}
/* A node just switched on: an empty dictionary above the capsule's words,
* `depth` marked cells and the canary on the data stack, started at QUIT. */
static void boot_with(unsigned depth)
{
unsigned i;
for (v4_cell k = DICT_W; k < DICT_END_W; k++) n.mem[k] = 0;
n.mem[DP] = DICT_W * 4;
n.mem[LATEST] = capsule_latest;
n.mem[STATE] = 0;
n.mem[CFP] = CFS_W;
n.mem[BASE] = 10;
n.mem[NODE_ERROR] = 0;
n.mem[FENCE] = DICT_W;
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.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 },
/* 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 },
/* 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" };
CHECK(host_load(&tx, &n, files, 12), "the capsule assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space");
printf(" capsule: %ld words\n", (long)v4_text_here(&tx) - 16);
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
w_quit = v4_text_word(&tx, "QUIT");
w_key = v4_text_word(&tx, "KEY");
w_key_end = v4_text_word(&tx, "CR"); /* the word after KEY in core.v4 */
w_fault = v4_text_word(&tx, "(FAULTS)");
capsule_latest = v4_text_latest(&tx);
CHECK(w_key_end > w_key && w_key_end - w_key <= 12, "KEY is the few words before CR");
/* ---- switch-on ---- */
boot();
CHECK(n.console_len == 5 && memcmp(n.console, "\nok> ", 5) == 0, "QUIT starts a new line and prompts");
CHECK(n.input_pos == n.input_len, "then waits for a line");
CHECK(run_until_waiting(5000) && last_steps == 64 && n.console_len == 5, "and goes on waiting, printing nothing");
CHECK(canary_under_expect(), "with the data stack as it found it");
/* ---- the sessions ---- */
for (i = 0; i < NSCRIPT; i++) {
const transcript *t = &script[i];
boot_bare();
CHECK(is(say(t->in), t->want), "%ssession %u", t->v3 ? "v3: " : "", i);
CHECK(n.mem[STATE] == 0, "session %u ends interpreting", i);
}
/* ---- one line at a time: the node keeps its state between them ---- */
boot();
CHECK(is(say("VARIABLE V 7 V !\n"), " ok\nok> "), "a variable is set on one line");
CHECK(is(say(": SHOW V @ 48 + EMIT ;\n"), " ok\nok> "), "a word defined on the next");
CHECK(is(say("SHOW 1 V +! SHOW\n"), "78 ok\nok> "), "and both used on a third");
CHECK(is(say("1 2 3 4 5 6\n"), " ok\nok> ") && is(say("+ + + + + 48 + EMIT\n"), "E ok\nok> "), "six values wait on the stack between lines");
CHECK(is(say("SHOW"), ""), "nothing happens until the line is ended");
CHECK(is(say(" SHOW\n"), "88 ok\nok> "), "and then all of it is read");
CHECK(canary_under_expect(), "the data stack is as it was at switch-on");
/* ---- a definition over several lines, and an error in the middle of one ---- */
boot();
CHECK(is(say(": LONG\n"), " ok\nok> ") && n.mem[STATE] != 0, "a line that leaves a definition open still says ok");
CHECK(is(say("65 EMIT\n"), " ok\nok> ") && is(say("66 EMIT ;\n"), " ok\nok> ") && n.mem[STATE] == 0, "it is finished two lines later");
CHECK(is(say("LONG\n"), "AB ok\nok> "), "and runs");
CHECK(is(say(": BROKEN 1 IF\n"), " ok\nok> ") && n.mem[STATE] != 0 && n.mem[CFP] != CFS_W, "a definition with an IF open");
CHECK(is(say("NOSUCH\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W,
"an error ends it and empties the control-flow stack");
CHECK(is(say("BROKEN\n"), "UNKNOWN WORD: 'BROKEN'\n ERROR\nok> "), "and it was never defined");
CHECK(is(say("LONG\n"), "AB ok\nok> "), "what was defined before is still there");
/* ---- QUIT, ABORT and a failed line each end a definition that is open ---- */
boot();
CHECK(is(say(": IQ QUIT ; IMMEDIATE : IA ABORT ; IMMEDIATE\n"), " ok\nok> "), "QUIT and ABORT as immediate words");
CHECK(is(say(": H1 1 IF IQ\n"), "\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "QUIT while compiling stops compiling");
CHECK(is(say("65 EMIT\n"), "A ok\nok> ") && is(say("H1\n"), "UNKNOWN WORD: 'H1'\n ERROR\nok> "), "and the definition is gone");
CHECK(is(say(": H2 1 IF IA\n"), " ok\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W, "ABORT while compiling stops compiling");
CHECK(is(say("66 EMIT\n"), "B ok\nok> ") && is(say("H2\n"), "UNKNOWN WORD: 'H2'\n ERROR\nok> "), "and the definition is gone");
CHECK(is(say(": H3 1 IF [ PAD PAD -1 CMOVE ]\n"), "Negative count\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W,
"a word that raises an error while a definition is open ends it");
CHECK(is(say("67 EMIT\n"), "C ok\nok> ") && is(say("H3\n"), "UNKNOWN WORD: 'H3'\n ERROR\nok> "), "and the definition is gone");
CHECK(is(say(": H4 68 EMIT ; H4\n"), "D ok\nok> "), "the next definition compiles and runs");
/* ---- an address outside memory (D-14): a message, ERROR, and the prompt ---- */
{
static const char *const lines[] = {
"65 EMIT -1 @ 66 EMIT\n", "65 EMIT 5 -1 ! 66 EMIT\n", "65 EMIT 16384 @ 66 EMIT\n", "65 EMIT 5 16384 ! 66 EMIT\n",
"65 EMIT 99999999 C@ 66 EMIT\n", "65 EMIT 7 -4 C! 66 EMIT\n", "65 EMIT -1 EXECUTE 66 EMIT\n", "65 EMIT 1 -1 +! 66 EMIT\n",
"65 EMIT PAD -8 4 CMOVE 66 EMIT\n", "65 EMIT -9 COUNT 66 EMIT\n", "65 EMIT -9 3 TYPE 66 EMIT\n",
": F0 -1 @ ; : F1 F0 ; : F2 F1 ; : F3 65 EMIT F2 66 EMIT ; F3 67 EMIT\n",
": G0 9 0 DO I 3 = IF 0 -1 ! THEN LOOP ; : G1 65 EMIT G0 66 EMIT ; G1\n",
};
boot();
for (i = 0; i < sizeof lines / sizeof lines[0]; i++) {
unsigned before = n.faults;
CHECK(is(say(lines[i]), "AAddress out of range\n ERROR\nok> "), "fault %u", i);
CHECK(n.faults == before + 1 && !n.stopped && n.mem[STATE] == 0, "fault %u: one fault, and the node is at its prompt", i);
CHECK(is(say("1 2 + 48 + EMIT\n"), "3 ok\nok> "), "and the next line runs, after fault %u", i);
}
CHECK(is(say("16383 @ DROP 0 @ DROP 67 EMIT\n"), "C ok\nok> "), "the first and last words of memory are not faults");
CHECK(is(say(": H5 1 IF [ -1 @ ]\n"), "Address out of range\n ERROR\nok> ") && n.mem[STATE] == 0 && n.mem[CFP] == CFS_W,
"a fault while a definition is open ends it");
CHECK(is(say("H5\n"), "UNKNOWN WORD: 'H5'\n ERROR\nok> ") && is(say(": H6 68 EMIT ; H6\n"), "D ok\nok> "), "and the next definition compiles and runs");
CHECK(v4_node_guards_intact(&n), "guards intact after the faults");
}
/* ---- the text is in the definition, a counted string after the call ---- */
boot();
for (v4_cell k = n.mem[DP] / 4; k < DICT_END_W; k++) n.mem[k] = (v4_cell)-1; /* memory that was not zero */
CHECK(is(say(": T .\" ABCDE\" ;\n"), " ok\nok> "), "a word that prints five characters");
{
v4_cell xt = n.mem[LATEST];
CHECK((uint32_t)n.mem[xt + 1] == (5u | ('A' << 8) | ('B' << 16) | ((uint32_t)'C' << 24)) && (uint32_t)n.mem[xt + 2] == ('D' | ('E' << 8)),
"the count and the characters follow the call, four to a cell, zeros after");
CHECK((n.mem[DP] + 3) / 4 == xt + 4, "then the rest of the word: four cells in all");
}
/* every length from 0 to 12: the word goes on at the right cell */
for (i = 0; i <= 12; i++) {
char line[96], want[32];
boot();
snprintf(line, sizeof line, ": T 60 EMIT .\" %.*s\" 62 EMIT ; T\n", (int)i, "abcdefghijkl");
snprintf(want, sizeof want, "<%.*s> ok\nok> ", (int)i, "abcdefghijkl");
CHECK(is(say(line), want), ".\" with %u characters", i);
snprintf(line, sizeof line, ": U 60 EMIT ABORT\" %.*s\" 62 EMIT ; 0 U 1 U 33 EMIT\n", (int)i, "abcdefghijkl");
snprintf(want, sizeof want, "<><%.*s\n ok\nok> ", (int)i, "abcdefghijkl");
CHECK(is(say(line), want), "ABORT\" with %u characters, false then true", i);
}
/* the longest: 76 characters fit an 80-character line after ." and a space.
* EXPECT stops at the 80th character, so that line's new-line is still to
* come and is read as an empty line (FORTH-79's EXPECT; see input.v4). */
{
char line[128], want[128], text[80];
for (i = 0; i < 76; i++) text[i] = (char)('#' + i); /* no " in it */
text[76] = 0;
boot();
snprintf(line, sizeof line, ".\" %s\"\n", text);
snprintf(want, sizeof want, "%s ok\nok> ok\nok> ", text);
CHECK(is(say(line), want), "a string that fills an 80-character line");
boot();
snprintf(line, sizeof line, ".\" %s\"\n", text + 1);
snprintf(want, sizeof want, "%s ok\nok> ", text + 1);
CHECK(is(say(line), want), "and one that fills a 79-character line");
}
/* ---- QUERY takes 80 characters; what is over is the next line ---- */
boot();
{
char line[128];
memset(line, ' ', 100);
memcpy(line, "65 EMIT", 7);
memcpy(line + 70, "66 EMIT", 7);
memcpy(line + 80, "67 EMIT 68 EMIT", 15);
line[100] = '\n'; line[101] = 0;
CHECK(is(say(line), "AB ok\nok> CD ok\nok> "), "a line of 100 characters is read as 80 and 20");
}
/* ---- ABORT and QUIT from deep in a programme, again and again ---- */
boot();
CHECK(is(say(": A0 ABORT ; : A1 A0 ; : A2 A1 ; : A3 A2 ; : A4 A3 ; : A5 A4 ;\n"), " ok\nok> "), "ABORT six calls down");
CHECK(is(say(": Q0 QUIT ; : Q1 Q0 ; : Q2 Q1 ; : Q3 Q2 ; : Q4 Q3 ; : Q5 Q4 ;\n"), " ok\nok> "), "QUIT six calls down");
CHECK(is(say(": L0 10 0 DO I 5 = IF ABORT THEN LOOP ; : L1 3 0 DO L0 LOOP ;\n"), " ok\nok> "), "ABORT inside two loops");
for (i = 0; i < 40; i++) {
CHECK(is(say("65 EMIT A5 66 EMIT\n"), "A ok\nok> "), "ABORT from six deep, time %u", i);
CHECK(is(say("67 EMIT Q5 68 EMIT\n"), "C\nok> "), "QUIT from six deep, time %u", i);
CHECK(is(say("L1 69 EMIT\n"), " ok\nok> "), "ABORT out of two loops, time %u", i);
CHECK(is(say(": SQ DUP * ; 7 SQ EMIT\n"), "1 ok\nok> "), "and the next line compiles and runs, time %u", i);
}
CHECK(is(say("DEPTH 48 + EMIT\n"), "0 ok\nok> "), "ABORT has emptied the data stack");
/* ---- how deep words may call each other from the prompt ----
* The prompt's call of INTERPRET is one return entry, so a chain of words
* one shorter than the return stack runs, and the next is a fault. */
{
unsigned deepest = 0;
char line[64], want[16];
boot();
CHECK(is(say(": N0 1+ ;\n"), " ok\nok> "), "a word that calls nothing");
for (i = 1; i <= V4_RET_DEPTH; i++) {
snprintf(line, sizeof line, ": N%u N%u 1+ ;\n", i, i - 1u);
CHECK(is(say(line), " ok\nok> "), "and one that calls it, %u deep", i + 1u);
}
for (i = 0; i <= V4_RET_DEPTH; i++) {
snprintf(line, sizeof line, "33 N%u EMIT 33 EMIT\n", i);
snprintf(want, sizeof want, "%c! ok\nok> ", (char)(34 + i));
if (strcmp(say(line), want) != 0) break;
deepest = i + 1;
}
printf(" from the prompt, words may call each other %u deep\n", deepest);
CHECK(deepest == V4_RET_DEPTH - 1u, "a word run from the prompt has all the return stack but the prompt's one entry");
CHECK(is(out, "Return stack overflow\n ERROR\nok> "), "and one more is reported");
}
/* ---- the exits, taken with the return stack full ----
* RR runs itself through EXECUTE; each level holds one return entry, and
* EXECUTE one more while it starts the next. With C at its largest and
* one >R besides, there is room for exactly the action's own call. An
* exit that did not empty the return stack before it printed would
* overflow it. */
{
static const struct { const char *action, *want; } e[] = {
{ "1 ABORT\" x\"", "x\n ok\nok> " },
{ "5 0 PICK", "PICK: Invalid index\n ERROR\nok> " },
{ "5 0 ROLL", "ROLL: Invalid index\n ERROR\nok> " },
{ "5 0 /", "/: Division by zero\n ERROR\nok> " },
{ "5 5 0 */MOD", "*/MOD: Division by zero\n ERROR\nok> " },
{ "ABORT", " ok\nok> " },
{ "QUIT", "\nok> " },
};
char line[96];
for (i = 0; i < sizeof e / sizeof e[0]; i++) {
boot_bare();
CHECK(is(say("VARIABLE V VARIABLE C\n"), " ok\nok> "), "two variables");
snprintf(line, sizeof line, ": RR C @ 1- DUP C ! IF V @ EXECUTE EXIT THEN 1 >R %s ;\n", e[i].action);
CHECK(is(say(line), " ok\nok> "), "a word that runs itself C times and then: %s", e[i].action);
snprintf(line, sizeof line, "' RR V ! %u C ! RR\n", (unsigned)(V4_RET_DEPTH - 3u));
CHECK(is(say(line), e[i].want), "%s with the return stack full", e[i].action);
CHECK(n.faults == 0, "%s: and it was not a fault", e[i].action);
CHECK(is(say("65 EMIT\n"), "A ok\nok> "), "and the next line runs");
/* one level more and the action's own call does not fit */
snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)(V4_RET_DEPTH - 2u));
CHECK(is(say(line), "Return stack overflow\n ERROR\nok> "), "%s one level deeper is a return stack overflow", e[i].action);
}
}
/* ---- the data stack, full ----
* P1 P2 P4 P8 P16 push that many values and call nothing while they do, so
* a word can fill the stack to any depth in a short line. */
{
char line[128], want[32], fill[64];
unsigned c, bit;
#define FILL(count) do { size_t at_ = 0; fill[0] = 0; \
for (c = (count), bit = 16; bit; bit >>= 1) if (c >= bit) { at_ += (size_t)snprintf(fill + at_, sizeof fill - at_, "P%u ", bit); c -= bit; } \
for (; c >= 16; c -= 16) at_ += (size_t)snprintf(fill + at_, sizeof fill - at_, "P16 "); } while (0)
boot_bare();
CHECK(is(say(": P1 7 ; : P2 7 7 ; : P4 7 7 7 7 ; : P8 7 7 7 7 7 7 7 7 ;\n"), " ok\nok> ")
&& is(say(": P16 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 ;\n"), " ok\nok> "), "words that push 1, 2, 4, 8 and 16 values");
/* 65, then DEPTH-2 more, then n = DEPTH-1: the stack is full when PICK and ROLL start */
FILL(V4_DATA_DEPTH - 2u);
snprintf(line, sizeof line, ": PF 65 %s%u PICK >R DROP R> EMIT ABORT ; PF\n", fill, (unsigned)(V4_DATA_DEPTH - 1u));
CHECK(is(say(line), "A ok\nok> ") && n.faults == 0, "PICK of the deepest value of a full stack");
snprintf(line, sizeof line, ": RF 65 %s%u ROLL EMIT DROP DEPTH 33 + EMIT ABORT ; RF\n", fill, (unsigned)(V4_DATA_DEPTH - 1u));
snprintf(want, sizeof want, "A%c ok\nok> ", (char)(33 + V4_DATA_DEPTH - 3u));
CHECK(is(say(line), want) && n.faults == 0, "ROLL of the deepest value of a full stack");
/* exactly full is not a fault; one more is */
FILL(V4_DATA_DEPTH);
snprintf(line, sizeof line, ": F1 %s2DROP ABORT ; F1\n", fill);
CHECK(is(say(line), " ok\nok> ") && n.faults == 0, "a stack exactly full is not a fault");
snprintf(line, sizeof line, ": F2 %s7 ; F2\n", fill);
CHECK(is(say(line), "Stack overflow\n ERROR\nok> ") && n.fault_kind == V4_FAULT_DATA_OVER, "one value more is");
CHECK(is(say("DEPTH 48 + EMIT\n"), "0 ok\nok> "), "and the stack is empty afterwards");
#undef FILL
}
/* and with text printed at the bottom of the chain */
boot();
CHECK(is(say(": P0 .\" deep\" ; : P1 P0 ; : P2 P1 ; : P3 P2 ; : P4 P3 ; P4\n"), "deep ok\nok> "), ".\" five calls down");
/* ---- how many values may wait on the stack from one line to the next ---- */
{
unsigned k, most = 0;
for (k = 1; k < V4_DATA_DEPTH; k++) {
char line[4 * V4_DATA_DEPTH + 16], want[16];
size_t at = 0;
unsigned m;
boot_bare();
for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "1 ");
snprintf(line + at, sizeof line - at, "\n");
if (strcmp(say(line), " ok\nok> ") != 0) break;
for (at = 0, m = 1; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "+ ");
snprintf(line + at, sizeof line - at, "32 + EMIT\n");
snprintf(want, sizeof want, "%c ok\nok> ", (char)(32 + k));
if (strcmp(say(line), want) != 0) break;
most = k;
}
printf(" %u values may wait on the stack while the next line is typed and interpreted\n", most);
CHECK(most + 4u >= V4_DATA_DEPTH, "the prompt and the interpreter take no more than four cells of the stack");
}
/* ---- how much of the data stack a line has ---- */
{
unsigned d;
for (d = 0; d < V4_DATA_DEPTH; d++) {
unsigned k, good = 1;
boot_with(d + 1);
if (strcmp(say(": Z1 .\" x\" 1 2 + ; Z1 Z1 + 48 + EMIT\n"), "xx6 ok\nok> ") != 0) break;
if (!canary_under_expect()) break;
for (k = d + 1; k-- > 0; ) if (v4_dstack_pop(&n.ds) != (v4_cell)(0x5A000000 + k)) good = 0;
if (!good) break;
}
printf(" defining and running a word from the prompt leaves %u data cells under it untouched\n", d);
CHECK(d >= 3, "the prompt leaves room on the data stack");
}
/* ---- numbers at the ends of the range, which depend on the cell width ---- */
boot_bare();
#if V4_CELL_BITS == 32
CHECK(is(say("-1 U. -2147483648 . 2147483647 .\n"), "4294967295 -2147483648 2147483647 ok\nok> "), "the largest and smallest numbers");
CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFF ok\nok> ") && is(say("2 BASE ! -1 U. DECIMAL\n"), "11111111111111111111111111111111 ok\nok> "), "in hex and in binary");
#else
CHECK(is(say("-1 U.\n"), "18446744073709551615 ok\nok> "), "the largest number (as v3)");
CHECK(is(say("-9223372036854775808 . 9223372036854775807 .\n"), "-9223372036854775808 9223372036854775807 ok\nok> "), "the smallest and largest signed");
CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFFFFFFFFFF ok\nok> "), "in hex");
/* 64 binary digits are one more than the hold buffer's 63 (D-13): an error, and nothing is printed */
CHECK(is(say("2 BASE ! -1 U. DECIMAL\n"), "Number too long\n ERROR\nok> "), "in binary, its 64 digits are one too many");
CHECK(is(say("DECIMAL\n"), " ok\nok> "), "(back to decimal)");
CHECK(is(say("9223372036854775807 2 BASE ! U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ok\nok> "), "a 63-digit number prints whole");
#endif
/* the shifts, to the last bit */
{
char line[96], want[64];
boot_bare();
snprintf(line, sizeof line, "1 %d LSHIFT .\n", V4_CELL_BITS);
CHECK(is(say(line), "Shift count out of range\n ERROR\nok> "), "a shift by the cell's width is out of range");
snprintf(line, sizeof line, "1 %d LSHIFT 0< . -1 %d RSHIFT . -8 1 RSHIFT 2* 8 + .\n", V4_CELL_BITS - 1, V4_CELL_BITS - 1);
CHECK(is(say(line), "-1 1 0 ok\nok> "), "a shift by one less reaches the top bit, and RSHIFT brings zeros in");
snprintf(line, sizeof line, "-1 1 RSHIFT .\n");
#if V4_CELL_BITS == 32
snprintf(want, sizeof want, "2147483647 ok\nok> ");
#else
snprintf(want, sizeof want, "9223372036854775807 ok\nok> ");
#endif
CHECK(is(say(line), want), "-1 1 RSHIFT is the largest positive number");
}
/* .S works on the stack it is printing, so it needs some of it free */
{
char line[4 * V4_DATA_DEPTH + 16], want[8 * V4_DATA_DEPTH + 32];
unsigned k, m, most = 0;
for (k = 1; k < V4_DATA_DEPTH; k++) {
size_t at = 0, wt;
boot_bare();
for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "7 ");
snprintf(line + at, sizeof line - at, "\n");
if (strlen(line) > 80 || strcmp(say(line), " ok\nok> ") != 0) break;
wt = (size_t)snprintf(want, sizeof want, "<%u> ", k);
for (m = 0; m < k; m++) wt += (size_t)snprintf(want + wt, sizeof want - wt, "7 ");
snprintf(want + wt, sizeof want - wt, "\n ok\nok> ");
if (strcmp(say(".S\n"), want) != 0) break;
snprintf(want, sizeof want, "%u ok\nok> ", k);
CHECK(is(say("DEPTH .\n"), want), "after .S the %u values are still there", k);
most = k;
}
printf(" .S prints a stack of up to %u values; it needs %u cells free\n", most, (unsigned)V4_DATA_DEPTH - most);
CHECK(most + 8u >= V4_DATA_DEPTH, ".S works with all but eight cells of the stack in use");
}
/* ---- nested CASE, by value ---- */
boot_bare();
CHECK(is(say(": IN CASE 1 OF 65 ENDOF 2 OF 66 ENDOF 63 SWAP ENDCASE ;\n"), " ok\nok> ")
&& is(say(": OUT CASE 1 OF IN ENDOF 2 OF DROP 90 ENDOF DROP 33 SWAP ENDCASE EMIT ;\n"), " ok\nok> "), "a CASE that calls a CASE");
CHECK(is(say("1 1 OUT 2 1 OUT 9 1 OUT 5 2 OUT 5 7 OUT .S\n"), "AB?Z!<0> \n ok\nok> "), "every path through both");
CHECK(is(say(": NC CASE 1 OF CASE 5 OF 65 ENDOF 66 SWAP ENDCASE ENDOF 67 SWAP ENDCASE EMIT ;\n"), " ok\nok> ")
&& is(say("5 1 NC 6 1 NC 7 2 NC .S\n"), "ABC<1> 7 \n ok\nok> "), "a CASE inside a clause of a CASE");
/* ---- FORGET gives the space back, and FENCE protects ---- */
boot_bare();
{
v4_cell dp0 = n.mem[DP], latest0 = n.mem[LATEST];
CHECK(is(say(": F1 1 ; VARIABLE F2 : F3 F1 F2 ;\n"), " ok\nok> ") && n.mem[DP] > dp0, "three words");
CHECK(is(say("FORGET F1\n"), " ok\nok> ") && n.mem[DP] == dp0 && n.mem[LATEST] == latest0, "FORGET of the first puts HERE and LATEST back where they were");
CHECK(is(say(": G1 65 EMIT ; : G2 66 EMIT ;\n"), " ok\nok> ") && is(say("HERE FENCE ! : G3 67 EMIT ;\n"), " ok\nok> "), "two words, the fence, and a third");
CHECK(is(say("FORGET G2\n"), "Protected word\n ERROR\nok> ") && is(say("G1 G2 G3\n"), "ABC ok\nok> "), "a word below the fence cannot be forgotten");
CHECK(is(say("FORGET G3 G1 G2\n"), "AB ok\nok> ") && is(say("G3\n"), "UNKNOWN WORD: 'G3'\n ERROR\nok> "), "one above it can");
}
/* ---- 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");
/* ---- 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