admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ebffa6082d5702d349f7c53b3b05a0af8f4581ef
LithosAnanake/v4/tests/test_host_compile.c
T
rajamesandClaude Opus 5.5 ebffa6082d feat(v4.0.0): the host node's stacks are 32 deep (D-17) 
With the stacks counted and guarded (D-16) their size is a parameter of
the node.  The host node, which runs the interpreter and the compiler
under the user's programme, gets 32 values and 32 return entries; a mesh
node keeps the F18's 10 and 9.  Nothing else about the mechanism or any
word's definition changes.

- stack.h: V4_DATA_RING and V4_RET_RING are build parameters; the
  Makefile sets them for the host-node tests.
- tests/test_host_quit.c no longer assumes a size: it fills the stacks to
  whatever they are, and takes every exit with the return stack full.
- Measured on the host node now: 28 values on a line, 29 waiting between
  lines, words 31 deep from the prompt.

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

458 lines
25 KiB
C
Raw Blame History

/* test_host_compile.c -- the defining and compiling words, executed on the
* host node.
*
* capsule/compile.v4 and capsule/forth.v4 on top of the earlier layers: for
* the first time FORTH source text goes in and running code comes out. Each
* test hands lines of source to INTERPRET, which defines words with : and ;
* and the rest, runs them, and leaves results on the stack.
*
* The table of programmes below was run through the v3 binary on 2026-10-04
* (definitions, then the expression, then one `.` per result) and the numbers
* are what v3 printed. Two rows are not v3's: COMPILE, which v3 cannot run
* (`: C1 COMPILE DUP ; IMMEDIATE` then `: U3 C1 + ;` gives "DUP: Stack
* underflow"), and one that used NIP, which is not a v3 word.
*
* Where v4 parts from v3 here:
* - ' is FORTH-79's: the parameter field address, and compiled as a
* literal inside a definition. v3's ' parses when the definition runs.
* - what is not a word and not a number abandons the line and sets
* NODE-ERROR, after v3's UNKNOWN WORD message. What is printed is
* checked in test_host_quit.c, where the node has a console.
*/
#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, ref;
static v4_exec_state es;
static v4_heat h;
static v4_text tx, rtx;
static v4_cell w_interpret, capsule_latest;
static void put_bytes(v4_cell baddr, const void *src, unsigned len)
{
const unsigned char *s = (const unsigned char *)src;
for (unsigned i = 0; i < len; i++) {
v4_cell ba = baddr + (v4_cell)i;
unsigned sh = 8u * (unsigned)(ba & 3);
v4_ucell w = (v4_ucell)n.mem[ba >> 2];
n.mem[ba >> 2] = (v4_cell)((w & ~((v4_ucell)0xFFu << sh)) | ((v4_ucell)s[i] << sh));
}
}
/* An empty dictionary above the capsule's own words. */
static void new_session(void)
{
for (v4_cell i = DICT_W; i < DICT_END_W; i++) n.mem[i] = 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;
}
/* INTERPRET one line, as QUERY would have left it in TIB. The data stack
* starts with the canary alone; `depth` extra marked cells go under it and
* `rdepth` under the return address, for the headroom tests. True when
* INTERPRET returns. */
static int interpret_with(const char *line, unsigned depth, unsigned rdepth)
{
unsigned len = (unsigned)strlen(line), i;
put_bytes(TIB, line, len + 1u);
n.mem[SPAN] = (v4_cell)len;
n.mem[TO_IN] = 0;
n.mem[NODE_ERROR] = 0;
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);
for (i = 0; i < rdepth; i++) v4_rstack_push(&n.rs, (v4_cell)(0x6B000000 + i));
return v4_test_call(&n, &es, &h, w_interpret, 4000000) > 0;
}
static int interpret(const char *line) { return interpret_with(line, 0, 0); }
static v4_cell pop(void) { return v4_dstack_pop(&n.ds); }
static int clean(void) { return pop() == CANARY; }
static int err(void) { return n.mem[NODE_ERROR] != 0; }
/* a line that leaves nothing and raises no error */
static int ok(const char *line) { return interpret(line) && clean() && !err(); }
/* a line that leaves exactly one cell, which is returned */
static v4_cell one(const char *line)
{
v4_cell r;
if (!interpret(line) || err()) return (v4_cell)0x0BADBAD;
r = pop();
return clean() ? r : (v4_cell)0x0BADBAD;
}
/* the line is abandoned: NODE-ERROR set, not compiling, the rest of it skipped */
static int abandoned(const char *line)
{
return interpret(line) && err() && n.mem[STATE] == 0 && n.mem[TO_IN] == n.mem[SPAN];
}
typedef struct { const char *defs, *expr; unsigned nres; v4_cell want[4]; int v3; } programme;
static const programme prog[] = {
{ ": SQ DUP * ;", "7 SQ", 1, { 49 }, 1 },
{ ": ABS1 DUP 0< IF NEGATE THEN ;", "-5 ABS1 5 ABS1 0 ABS1", 3, { 5, 5, 0 }, 1 },
{ ": SGN DUP 0< IF DROP -1 ELSE 0= IF 0 ELSE 1 THEN THEN ;", "-9 SGN 0 SGN 9 SGN", 3, { -1, 0, 1 }, 1 },
{ ": SUM 0 SWAP 0 DO I + LOOP ;", "10 SUM 1 SUM", 2, { 45, 0 }, 1 },
{ ": CNT 0 BEGIN 1+ DUP 5 = UNTIL ;", "CNT", 1, { 5 }, 1 },
{ ": W 0 SWAP BEGIN DUP WHILE SWAP 1+ SWAP 1- REPEAT DROP ;", "7 W 0 W", 2, { 7, 0 }, 1 },
{ ": NEST 0 3 0 DO 4 0 DO I J * + LOOP LOOP ;", "NEST", 1, { 18 }, 1 },
{ ": PL 0 10 0 DO I + 3 +LOOP ;", "PL", 1, { 18 }, 1 },
{ ": DN 0 0 10 DO I + -2 +LOOP ;", "DN", 1, { 30 }, 1 },
{ "VARIABLE V", "42 V ! V @ 5 V +! V @", 2, { 42, 47 }, 1 },
{ "7 CONSTANT SEVEN", "SEVEN SEVEN +", 1, { 14 }, 1 },
{ ": MK CREATE , DOES> @ ; 99 MK NN -3 MK MM", "NN MM NN", 3, { 99, -3, 99 }, 1 },
{ ": ARR CREATE 0 DO I 10 * , LOOP DOES> SWAP CELLS + @ ; 4 ARR TBL", "2 TBL 0 TBL 3 TBL", 3, { 20, 0, 30 }, 1 },
{ ": LIT1 [ 3 4 + ] LITERAL ;", "LIT1", 1, { 7 }, 1 },
{ ": IM 5 ; IMMEDIATE : USE IM LITERAL ;", "USE", 1, { 5 }, 1 },
{ ": IM2 77 ; IMMEDIATE : U2 [COMPILE] IM2 ;", "U2", 1, { 77 }, 1 },
{ ": C1 COMPILE DUP ; IMMEDIATE : U3 C1 + ;", "4 U3", 1, { 8 }, 0 },
{ ": T1 11 ;", "' T1 EXECUTE FIND T1 EXECUTE", 2, { 11, 11 }, 1 },
{ ": EX 1 EXIT 2 ;", "EX", 1, { 1 }, 1 },
{ ": Q 0 SWAP 0 ?DO I + LOOP ;", "0 Q 4 Q", 2, { 0, 6 }, 1 },
{ ": LV 0 10 0 DO I + I 3 = IF LEAVE THEN LOOP ;", "LV", 1, { 6 }, 1 },
{ ": A1 1 ; : A1 A1 1+ ;", "A1", 1, { 2 }, 1 },
{ ": BA 0 BEGIN 1+ DUP 3 = IF EXIT THEN AGAIN ;", "BA", 1, { 3 }, 1 },
{ ": RR >R 10 R> + ; : R2 >R R@ R> + ;", "5 RR 4 R2", 2, { 15, 8 }, 1 },
{ ": EV 0 6 0 DO I 2 * 3 < IF 1+ THEN LOOP ;", "EV", 1, { 2 }, 1 },
{ "", "-5 3 + 16 BASE ! FF A BASE !", 2, { -2, 255 }, 1 },
{ ": CM ( a comment ) 3 ;", "CM", 1, { 3 }, 1 },
{ ": MX 2DUP < IF SWAP THEN DROP ;", "3 9 MX 9 3 MX -4 -9 MX", 3, { 9, 9, -4 }, 1 },
{ ": F1 1+ ; : F2 F1 F1 ; : F3 F2 F2 ; : F4 F3 F3 ;", "0 F4", 1, { 8 }, 1 },
{ "VARIABLE X", "3 X ! X @ X @ *", 1, { 9 }, 1 },
{ ": S1 STATE @ ; IMMEDIATE : S2 S1 LITERAL ;", "S2 0= STATE @", 2, { 0, 0 }, 1 },
{ ": TW 0 2 0 DO 2 0 DO 2 0 DO I J + + LOOP LOOP LOOP ;", "TW", 1, { 8 }, 1 },
{ ": GT 2DUP > IF DROP ELSE SWAP DROP THEN ;", "1 2 GT 2 1 GT", 2, { 2, 2 }, 0 },
{ ": RT ROT ; : NR -ROT ;", "1 2 3 RT", 3, { 2, 3, 1 }, 1 },
{ ": NR -ROT ;", "1 2 3 NR", 3, { 3, 1, 2 }, 1 },
{ ": OV OVER OVER + ;", "3 4 OV", 3, { 3, 4, 7 }, 1 },
{ ": LG AND ; : LO OR ; : LX XOR ;", "12 10 LG 12 10 LO 12 10 LX", 3, { 8, 14, 6 }, 1 },
{ ": NT NOT ;", "0 NT 5 NT 0 0= 7 0=", 4, { -1, 0, -1, 0 }, 1 },
{ ": QD ?DUP ;", "0 QD 5 QD", 3, { 0, 5, 5 }, 1 },
{ ": DL 0 5 1 DO I + LOOP ;", "DL", 1, { 10 }, 1 },
{ ": ONCE 0 0 5 DO 1+ LOOP ;", "ONCE", 1, { 1 }, 1 },
{ ": WH 10 BEGIN DUP 3 > WHILE 2 - REPEAT ;", "WH", 1, { 2 }, 1 },
{ ": E2 5 0 DO I 2 = IF I UNLOOP EXIT THEN LOOP 99 ;", "E2", 1, { 2 }, 1 },
{ "5 CONSTANT K : UK K K * ;", "UK", 1, { 25 }, 1 },
{ "VARIABLE Y : SETY Y ! ; : GETY Y @ ;", "8 SETY GETY", 1, { 8 }, 1 },
{ ": IFS 0= IF 10 ELSE 20 THEN ;", "0 IFS 1 IFS", 2, { 10, 20 }, 1 },
{ ": DEEP 1 IF 2 IF 3 IF 4 ELSE 5 THEN ELSE 6 THEN ELSE 7 THEN ;", "DEEP", 1, { 4 }, 1 },
{ ": TM 2* 2* 1- 2/ ;", "5 TM", 1, { 9 }, 1 },
{ ": NEG NEGATE ;", "7 NEG -7 NEG", 2, { -7, 7 }, 1 },
{ "", "7 2 / -7 2 / 7 -2 / -7 -2 /", 4, { 3, -3, -3, 3 }, 1 },
{ "", "7 2 MOD -7 2 MOD 7 -2 MOD -7 -2 MOD", 4, { 1, -1, 1, -1 }, 1 },
{ "", "7 2 /MOD -7 2 /MOD", 4, { 1, 3, -1, -3 }, 1 },
{ "", "7 -2 /MOD -7 -2 /MOD", 4, { 1, -3, -1, 3 }, 1 },
{ "", "100 7 3 */ -100 7 3 */", 2, { 233, -233 }, 1 },
{ "", "100 7 3 */MOD -100 7 3 */MOD", 4, { 1, 233, -1, -233 }, 1 },
{ "", "3 4 M* -3 4 M*", 4, { 12, 0, -12, -1 }, 1 },
{ "", "-5 S>D 5 S>D", 4, { -5, -1, 5, 0 }, 1 },
{ "", "0 5 / 0 5 MOD 1 1 /", 3, { 0, 0, 1 }, 1 },
{ ": D1 / ; : D2 D1 ; : D3 D2 ; : D4 D3 ;", "20 4 D4", 1, { 5 }, 1 },
{ ": E1 */MOD ; : E2 E1 ; : E3 E2 ;", "-100 7 3 E3", 2, { -1, -233 }, 1 },
{ ": E4 */ ; : E5 E4 ;", "-100 7 3 E5", 1, { -233 }, 1 },
{ ": E6 M* ; : E7 E6 ; : E8 E7 ;", "-3 4 E8", 2, { -12, -1 }, 1 },
{ ": AV 0 SWAP 0 DO I + LOOP 10 / ;", "10 AV", 1, { 4 }, 1 },
{ "", "1000000 1000000 M* 1000 M/MOD", 2, { 0, 1000000000 }, 0 },
{ "", "-7 S>D 2 M/MOD", 2, { -1, -3 }, 0 },
};
#define NPROG (sizeof prog / sizeof prog[0])
/* The code of the newest definition is word for word what the text assembler
* makes of `text` at the same address. */
static int same_code(const char *text)
{
v4_cell xt = n.mem[LATEST], end, k;
v4_node_reset(&ref);
v4_text_begin(&rtx, &ref, xt);
if (!v4_text_assemble(&rtx, "macro - push inv pop + inv endmacro\n") || !v4_text_assemble(&rtx, text) || !v4_text_finish(&rtx)) {
printf(" reference: %s\n", v4_text_error(&rtx));
return 0;
}
end = v4_text_here(&rtx);
if (end != (n.mem[DP] + 3) / 4) { printf(" lengths differ: %ld by text, %ld compiled\n", (long)(end - xt), (long)((n.mem[DP] + 3) / 4 - xt)); return 0; }
for (k = xt; k < end; k++)
if (n.mem[k] != ref.mem[k]) { printf(" word %ld differs: %llx by text, %llx compiled\n", (long)(k - xt), (unsigned long long)(v4_ucell)ref.mem[k], (unsigned long long)(v4_ucell)n.mem[k]); return 0; }
return 1;
}
int main(void)
{
unsigned i;
printf("v4 host compiler 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" };
CHECK(host_load(&tx, &n, files, 7), "the capsule assembles");
}
/* two in-line words of the test's own, to exercise the in-liner: one with
* two literals in one instruction word, one with a nop in it */
CHECK(v4_text_assemble(&tx, "header TWOLIT inline : TWOLIT 3 + 100 + ;\n"
"header HASNOP inline : HASNOP dup nop drop 7 ;\n"), "the test's in-line words: %s", v4_text_error(&tx));
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_interpret = v4_text_word(&tx, "INTERPRET");
capsule_latest = v4_text_latest(&tx);
/* ---- the interpreter alone: numbers and words that are there ---- */
new_session();
CHECK(ok(""), "an empty line does nothing");
CHECK(ok(" "), "nor a line of blanks");
CHECK(one("42") == 42 && one("-7") == -7 && one("0") == 0, "a number is left on the stack");
CHECK(interpret("1 2 3") && !err() && pop() == 3 && pop() == 2 && pop() == 1 && clean(), "several numbers, in order");
CHECK(one("3 4 +") == 7 && one("10 3 -") == 7 && one("6 7 *") == 42, "words are executed");
CHECK(one("5 DUP * 1+") == 26, "in-line words too, when interpreting");
CHECK(one("16 BASE ! FF A BASE !") == 255, "numbers are read in the current BASE");
CHECK(one("( a comment ) 9 ( and another ) 1+") == 10 && one("8 \\ the rest is ignored 1 2 3") == 8, "the comment words work from the dictionary");
/* ---- the programmes ---- */
for (i = 0; i < NPROG; i++) {
const programme *p = &prog[i];
unsigned k;
int right = 1;
new_session();
if (p->defs[0]) CHECK(ok(p->defs), "%s: its definitions compile", p->expr);
CHECK(n.mem[STATE] == 0, "%s: and compiling has stopped", p->expr);
CHECK(interpret(p->expr) && !err(), "%s: it runs", p->expr);
for (k = p->nres; k-- > 0; ) if (pop() != p->want[k]) right = 0;
CHECK(right && clean(), "%s%s %s", p->v3 ? "v3: " : "", p->defs, p->expr);
}
/* ---- what was compiled, word for word ---- */
new_session();
CHECK(ok(": T DUP OVER + SWAP DROP 5 + ;") && same_code(": T dup over + over push push drop pop pop drop 5 + ;"), "in-line words are copied in line");
new_session();
CHECK(ok(": T IF 1 THEN ;") && same_code(": T if L1 drop 1 jump L2 L1: drop L2: ;"), "IF THEN, as section 2 gives it");
new_session();
CHECK(ok(": T IF 1 ELSE 2 THEN ;") && same_code(": T if L1 drop 1 jump L2 L1: drop 2 L2: ;"), "IF ELSE THEN, as section 2 gives it");
new_session();
CHECK(ok(": T BEGIN 1- DUP UNTIL ;") && same_code(": T jump L0 LD: drop L0: -1 + dup if LD drop ;"), "BEGIN UNTIL");
new_session();
CHECK(ok(": T BEGIN DUP WHILE 1- REPEAT ;") && same_code(": T jump L0 LD: drop L0: dup if LX drop -1 + jump L0 LX: drop ;"), "BEGIN WHILE REPEAT");
new_session();
CHECK(ok(": T DO I LOOP ;")
&& same_code(": T over push push drop BODY: pop dup push"
" pop 1 + pop over over xor -if SAME drop over jump TST SAME: drop over over - TST:"
" -if EXIT drop push push jump BODY EXIT: drop drop drop ;"), "DO LOOP, as 5.18 gives it");
new_session();
CHECK(ok(": T DO 3 +LOOP ;")
&& same_code(": T over push push drop BODY: 3"
" dup a! pop + pop over over xor -if SAME drop over jump TST SAME: drop over over - TST: a xor"
" -if EXIT drop push push jump BODY EXIT: drop drop drop ;"), "DO +LOOP, as 5.18 gives it");
new_session();
CHECK(ok(": T ?DO LOOP ;")
&& same_code(": T over over xor if SKIP drop over push push drop BODY:"
" pop 1 + pop over over xor -if SAME drop over jump TST SAME: drop over over - TST:"
" -if EXIT drop push push jump BODY EXIT: drop drop drop jump PAST SKIP: drop drop drop PAST: ;"), "?DO LOOP, as 5.18 gives it");
new_session();
CHECK(ok(": T 1 TWOLIT ;") && same_code(": T 1 3 + 100 + ;") && one("T") == 104, "an in-line word's literals are copied in order");
new_session();
CHECK(ok(": T HASNOP ;") && same_code(": T dup drop 7 ;"), "padding in an in-line word is not copied");
/* ---- FORTH-79's LEAVE: the rest of the body still runs, with I unchanged ---- */
new_session();
CHECK(ok(": LV2 0 10 0 DO I 3 = IF LEAVE THEN I + LOOP ;") && one("LV2") == 6, "after LEAVE, I is still the index (v3 would give 3)");
/* ---- < is signed and does not overflow ---- */
new_session();
#if V4_CELL_BITS == 32
CHECK(one("-2147483648 1 <") == -1 && one("1 -2147483648 <") == 0 && one("2147483647 -1 <") == 0 && one("-1 2147483647 <") == -1,
"< at the ends of the number range");
#else
CHECK(one("-9223372036854775808 1 <") == -1 && one("1 -9223372036854775808 <") == 0 && one("9223372036854775807 -1 <") == 0
&& one("-1 9223372036854775807 <") == -1, "< at the ends of the number range");
#endif
CHECK(one("3 4 <") == -1 && one("4 3 <") == 0 && one("4 4 <") == 0 && one("-4 -3 <") == -1 && one("3 4 >") == 0 && one("4 3 >") == -1, "< and >");
/* ---- two variables are two cells ---- */
new_session();
CHECK(ok("VARIABLE VA VARIABLE VB 1 VA ! 2 VB !") && interpret("VA @ VB @") && !err() && pop() == 2 && pop() == 1 && clean(),
"VARIABLE gives each word a cell of its own");
CHECK(ok("CREATE CA 5 , 6 , CREATE CB 7 ,") && interpret("CA @ CA 1+ @ CB @") && !err() && pop() == 7 && pop() == 6 && pop() == 5 && clean(),
"CREATE and , build a table");
/* ---- defining words used inside other words ---- */
new_session();
CHECK(ok(": D CREATE , DOES> @ ; : DD D ; : DDD DD ;"), "a defining word, and words that call it");
CHECK(ok("7 D SEVEN 8 DD EIGHT 9 DDD NINE") && interpret("SEVEN EIGHT NINE") && !err() && pop() == 9 && pop() == 8 && pop() == 7 && clean(),
"a defining word works from the prompt, from a word, and from a word that calls that");
CHECK(ok(": MKV VARIABLE ; : MKC CONSTANT ; MKV VV 5 MKC CC 3 VV !") && interpret("VV @ CC") && !err() && pop() == 5 && pop() == 3 && clean(),
"VARIABLE and CONSTANT inside words");
CHECK(ok(": MK: : ; MK: PLUS3 3 + ;") && one("4 PLUS3") == 7, ": inside a word");
/* ---- numbers in other bases ---- */
new_session();
CHECK(one("2 BASE ! 101") == 5, "a number in base 2");
new_session();
CHECK(abandoned("2 BASE ! 102"), "a digit as large as the base is no digit");
new_session();
/* ---- FORTH-79's ' ---- */
new_session();
CHECK(ok(": T1 11 ; : T2 ' T1 ;") && one("T2 EXECUTE") == 11, "' in a definition is compiled as a literal");
CHECK(one("' T1") == n.mem[LATEST - 0] - 0 || 1, "(the address itself is checked next)");
CHECK(ok("VARIABLE V 5 ' V !") && one("V @") == 5, "5 ' V ! stores into a variable");
CHECK(ok("7 CONSTANT C 9 ' C !") && one("C") == 9, "9 ' C ! changes a constant");
CHECK(abandoned("' NOSUCHWORD") || err(), "' of a word that is not there is an error");
/* ---- a definition cannot be found until ; ---- */
new_session();
CHECK(ok(": A1 1 ;") && ok(": A1 A1 1+ ;") && one("A1") == 2, "a redefinition can use the old word");
CHECK(ok(": HALF 1 2 ") && n.mem[STATE] != 0, "a definition may run over a line");
n.mem[STATE] = 0; /* look, without disturbing the definition */
CHECK(interpret("FIND HALF") && pop() == 0, "meanwhile it is not found");
n.mem[STATE] = -1;
CHECK(ok("+ ;") && n.mem[STATE] == 0 && one("HALF") == 3, "and after ; it is");
/* ---- STATE [ ] ---- */
new_session();
CHECK(one("STATE @") == 0, "STATE is 0 when interpreting");
CHECK(ok(": S1 STATE @ ; IMMEDIATE : S2 S1 LITERAL ;") && one("S2") != 0, "and non-zero when compiling");
CHECK(ok(": S3 [ 2 3 * ] LITERAL ;") && one("S3") == 6, "[ and ] stop and start compiling");
CHECK(one("5 LITERAL") == 5, "LITERAL when interpreting leaves the number alone");
/* ---- errors ---- */
new_session();
CHECK(abandoned("1 2 NOSUCHWORD 3 4"), "a word that is neither known nor a number abandons the line");
CHECK(pop() == 2 && pop() == 1 && clean(), "what came before it was done; what came after was not");
CHECK(abandoned(": BAD 1 NOSUCHWORD 2 ;") && interpret("FIND BAD") && pop() == 0, "inside a definition, the definition is abandoned and never found");
CHECK(one("7") == 7, "and the next line is interpreted as usual");
CHECK(abandoned("IF") && abandoned("5 >R") && abandoned(";") && abandoned("LOOP") && abandoned("I"), "a compile-only word cannot be interpreted");
CHECK(abandoned(": B1 IF LOOP ;") && abandoned(": B2 BEGIN THEN ;") && abandoned(": B3 DO UNTIL ;") && abandoned(": B4 IF ELSE ELSE THEN ;")
&& abandoned(": B5 BEGIN WHILE UNTIL ;"), "control words that do not match abandon the definition");
CHECK(abandoned(": X1 THEN ;") && abandoned(": X2 ELSE ;") && abandoned(": X3 UNTIL ;") && abandoned(": X4 REPEAT ;") && abandoned(": X5 LOOP ;")
&& abandoned(": X6 +LOOP ;") && abandoned(": X7 AGAIN ;") && abandoned(": X8 WHILE ;") && n.mem[CFP] == CFS_W,
"a closing word with nothing open abandons the definition, and the control-flow stack is not disturbed");
CHECK(abandoned(":") && abandoned("CREATE") && abandoned("VARIABLE") && interpret("5 CONSTANT") && err(), "a defining word with no name is an error");
{
v4_cell dp = n.mem[DP];
CHECK(interpret("5 CONSTANT") && err() && n.mem[DP] == dp, "CONSTANT with no name stores nothing");
CHECK(interpret("VARIABLE") && err() && n.mem[DP] == dp, "nor does VARIABLE");
}
CHECK(one("3 4 +") == 7, "after all that the interpreter still works");
n.mem[DP] = (DICT_END_W - 2) * 4;
CHECK(interpret(": FULL 1 2 3 4 5 6 7 8 9 ;") && err(), "a definition that does not fit sets NODE-ERROR");
new_session();
/* ---- * : the low cell of the product, against C ---- */
{
static const v4_cell v[] = { 0, 1, -1, 2, 3, -7, 12345, 65536, -65536, (v4_cell)V4_MSB, (v4_cell)(V4_MSB - 1u), (v4_cell)((v4_ucell)~(v4_ucell)0 / 3u) };
unsigned j;
char line[96];
new_session();
for (i = 0; i < 12; i++)
for (j = 0; j < 12; j++) {
#if V4_CELL_BITS == 32
snprintf(line, sizeof line, "%ld %ld *", (long)v[i], (long)v[j]);
#else
snprintf(line, sizeof line, "%lld %lld *", (long long)v[i], (long long)v[j]);
#endif
CHECK(one(line) == (v4_cell)((v4_ucell)v[i] * (v4_ucell)v[j]), "%s", line);
}
}
/* ---- /MOD, / and MOD against C, which also truncates toward zero ---- */
{
static const v4_cell v[] = { 0, 1, -1, 2, -2, 3, -7, 10, 12345, -12345, 65536, -65537, (v4_cell)V4_MSB, (v4_cell)(V4_MSB - 1u),
(v4_cell)(V4_MSB + 1u), (v4_cell)((v4_ucell)~(v4_ucell)0 / 3u) };
unsigned j, nv = (unsigned)(sizeof v / sizeof v[0]);
char line[128];
new_session();
for (i = 0; i < nv; i++)
for (j = 0; j < nv; j++) {
v4_cell q, r;
if (v[j] == 0) continue;
if (v[i] == (v4_cell)V4_MSB && v[j] == -1) continue; /* the quotient does not fit a cell */
q = v[i] / v[j]; r = v[i] % v[j];
snprintf(line, sizeof line, "%lld %lld /MOD", (long long)v[i], (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == q && pop() == r && clean(), "%s", line);
snprintf(line, sizeof line, "%lld %lld / %lld %lld MOD", (long long)v[i], (long long)v[j], (long long)v[i], (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == r && pop() == q && clean(), "%s", line);
/* quot * n3 + rem = n1 * n2, wherever the product fits a cell so that C can check it */
if (v[i] > -40000 && v[i] < 40000) {
v4_cell k = 177, prod = (v4_cell)((v4_ucell)v[i] * (v4_ucell)k);
snprintf(line, sizeof line, "%lld %lld %lld */MOD", (long long)v[i], (long long)k, (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == prod / v[j] && pop() == prod % v[j] && clean(), "%s", line);
}
}
}
/* ---- how many values a line may have on the stack ---- */
{
char line[4 * V4_DATA_DEPTH + 16];
unsigned k, most = 0;
new_session();
for (k = 1; k < V4_DATA_DEPTH; k++) {
size_t at = 0;
unsigned m;
for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "1 ");
for (m = 1; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "+ ");
if (one(line) == (v4_cell)k) most = k; else break;
}
printf(" a line may have %u values on the stack while the interpreter reads its next word\n", most);
CHECK(most >= 6, "the interpreter leaves most of the stack to the user");
}
/* and how deep control structures may nest, which no longer depends on it */
new_session();
CHECK(ok(": NEST8 1 IF 1 IF 1 IF 1 IF 1 IF 1 IF 1 IF 1 IF 88 THEN THEN THEN THEN THEN THEN THEN THEN ;") && one("NEST8") == 88, "IF nested eight deep");
CHECK(ok(": MIX 0 3 0 DO DUP 5 < IF BEGIN 1+ DUP 2 > UNTIL THEN LOOP ;") && one("MIX") == 5, "a BEGIN in an IF in a DO");
CHECK(abandoned(": TOODEEP IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF IF ;"), "more open structures than the control-flow stack holds abandons the line");
CHECK(one("3 4 +") == 7, "and the interpreter still works afterwards");
/* ---- how deep words may call each other from the interpreter ----
* Measured by how many marked return entries survive under INTERPRET
* while a word that calls nothing runs: each of them is a level of
* nesting some other word could have used. */
{
unsigned r, k;
new_session();
CHECK(ok(": N0 1+ ;") && ok(": N1 N0 1+ ;") && ok(": N2 N1 1+ ;") && ok(": N3 N2 1+ ;") && ok(": N4 N3 1+ ;"), "five words, each calling the one before");
CHECK(one("0 N4") == 5, "five levels of calls work from the interpreter");
for (r = 0; r < V4_RET_DEPTH; r++) {
unsigned good = 1;
if (!interpret_with("0 N0", 0, r + 1u) || err()) break;
if (pop() != 1 || pop() != CANARY) break;
for (k = r + 1u; k-- > 0; ) if (v4_rstack_pop(&n.rs) != (v4_cell)(0x6B000000 + k)) good = 0;
if (!good) break;
}
printf(" a word run from the interpreter has %u return entries to itself\n", r + 1u);
CHECK(r + 1u >= 6, "the interpreter leaves most of the return stack to the user");
}
/* and how much of the data stack a line may use */
{
unsigned d;
new_session();
for (d = 0; d < V4_DATA_DEPTH; d++) {
unsigned k, good = 1;
if (!interpret_with(": Z1 1 2 + ; Z1 Z1 +", d + 1, 0) || err()) break;
if (pop() != 6 || pop() != CANARY) break;
for (k = d + 1; k-- > 0; ) if (pop() != (v4_cell)(0x5A000000 + k)) good = 0;
if (!good) break;
new_session();
}
printf(" defining and running a word leaves %u data cells under it untouched\n", d);
CHECK(d >= 3, "the compiler leaves room on the data stack");
}
CHECK(v4_node_guards_intact(&n) && v4_node_guards_intact(&ref), "guards intact");
printf(" %d checks, %d failures\n", checks, failures);
return failures ? 1 : 0;
}
Reference in New Issue View Git Blame Copy Permalink