admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(v4.0.0): assemble definitions written as text

Browse Source 
Test support, beside the slot packer: reads definitions in the notation
DECOMPOSITION.md uses -- words, opcodes, literals, constants, labels,
branches, FOR NEXT and FOR UNEXT, in-line macros, comments -- and lays
them down through the slot packer, so they no longer have to be retyped
opcode by opcode in C.

Tested by assembling SWAP, UM/MOD, C@ and C! both ways on two nodes and
comparing memory word for word, by running what is assembled, and on
every error it reports, each with its line number.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-03 21:13:32 -04:00
co-authored by Claude Opus 5.5
parent 861f800b7f
commit 7b710aa322
4 changed files with 1005 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/README.md
+3 -1
View File
@@ -16,7 +16,9 @@ and every ISA, hosted and bare metal, must still reach its `ok` prompt.
What exists so far is the single node: registers, circular stacks, memory, all
32 opcodes, per-opcode and per-call-target heat, and three console
registers (`CONSOLE-TX`, which captures output, and `CONSOLE-RX` and `CONSOLE-STATUS`, which hand out
input a test feeds) standing in for the console node until the mesh exists. `make -C v4 test` builds
input a test feeds) standing in for the console node until the mesh exists. The tests load definitions
onto a node either opcode by opcode (`v4/include/v4/asm.h`) or as text in the notation `DECOMPOSITION.md`
uses (`v4/include/v4/text.h`). `make -C v4 test` builds
and runs the tests at both cell widths; `make -C v4 sanitize` repeats them
under ASan and UBSan. There is no compiler capsule, no POST and no K
measurement yet.
v4/include/v4/text.h
+131
View File
@@ -0,0 +1,131 @@
/* text.h -- assemble definitions written as text onto a node.
*
* Until now every DECOMPOSITION.md definition was retyped by hand in the
* tests as calls to the slot packer (asm.h), one opcode at a time. This
* reads the definitions as they are written in the document instead:
*
* : EMIT ( c -- ) CONSOLE-TX b! !b ;
* : SPACE 32 jump EMIT
*
* and lays them down through the same slot packer, so the words it produces
* are the ones the hand-written calls would have produced. It is test
* support, like asm.h: it is not the compiler capsule (JUSTIFICATION.md
* section 9), which is itself v4 code and will be assembled by this.
*
* THE NOTATION. Tokens are separated by white space. Names are case
* sensitive; the 32 opcode mnemonics are lower case.
*
* \ ... comment to the end of the line
* ( ... ) comment to the closing parenthesis
* : NAME start the word NAME at the next instruction word. A
* word ends where the next one starts; `;` is the return
* opcode and a word may hold several, or none (it then
* runs on into the next word).
* NAME call the word NAME. It may be defined later in the
* text, or in a later call to v4_text_assemble.
* 123 -5 $FF a literal: `@p` and its value. Decimal, or hex after $.
* It must fit a cell, as a signed or an unsigned number.
* CONST a constant given by v4_text_constant: a literal.
* ; + dup a! ... an opcode. `@p` cannot be written; write the number.
* jump X call X if X -if X next X
* a branch to X: a label of this word if it has one of
* that name, before or after the branch; otherwise a word.
* LABEL: a label, at the next instruction word. Labels belong
* to the word they are in and may be used before they
* are defined.
* FOR ... NEXT `push`, then the body, then `next` back to the body.
* FOR ... UNEXT the same with `unext`: the body and the `unext` must
* fit one instruction word and hold no literal.
* macro NAME ... endmacro
* NAME stands for the tokens between, wherever it is
* written afterwards (the document's "in line"). A macro
* may use other macros; it may not define a word, a label
* or a macro.
*
* A name is looked up in this order: opcode, macro, number, constant, label
* (for a branch target), word. So an opcode's name cannot be redefined, and
* the FORTH words that share one (`@`, `!`, `+`, ...) are written as their
* opcode sequences.
*
* BRANCH PLACEMENT. A branch's address field is what is left of its word, so
* it reaches less the later its slot. The slot packer refuses a branch that
* cannot reach its target; this never asks it to: a branch is put in a slot
* only if that slot reaches the whole node (at 1024 words, every legal slot),
* and otherwise starts a new word.
*
* ERRORS. The first error stops the assembly and is kept: v4_text_error
* gives a message with the line number, and every later call does nothing.
*/
#ifndef V4_TEXT_H
#define V4_TEXT_H
#include "v4/asm.h"
#define V4_TEXT_MAX_SYMBOLS 2048u /* words, constants and macros */
#define V4_TEXT_MAX_LABELS 64u /* in one word */
#define V4_TEXT_MAX_REFS 1024u /* branches whose target is not known yet */
#define V4_TEXT_POOL 65536u /* characters of names and macro text */
#define V4_TEXT_MAX_TOKEN 63u
#define V4_TEXT_MAX_DEPTH 8u /* macros inside macros; FOR inside FOR */
typedef struct {
unsigned name; /* offset into pool */
unsigned char kind;
v4_cell value; /* address, constant, or macro text offset */
} v4_text_symbol;
typedef struct {
unsigned name;
v4_asm_ref ref;
unsigned line;
int local; /* may still turn out to be a label of this word */
} v4_text_ref;
typedef struct {
v4_asm as;
v4_text_symbol sym[V4_TEXT_MAX_SYMBOLS];
unsigned nsym;
struct { unsigned name; v4_cell addr; } label[V4_TEXT_MAX_LABELS];
unsigned nlabel;
v4_text_ref ref[V4_TEXT_MAX_REFS];
unsigned nref;
v4_cell for_addr[V4_TEXT_MAX_DEPTH];
unsigned nfor;
char pool[V4_TEXT_POOL];
unsigned pool_used;
unsigned line;
int failed;
char message[160];
} v4_text;
/* Start assembling at word address `origin` of node `n`. */
void v4_text_begin(v4_text *t, v4_node *n, v4_cell origin);
/* Give NAME a value; written in the text it is a literal. */
void v4_text_constant(v4_text *t, const char *name, v4_cell value);
/* Assemble `source`, a NUL-terminated string. May be called several times;
* words, constants and macros carry over, labels do not. Returns 1 if there
* has been no error. */
int v4_text_assemble(v4_text *t, const char *source);
/* Finish: every branch must have found its target. Returns 1 if there has
* been no error. Assembling may continue afterwards. */
int v4_text_finish(v4_text *t);
/* The address of the word NAME, or -1 if there is none. */
v4_cell v4_text_word(const v4_text *t, const char *name);
/* The next free word address. */
v4_cell v4_text_here(v4_text *t);
/* "" if there has been no error, else what and where. */
const char *v4_text_error(const v4_text *t);
#endif /* V4_TEXT_H */
v4/src/text.c
+428
View File
@@ -0,0 +1,428 @@
/* text.c -- assemble definitions written as text. See text.h. */
#include "v4/text.h"
#include <errno.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
enum { KIND_WORD = 1, KIND_CONST, KIND_MACRO };
static const char *const mnemonic[V4_OPCODE_COUNT] = {
";", "ex", "jump", "call", "unext", "next", "if", "-if",
"@p", "@+", "@b", "@", "!p", "!+", "!b", "!",
"+*", "2*", "2/", "inv", "+", "and", "xor", "drop",
"dup", "pop", "over", "a", "nop", "push", "b!", "a!"
};
/* Where tokens come from: the source text, or a macro's text on top of it. */
typedef struct {
const char *p[V4_TEXT_MAX_DEPTH + 1u];
unsigned depth; /* 0: nothing; 1: the source; more: in macros */
} reader;
static void fail(v4_text *t, const char *what, const char *token)
{
if (t->failed) return;
t->failed = 1;
if (token) snprintf(t->message, sizeof t->message, "line %u: %s: %s", t->line, what, token);
else snprintf(t->message, sizeof t->message, "line %u: %s", t->line, what);
}
static unsigned intern(v4_text *t, const char *s)
{
size_t len = strlen(s) + 1u;
unsigned at = t->pool_used;
if (len > V4_TEXT_POOL - t->pool_used) { fail(t, "out of name space", s); return 0; }
memcpy(t->pool + at, s, len);
t->pool_used += (unsigned)len;
return at;
}
static int opcode_of(const char *s)
{
for (int i = 0; i < (int)V4_OPCODE_COUNT; i++) if (strcmp(s, mnemonic[i]) == 0) return i;
return -1;
}
static const v4_text_symbol *find(const v4_text *t, const char *s)
{
for (unsigned i = t->nsym; i-- > 0; ) if (strcmp(t->pool + t->sym[i].name, s) == 0) return &t->sym[i];
return NULL;
}
static int is_reserved(const char *s)
{
return strcmp(s, ":") == 0 || strcmp(s, "macro") == 0 || strcmp(s, "endmacro") == 0
|| strcmp(s, "\\") == 0 || strcmp(s, "(") == 0
|| strcmp(s, "FOR") == 0 || strcmp(s, "NEXT") == 0 || strcmp(s, "UNEXT") == 0;
}
static int is_label_def(const char *s)
{
size_t len = strlen(s);
return len > 1 && s[len - 1] == ':';
}
/* A whole token that is a number: decimal with an optional sign, or $hex.
* It must fit a cell, read as signed or as unsigned. */
static int number_of(const char *s, v4_cell *out, int *too_big)
{
const char *digits = s;
char *end;
int neg = 0, base = 10;
unsigned long long u;
*too_big = 0;
if (*digits == '$') { base = 16; digits++; }
else if (*digits == '-') { neg = 1; digits++; }
if (*digits == 0) return 0;
for (const char *c = digits; *c; c++) {
int ok = (*c >= '0' && *c <= '9')
|| (base == 16 && ((*c >= 'a' && *c <= 'f') || (*c >= 'A' && *c <= 'F')));
if (!ok) return 0;
}
errno = 0;
u = strtoull(digits, &end, base);
if (*end) return 0;
if (errno == ERANGE
|| (neg ? u > (unsigned long long)V4_MSB : u > (unsigned long long)(v4_ucell)~(v4_ucell)0)) {
*too_big = 1;
return 1;
}
*out = neg ? (v4_cell)((v4_ucell)0 - (v4_ucell)u) : (v4_cell)(v4_ucell)u;
return 1;
}
/* The next token, or 0 at the end. Comments are skipped here, and lines
* counted, in the source only: a macro's text holds neither. */
static int next_token(v4_text *t, reader *r, char *tok)
{
for (;;) {
const char *p;
unsigned len = 0;
if (r->depth == 0) return 0;
p = r->p[r->depth - 1u];
while (*p == ' ' || *p == '\t' || *p == '\r' || *p == '\n') {
if (*p == '\n' && r->depth == 1) t->line++;
p++;
}
if (*p == 0) { r->depth--; continue; }
while (*p && *p != ' ' && *p != '\t' && *p != '\r' && *p != '\n') {
if (len < V4_TEXT_MAX_TOKEN) tok[len] = *p;
len++; p++;
}
if (len > V4_TEXT_MAX_TOKEN) { tok[V4_TEXT_MAX_TOKEN] = 0; fail(t, "name too long", tok); return 0; }
tok[len] = 0;
if (strcmp(tok, "\\") == 0) {
while (*p && *p != '\n') p++;
r->p[r->depth - 1u] = p;
continue;
}
if (strcmp(tok, "(") == 0) {
while (*p && *p != ')') { if (*p == '\n' && r->depth == 1) t->line++; p++; }
if (*p == 0) { fail(t, "comment not closed", NULL); return 0; }
r->p[r->depth - 1u] = p + 1;
continue;
}
r->p[r->depth - 1u] = p;
return 1;
}
}
/* A branch may go in the next slot only if that slot can reach every word of
* the node; otherwise it starts a new word. */
static void place_branch(v4_text *t)
{
v4_asm *as = &t->as;
if (as->slot == 0) return;
if (!v4_iword_branch_legal(as->slot)
|| (v4_ucell)v4_iword_slot_mask(as->slot) < (v4_ucell)(V4_NODE_WORDS - 1u))
(void)v4_asm_label(as);
}
static void check_asm(v4_text *t, const char *tok)
{
if (t->as.error) fail(t, "does not fit: memory is full, or a branch cannot reach", tok);
}
static void branch_to(v4_text *t, unsigned op, v4_cell target, const char *tok)
{
place_branch(t);
v4_asm_branch(&t->as, op, target);
check_asm(t, tok);
}
static void branch_later(v4_text *t, unsigned op, const char *name, int local)
{
v4_text_ref *ref;
if (t->nref == V4_TEXT_MAX_REFS) { fail(t, "too many unresolved branches", name); return; }
place_branch(t);
ref = &t->ref[t->nref];
ref->name = intern(t, name);
ref->ref = v4_asm_branch_fwd(&t->as, op);
ref->line = t->line;
ref->local = local;
check_asm(t, name);
if (!t->failed) t->nref++;
}
/* A branch to `name`. Written as a bare name it is a call to a word. After
* a branch mnemonic it is a label of this word if the word has one, before
* or after the branch, and only otherwise a word -- so it cannot be settled
* until the word ends, even when a word of that name already exists. */
static void branch(v4_text *t, unsigned op, const char *name, int may_be_label)
{
const v4_text_symbol *s;
if (may_be_label)
for (unsigned i = 0; i < t->nlabel; i++)
if (strcmp(t->pool + t->label[i].name, name) == 0) { branch_to(t, op, t->label[i].addr, name); return; }
s = find(t, name);
if (s && s->kind == KIND_WORD && !may_be_label) { branch_to(t, op, s->value, name); return; }
if ((s && s->kind != KIND_WORD) || opcode_of(name) >= 0 || is_reserved(name) || is_label_def(name)) {
fail(t, "not something to branch to", name);
return;
}
{
v4_cell v; int big;
if (number_of(name, &v, &big)) { fail(t, "not something to branch to", name); return; }
}
branch_later(t, op, name, may_be_label);
}
static void resolve(v4_text *t, unsigned i, v4_cell target)
{
v4_asm_resolve(&t->as, t->ref[i].ref, target);
if (t->as.error) {
unsigned line = t->line;
t->line = t->ref[i].line;
fail(t, "branch cannot reach", t->pool + t->ref[i].name);
t->line = line;
}
t->ref[i] = t->ref[--t->nref];
}
/* The word being assembled ends: its labels go, and what was not a label of
* it must be a word. */
static void end_word(v4_text *t)
{
if (t->nfor) { fail(t, "FOR without NEXT or UNEXT", NULL); t->nfor = 0; }
for (unsigned i = 0; i < t->nref && !t->failed; ) {
const v4_text_symbol *s;
if (!t->ref[i].local) { i++; continue; }
t->ref[i].local = 0;
s = find(t, t->pool + t->ref[i].name);
if (s && s->kind == KIND_WORD) resolve(t, i, s->value); /* moves another into place i */
else i++;
}
t->nlabel = 0;
}
static void define(v4_text *t, const char *name, unsigned char kind, v4_cell value)
{
v4_cell v; int big;
if (opcode_of(name) >= 0 || is_reserved(name) || is_label_def(name) || number_of(name, &v, &big)) {
fail(t, "cannot be used as a name", name);
return;
}
if (find(t, name)) { fail(t, "already defined", name); return; }
if (t->nsym == V4_TEXT_MAX_SYMBOLS) { fail(t, "too many names", name); return; }
t->sym[t->nsym].name = intern(t, name);
t->sym[t->nsym].kind = kind;
t->sym[t->nsym].value = value;
if (!t->failed) t->nsym++;
}
static void define_macro(v4_text *t, reader *r)
{
char name[V4_TEXT_MAX_TOKEN + 1u], tok[V4_TEXT_MAX_TOKEN + 1u];
unsigned start, line = t->line;
if (r->depth != 1) { fail(t, "macro inside a macro", NULL); return; }
if (!next_token(t, r, name)) { fail(t, "macro without a name", NULL); return; }
start = t->pool_used;
for (;;) {
size_t len;
if (!next_token(t, r, tok)) {
if (!t->failed) { t->line = line; fail(t, "macro without endmacro", name); }
return;
}
if (strcmp(tok, "endmacro") == 0) break;
if (strcmp(tok, ":") == 0 || strcmp(tok, "macro") == 0 || is_label_def(tok)) {
fail(t, "not allowed in a macro", tok);
return;
}
len = strlen(tok);
if (len + 2u > V4_TEXT_POOL - t->pool_used) { fail(t, "out of name space", name); return; }
memcpy(t->pool + t->pool_used, tok, len);
t->pool_used += (unsigned)len;
t->pool[t->pool_used++] = ' ';
}
if (t->pool_used == V4_TEXT_POOL) { fail(t, "out of name space", name); return; }
t->pool[t->pool_used++] = 0;
define(t, name, KIND_MACRO, (v4_cell)start);
}
static void one_token(v4_text *t, reader *r, const char *tok)
{
const v4_text_symbol *s;
v4_asm *as = &t->as;
v4_cell v;
int op, big;
if (strcmp(tok, ":") == 0) {
char name[V4_TEXT_MAX_TOKEN + 1u];
if (r->depth != 1) { fail(t, "not allowed in a macro", tok); return; }
if (!next_token(t, r, name)) { fail(t, ": without a name", NULL); return; }
end_word(t);
define(t, name, KIND_WORD, v4_asm_label(as));
return;
}
if (strcmp(tok, "macro") == 0) { define_macro(t, r); return; }
if (strcmp(tok, "endmacro") == 0) { fail(t, "endmacro without macro", NULL); return; }
if (is_label_def(tok)) {
char name[V4_TEXT_MAX_TOKEN + 1u];
v4_cell addr;
size_t len = strlen(tok) - 1u;
memcpy(name, tok, len);
name[len] = 0;
for (unsigned i = 0; i < t->nlabel; i++)
if (strcmp(t->pool + t->label[i].name, name) == 0) { fail(t, "label already defined in this word", name); return; }
if (t->nlabel == V4_TEXT_MAX_LABELS) { fail(t, "too many labels in one word", name); return; }
addr = v4_asm_label(as);
t->label[t->nlabel].name = intern(t, name);
t->label[t->nlabel].addr = addr;
t->nlabel++;
for (unsigned i = 0; i < t->nref && !t->failed; )
if (t->ref[i].local && strcmp(t->pool + t->ref[i].name, name) == 0) resolve(t, i, addr);
else i++;
return;
}
if (strcmp(tok, "FOR") == 0) {
if (t->nfor == V4_TEXT_MAX_DEPTH) { fail(t, "FOR nested too deep", NULL); return; }
v4_asm_op(as, V4_OP_PUSH);
t->for_addr[t->nfor++] = v4_asm_label(as);
check_asm(t, tok);
return;
}
if (strcmp(tok, "NEXT") == 0) {
if (t->nfor == 0) { fail(t, "NEXT without FOR", NULL); return; }
branch_to(t, V4_OP_NEXT, t->for_addr[--t->nfor], tok);
return;
}
if (strcmp(tok, "UNEXT") == 0) {
v4_cell body;
if (t->nfor == 0) { fail(t, "UNEXT without FOR", NULL); return; }
body = t->for_addr[--t->nfor];
/* unext repeats the word it is in, so it must still be the word the
* body started, with a slot left, and that word must own no literal */
if (as->here != body || as->slot == 0 || as->slot >= V4_SLOT_COUNT || as->nlit != 0) {
fail(t, "FOR ... UNEXT must fit one instruction word and hold no literal", NULL);
return;
}
v4_asm_op(as, V4_OP_UNEXT);
check_asm(t, tok);
return;
}
op = opcode_of(tok);
if (op >= 0) {
if (op == V4_OP_FETCH_P) { fail(t, "write the number, not @p", NULL); return; }
if (v4_op_is_branch((unsigned)op)) {
char target[V4_TEXT_MAX_TOKEN + 1u];
if (!next_token(t, r, target)) { fail(t, "branch without a target", tok); return; }
branch(t, (unsigned)op, target, 1);
return;
}
v4_asm_op(as, (unsigned)op);
check_asm(t, tok);
return;
}
s = find(t, tok);
if (s && s->kind == KIND_MACRO) {
if (r->depth == V4_TEXT_MAX_DEPTH + 1u) { fail(t, "macros nested too deep", tok); return; }
r->p[r->depth++] = t->pool + (unsigned)s->value;
return;
}
if (number_of(tok, &v, &big)) {
if (big) { fail(t, "number does not fit a cell", tok); return; }
v4_asm_lit(as, v);
check_asm(t, tok);
return;
}
if (s && s->kind == KIND_CONST) {
v4_asm_lit(as, s->value);
check_asm(t, tok);
return;
}
branch(t, V4_OP_CALL, tok, 0); /* a word, defined already or later */
}
void v4_text_begin(v4_text *t, v4_node *n, v4_cell origin)
{
v4_asm_begin(&t->as, n, origin);
t->nsym = 0;
t->nlabel = 0;
t->nref = 0;
t->nfor = 0;
t->pool_used = 0;
t->line = 0;
t->failed = 0;
t->message[0] = 0;
}
void v4_text_constant(v4_text *t, const char *name, v4_cell value)
{
if (t->failed) return;
if (strlen(name) > V4_TEXT_MAX_TOKEN) { fail(t, "name too long", name); return; }
define(t, name, KIND_CONST, value);
}
int v4_text_assemble(v4_text *t, const char *source)
{
char tok[V4_TEXT_MAX_TOKEN + 1u];
reader r;
if (t->failed) return 0;
r.p[0] = source;
r.depth = 1;
t->line = 1;
while (!t->failed && next_token(t, &r, tok)) one_token(t, &r, tok);
if (!t->failed) end_word(t);
return !t->failed;
}
int v4_text_finish(v4_text *t)
{
if (t->failed) return 0;
end_word(t);
while (t->nref && !t->failed) {
const v4_text_symbol *s = find(t, t->pool + t->ref[0].name);
if (!s || s->kind != KIND_WORD) {
t->line = t->ref[0].line;
fail(t, "never defined", t->pool + t->ref[0].name);
break;
}
resolve(t, 0, s->value);
}
if (!t->failed && !v4_asm_ok(&t->as)) fail(t, "does not fit: memory is full", NULL);
return !t->failed;
}
v4_cell v4_text_word(const v4_text *t, const char *name)
{
const v4_text_symbol *s = find(t, name);
return s && s->kind == KIND_WORD ? s->value : (v4_cell)-1;
}
v4_cell v4_text_here(v4_text *t)
{
return v4_asm_label(&t->as);
}
const char *v4_text_error(const v4_text *t)
{
return t->failed ? t->message : "";
}
v4/tests/test_text.c
+443
View File
@@ -0,0 +1,443 @@
/* test_text.c -- the text assembler (text.h).
*
* Its job is to produce, from a definition written as text, the words the
* slot packer (asm.h) produces from the same definition written by hand. So
* the first test assembles four real definitions both ways, on two nodes,
* and compares the memory word for word; the rest check each piece of the
* notation, that what is assembled runs, and every error it reports.
*/
#include "v4/text.h"
#include "v4/testcode.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)
#define ORIGIN 16
#define VARS ((v4_cell)(V4_NODE_WORDS - 16u))
static v4_node na, nb; /* by hand, by text */
static v4_exec_state es;
static v4_heat h;
static v4_asm as;
static v4_text tx; /* large: not on the stack */
/* ---- four definitions by hand, as the other tests write them ----------- */
#define O(name) v4_asm_op(&as, V4_OP_##name)
#define LIT(v) v4_asm_lit(&as, (v4_cell)(v))
#define CALL(w) v4_asm_branch(&as, V4_OP_CALL, (w))
#define FWD(op) v4_asm_branch_fwd(&as, V4_OP_##op)
#define HERE_(r) v4_asm_resolve(&as, (r), v4_asm_label(&as))
static v4_cell hand_swap, hand_ummod, hand_cfetch, hand_cstore, hand_roundtrip, hand_end;
static void build_by_hand(void)
{
v4_node_reset(&na);
v4_asm_begin(&as, &na, ORIGIN);
hand_swap = v4_asm_label(&as);
O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
{
v4_cell loop, l_sub, l_setbit, l_nosub;
v4_asm_ref r0, r1, r2, r3, r4, r5, r6, to_sub1, to_sub2, to_nosub1, to_nosub2, to_setbit;
hand_ummod = v4_asm_label(&as);
O(BANG_A); LIT(V4_CELL_BITS - 1); O(PUSH);
loop = v4_asm_label(&as);
r0 = FWD(MINUS_IF);
O(TWO_STAR); O(OVER); r1 = FWD(MINUS_IF);
O(DROP); LIT(1); O(ADD); r2 = FWD(JUMP);
HERE_(r1); O(DROP);
HERE_(r2); O(PUSH); O(TWO_STAR); O(RPOP);
to_sub1 = FWD(JUMP);
HERE_(r0);
O(TWO_STAR); O(OVER); r3 = FWD(MINUS_IF);
O(DROP); LIT(1); O(ADD); r4 = FWD(JUMP);
HERE_(r3); O(DROP);
HERE_(r4); O(PUSH); O(TWO_STAR); O(RPOP);
O(DUP); O(PUSH_A); O(XOR); r5 = FWD(MINUS_IF);
O(DROP); to_nosub1 = FWD(MINUS_IF);
to_sub2 = FWD(JUMP);
HERE_(r5);
O(DROP); O(DUP); O(INV); O(PUSH_A); O(ADD); O(INV); r6 = FWD(MINUS_IF);
O(DROP); to_nosub2 = FWD(JUMP);
HERE_(r6);
O(PUSH); O(DROP); O(RPOP); to_setbit = FWD(JUMP);
l_sub = v4_asm_label(&as);
O(INV); O(PUSH_A); O(ADD); O(INV);
l_setbit = v4_asm_label(&as);
O(PUSH); LIT(1); O(ADD); O(RPOP);
l_nosub = v4_asm_label(&as);
v4_asm_branch(&as, V4_OP_NEXT, loop);
O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
v4_asm_resolve(&as, to_sub1, l_sub);
v4_asm_resolve(&as, to_sub2, l_sub);
v4_asm_resolve(&as, to_setbit, l_setbit);
v4_asm_resolve(&as, to_nosub1, l_nosub);
v4_asm_resolve(&as, to_nosub2, l_nosub);
}
{
v4_asm_ref f0, f1, f2;
hand_cfetch = v4_asm_label(&as);
O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND);
f0 = FWD(IF);
LIT(-1); O(ADD); f1 = FWD(IF);
LIT(-1); O(ADD); f2 = FWD(IF);
O(DROP); O(FETCH_A); LIT(23); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_SLASH); O(UNEXT);
LIT(255); O(AND); O(SEMI);
HERE_(f2);
O(DROP); O(FETCH_A); LIT(15); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_SLASH); O(UNEXT);
LIT(255); O(AND); O(SEMI);
HERE_(f1);
O(DROP); O(FETCH_A); LIT(7); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_SLASH); O(UNEXT);
LIT(255); O(AND); O(SEMI);
HERE_(f0);
O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI);
}
{
v4_asm_ref k0, k1, k2;
hand_cstore = v4_asm_label(&as);
O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A);
LIT(3); O(AND); O(PUSH); LIT(255); O(AND); O(RPOP);
k0 = FWD(IF);
LIT(-1); O(ADD); k1 = FWD(IF);
LIT(-1); O(ADD); k2 = FWD(IF);
O(DROP); LIT(23); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_STAR); O(UNEXT);
O(FETCH_A); LIT((v4_cell)(v4_ucell)0xFF000000u); O(INV); O(AND); O(ADD); O(STORE_A); O(SEMI);
HERE_(k2);
O(DROP); LIT(15); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_STAR); O(UNEXT);
O(FETCH_A); LIT(-16711681); O(AND); O(ADD); O(STORE_A); O(SEMI);
HERE_(k1);
O(DROP); LIT(7); O(PUSH);
(void)v4_asm_label(&as);
O(TWO_STAR); O(UNEXT);
O(FETCH_A); LIT(-65281); O(AND); O(ADD); O(STORE_A); O(SEMI);
HERE_(k0);
O(DROP); O(FETCH_A); LIT(-256); O(AND); O(ADD); O(STORE_A); O(SEMI);
}
/* ( c baddr -- c' ) dup push C! pop C@ ; calls, one of them backward */
hand_roundtrip = v4_asm_label(&as);
O(DUP); O(PUSH); CALL(hand_cstore); O(RPOP); v4_asm_branch(&as, V4_OP_JUMP, hand_cfetch);
hand_end = v4_asm_label(&as);
CHECK(v4_asm_ok(&as), "the hand-written words assemble");
}
/* The same four, as DECOMPOSITION.md writes them. */
static const char source[] =
"\\ four words from DECOMPOSITION.md sections 4 and 5.3\n"
"macro SWAP over push push drop pop pop endmacro\n"
"\n"
": SWAP' ( a b -- b a ) SWAP ;\n"
"\n"
": UM/MOD ( ulo uhi ud -- urem uquot )\n"
" a! N-1 FOR\n"
" -if L0 \\ hi's top bit set\n"
" 2* over -if L1 drop 1 + jump L2\n"
" L1: drop L2: push 2* pop\n"
" jump SUB\n"
" L0:\n"
" 2* over -if L3 drop 1 + jump L4\n"
" L3: drop L4: push 2* pop\n"
" dup a xor -if L5\n"
" drop -if NOSUB jump SUB\n"
" L5: drop dup inv a + inv -if L6\n"
" drop jump NOSUB\n"
" L6: push drop pop jump SETBIT\n"
" SUB: inv a + inv\n"
" SETBIT: push 1 + pop\n"
" NOSUB:\n"
" NEXT\n"
" SWAP ;\n"
"\n"
": C@ ( baddr -- c )\n"
" dup 2/ 2/ a! 3 and\n"
" if K0 -1 + if K1 -1 + if K2\n"
" drop @ 23 FOR 2/ UNEXT 255 and ;\n"
" K2: drop @ 15 FOR 2/ UNEXT 255 and ;\n"
" K1: drop @ 7 FOR 2/ UNEXT 255 and ;\n"
" K0: drop @ 255 and ;\n"
"\n"
": C! ( c baddr -- )\n"
" dup 2/ 2/ a! 3 and push 255 and pop\n"
" if K0 -1 + if K1 -1 + if K2\n"
" drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;\n"
" K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;\n"
" K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;\n"
" K0: drop @ -256 and + ! ;\n"
"\n"
": ROUNDTRIP ( c baddr -- c' ) dup push C! pop jump C@\n";
/* ---- running on the text-assembled node -------------------------------- */
static int call(v4_node *n, v4_cell word, unsigned argc, v4_cell a, v4_cell b, v4_cell c)
{
v4_dstack_reset(&n->ds);
v4_rstack_reset(&n->rs);
v4_exec_reset(&es);
v4_heat_reset(&h);
v4_dstack_push(&n->ds, CANARY);
if (argc > 0) v4_dstack_push(&n->ds, a);
if (argc > 1) v4_dstack_push(&n->ds, b);
if (argc > 2) v4_dstack_push(&n->ds, c);
return word >= 0 && v4_test_call(n, &es, &h, word, 100000) > 0;
}
static v4_cell pop(v4_node *n) { return v4_dstack_pop(&n->ds); }
/* Assemble `src` on a fresh node; 1 if it assembles and finishes. */
static int ok(const char *src)
{
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
v4_text_constant(&tx, "VAR", VARS);
return v4_text_assemble(&tx, src) && v4_text_finish(&tx);
}
/* Assemble `src`; 1 if it is refused with a message holding `what`, and,
* when `line` is not 0, naming that line. */
static int refused(const char *src, const char *what, unsigned line)
{
char want[32];
if (ok(src)) return 0;
snprintf(want, sizeof want, "line %u:", line);
if (strstr(v4_text_error(&tx), what) == NULL) { printf(" message was: %s\n", v4_text_error(&tx)); return 0; }
if (line && strncmp(v4_text_error(&tx), want, strlen(want)) != 0) { printf(" message was: %s\n", v4_text_error(&tx)); return 0; }
return 1;
}
/* Run the word NAME of the last assembly on up to two arguments; its one result. */
static v4_cell result(const char *name, unsigned argc, v4_cell a, v4_cell b)
{
v4_cell r;
if (!call(&nb, v4_text_word(&tx, name), argc, a, b, 0)) return (v4_cell)0x0BADBAD;
r = pop(&nb);
return pop(&nb) == CANARY ? r : (v4_cell)0x0BADBAD;
}
int main(void)
{
unsigned i;
printf("v4 text assembler tests: V4_CELL_BITS=%d\n", V4_CELL_BITS);
/* ---- the same words by hand and by text ---- */
build_by_hand();
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
v4_text_constant(&tx, "N-1", V4_CELL_BITS - 1);
CHECK(v4_text_assemble(&tx, source), "the text assembles: %s", v4_text_error(&tx));
CHECK(v4_text_finish(&tx), "and finishes: %s", v4_text_error(&tx));
CHECK(v4_text_error(&tx)[0] == 0, "with no error message");
CHECK(v4_text_word(&tx, "SWAP'") == hand_swap, "SWAP' is where the hand-written one is");
CHECK(v4_text_word(&tx, "UM/MOD") == hand_ummod, "UM/MOD is where the hand-written one is");
CHECK(v4_text_word(&tx, "C@") == hand_cfetch, "C@ is where the hand-written one is");
CHECK(v4_text_word(&tx, "C!") == hand_cstore, "C! is where the hand-written one is");
CHECK(v4_text_word(&tx, "ROUNDTRIP") == hand_roundtrip, "ROUNDTRIP is where the hand-written one is");
CHECK(v4_text_here(&tx) == hand_end, "the text ends where the hand-written code ends: %ld, %ld",
(long)v4_text_here(&tx), (long)hand_end);
CHECK(hand_end - ORIGIN > 60, "the comparison covers a real amount of code: %ld words", (long)(hand_end - ORIGIN));
for (i = 0; i < V4_NODE_WORDS; i++) if (na.mem[i] != nb.mem[i]) break;
CHECK(i == V4_NODE_WORDS, "every word of memory is the same; first difference at %u", i);
CHECK(v4_text_word(&tx, "SWAP") == -1 && v4_text_word(&tx, "N-1") == -1 && v4_text_word(&tx, "NOPE") == -1,
"a macro, a constant and an unknown name are not words");
/* and they run */
CHECK(call(&nb, v4_text_word(&tx, "UM/MOD"), 3, 100, 0, 7) && pop(&nb) == 14 && pop(&nb) == 2 && pop(&nb) == CANARY,
"100 0 7 UM/MOD is 2 14");
for (i = 0; i < 8; i++) {
v4_cell baddr = VARS * 4 + (v4_cell)i;
CHECK(call(&nb, v4_text_word(&tx, "ROUNDTRIP"), 2, (v4_cell)(0x341 + i), baddr, 0)
&& pop(&nb) == (v4_cell)((0x41 + i) & 0xFF) && pop(&nb) == CANARY, "C! then C@ at byte %u", i);
}
/* ---- the notation, piece by piece ---- */
/* numbers */
CHECK(ok(": T 123 ;") && result("T", 0, 0, 0) == 123, "a decimal literal");
CHECK(ok(": T -5 ;") && result("T", 0, 0, 0) == -5, "a negative literal");
CHECK(ok(": T $FF ;") && result("T", 0, 0, 0) == 255, "a hex literal");
CHECK(ok(": T $ff $Ab + ;") && result("T", 0, 0, 0) == 255 + 0xAB, "hex in either case");
CHECK(ok(": T 0 ;") && result("T", 0, 0, 0) == 0, "zero");
CHECK(ok(": T 1 2 3 4 5 6 7 + + + + + + ;") && result("T", 0, 0, 0) == 28, "seven literals in a row");
#if V4_CELL_BITS == 32
CHECK(ok(": T 4294967295 ;") && result("T", 0, 0, 0) == -1, "the largest unsigned number is all ones");
CHECK(ok(": T -2147483648 ;") && result("T", 0, 0, 0) == (v4_cell)V4_MSB, "the most negative number");
CHECK(ok(": T $FFFFFFFF ;") && result("T", 0, 0, 0) == -1, "eight hex digits");
CHECK(refused(": T 4294967296 ;", "does not fit a cell", 1), "one more than fits is refused");
CHECK(refused(": T -2147483649 ;", "does not fit a cell", 1), "one less than fits is refused");
CHECK(refused(": T $100000000 ;", "does not fit a cell", 1), "nine hex digits are refused");
#else
CHECK(ok(": T 18446744073709551615 ;") && result("T", 0, 0, 0) == -1, "the largest unsigned number is all ones");
CHECK(ok(": T -9223372036854775808 ;") && result("T", 0, 0, 0) == (v4_cell)V4_MSB, "the most negative number");
CHECK(ok(": T $FFFFFFFFFFFFFFFF ;") && result("T", 0, 0, 0) == -1, "sixteen hex digits");
CHECK(refused(": T 18446744073709551616 ;", "does not fit a cell", 1), "one more than fits is refused");
CHECK(refused(": T -9223372036854775809 ;", "does not fit a cell", 1), "one less than fits is refused");
CHECK(refused(": T $10000000000000000 ;", "does not fit a cell", 1), "seventeen hex digits are refused");
#endif
CHECK(refused(": T 99999999999999999999999999 ;", "does not fit a cell", 1), "a very long number is refused");
/* constants */
CHECK(ok(": T VAR ;") && result("T", 0, 0, 0) == VARS, "a constant is a literal");
CHECK(ok(": ST ( x -- ) VAR a! ! ; : LD ( -- x ) VAR a! @ ;")
&& call(&nb, v4_text_word(&tx, "ST"), 1, 4321, 0, 0) && pop(&nb) == CANARY
&& result("LD", 0, 0, 0) == 4321 && nb.mem[VARS] == 4321, "a constant used as an address");
/* comments */
CHECK(ok("\\ a line comment\n: T ( a stack comment ) 7 \\ another\n ( and\n one over two lines ) 8 + ; \\ the end")
&& result("T", 0, 0, 0) == 15, "comments are skipped");
CHECK(ok(": (T) 5 ; : T (T) (T) + ;") && result("T", 0, 0, 0) == 10, "a name in parentheses is a name, not a comment");
CHECK(refused(": T 1 ( never closed", "comment not closed", 0), "an open comment is refused");
/* every opcode has its mnemonic */
{
static const char *const m[V4_OPCODE_COUNT] = {
";", "ex", "jump", "call", "unext", "next", "if", "-if", "@p", "@+", "@b", "@", "!p", "!+", "!b", "!",
"+*", "2*", "2/", "inv", "+", "and", "xor", "drop", "dup", "pop", "over", "a", "nop", "push", "b!", "a!" };
for (i = 0; i < V4_OPCODE_COUNT; i++) {
char src[64];
unsigned op;
if (v4_op_is_branch(i) || i == V4_OP_FETCH_P) continue;
snprintf(src, sizeof src, ": T %s", m[i]);
CHECK(ok(src), "opcode %s assembles", m[i]);
op = (unsigned)(((v4_ucell)nb.mem[ORIGIN] >> V4_SLOT_LOW_BIT(0)) & 0x1Fu);
CHECK(op == i, "%s is opcode %u, got %u", m[i], i, op);
}
}
CHECK(refused(": T @p ;", "write the number", 1), "@p cannot be written");
/* calls: backward, forward, and across calls to v4_text_assemble */
CHECK(ok(": A 3 ; : T A A + ;") && result("T", 0, 0, 0) == 6, "a call to an earlier word");
CHECK(ok(": T A A + ; : A 4 ;") && result("T", 0, 0, 0) == 8, "a call to a later word");
CHECK(ok(": T jump A : A 9 ;") && result("T", 0, 0, 0) == 9, "a jump to a later word");
CHECK(ok(": T call A 1 + ; : A 9 ;") && result("T", 0, 0, 0) == 10, "call NAME is the same as NAME");
v4_node_reset(&nb);
v4_text_begin(&tx, &nb, ORIGIN);
CHECK(v4_text_assemble(&tx, ": T B 1 + ;") && v4_text_assemble(&tx, "macro TWICE dup + endmacro : B 20 TWICE ;")
&& v4_text_finish(&tx) && result("T", 0, 0, 0) == 41, "a word defined in a later assembly; macros carry over");
CHECK(v4_text_assemble(&tx, ": U T TWICE ;") && v4_text_finish(&tx) && result("U", 0, 0, 0) == 82,
"assembling goes on after a finish");
CHECK(ok(": A 1 ; : B A A + ; : C B B + ; : T C C + ;") && result("T", 0, 0, 0) == 8, "calls three deep");
CHECK(ok(": T 5 \n : U 1 + ;") && result("T", 0, 0, 0) == 6, "a word with no ; runs on into the next");
/* labels */
CHECK(ok(": T ( n -- 1|2 ) if Z drop 1 ; Z: drop 2 ;") && result("T", 1, 5, 0) == 1 && result("T", 1, 0, 0) == 2,
"a forward label");
CHECK(ok(": T ( n -- 0 ) L: if DONE -1 + jump L DONE: ;") && result("T", 1, 9, 0) == 0, "a backward label");
CHECK(ok(": T ( n -- f ) -if P drop -1 ; P: drop 0 ;") && result("T", 1, -3, 0) == -1 && result("T", 1, 3, 0) == 0,
"-if to a label");
CHECK(ok(": A ( n -- 1|2 ) if L drop 1 ; L: drop 2 ; : T ( n -- 3|4 ) if L drop 3 ; L: drop 4 ;")
&& result("A", 1, 0, 0) == 2 && result("T", 1, 0, 0) == 4 && result("T", 1, 1, 0) == 3,
"the same label name in two words");
CHECK(ok(": L 50 ; : T ( n -- x ) if L drop 1 ; L: drop 2 ;") && result("T", 1, 0, 0) == 2,
"a label of this word comes before a word of the same name, even defined after the branch");
CHECK(ok(": L 50 ; : T ( n -- x ) L: if DONE -1 + jump L DONE: drop 3 ;") && result("T", 1, 4, 0) == 3,
"and defined before it");
CHECK(ok(": L drop 50 ; : T ( n -- x ) if L drop 1 ; : U 2 ;") && result("T", 1, 0, 0) == 50,
"with no such label the branch goes to the word");
CHECK(ok(": L drop 50 ; : T ( n -- x ) if L drop 1 ;") && result("T", 1, 0, 0) == 50,
"also when the text ends there");
CHECK(ok(": T ( n -- x ) if OUT drop 1 ; : OUT drop 77 ;") && result("T", 1, 0, 0) == 77 && result("T", 1, 4, 0) == 1,
"a branch target that is no label of its word is a word");
CHECK(refused(": T L: 1 L: 2 ;", "label already defined", 1), "a label twice in one word is refused");
CHECK(refused(": T if NOWHERE ;\n: U 1 ;", "never defined", 1), "a branch to nothing is refused, with its line");
CHECK(refused("\n\n: T 1 MISSING + ;", "never defined", 3), "a call to nothing is refused, with its line");
CHECK(refused(": T jump", "branch without a target", 1), "a branch with nothing after it is refused");
CHECK(refused(": T jump 5 ;", "not something to branch to", 1), "a branch to a number is refused");
CHECK(refused(": T jump VAR ;", "not something to branch to", 1), "a branch to a constant is refused");
CHECK(refused(": T jump dup ;", "not something to branch to", 1), "a branch to an opcode is refused");
/* FOR ... NEXT and FOR ... UNEXT */
CHECK(ok(": T ( n -- n+5 ) 4 FOR 1 + NEXT ;") && result("T", 1, 10, 0) == 15, "FOR NEXT runs its body n+1 times");
CHECK(ok(": T ( n -- n*8 ) 2 FOR 2* UNEXT ;") && result("T", 1, 3, 0) == 24, "FOR UNEXT runs its body n+1 times");
CHECK(ok(": T ( n -- x ) 1 FOR 2 FOR 2* UNEXT NEXT ;") && result("T", 1, 1, 0) == 64, "UNEXT inside NEXT");
CHECK(ok(": T ( n -- x ) 2 FOR 2* UNEXT 1 + ;") && result("T", 1, 1, 0) == 9, "code after UNEXT shares its word");
CHECK(ok(": T ( n -- x ) 2 FOR dup + 2* nop UNEXT ;") && result("T", 1, 1, 0) == 64, "a body of four slots and unext fit");
CHECK(refused(": T 2 FOR dup + 2* nop nop nop UNEXT ;", "must fit one instruction word", 1), "a body of six slots does not");
CHECK(refused(": T 2 FOR 1 + UNEXT ;", "must fit one instruction word", 1), "a literal in an UNEXT body is refused");
CHECK(refused(": T NEXT ;", "NEXT without FOR", 1), "NEXT alone is refused");
CHECK(refused(": T UNEXT ;", "UNEXT without FOR", 1), "UNEXT alone is refused");
CHECK(refused(": T 3 FOR 1 + ;\n: U ;", "FOR without NEXT", 2), "FOR left open is refused");
CHECK(refused(": T 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR ;", "nested too deep", 1), "nine FORs deep is refused");
/* macros */
CHECK(ok("macro SWAP over push push drop pop pop endmacro : T ( a b -- b ) SWAP drop ;")
&& result("T", 2, 3, 10) == 10, "a macro is laid down in line");
CHECK(ok("macro 1+ 1 + endmacro macro 2+ 1+ 1+ endmacro : T 2+ 2+ ;") && result("T", 1, 5, 0) == 9, "macros in macros");
CHECK(ok("macro TEN ( a comment ) 10 \\ and another\n endmacro : T TEN TEN + ;") && result("T", 0, 0, 0) == 20,
"comments inside a macro are dropped");
CHECK(ok("macro SHL3 2 FOR 2* UNEXT endmacro : T SHL3 ;") && result("T", 1, 1, 0) == 8, "FOR UNEXT in a macro");
CHECK(ok(": A 6 ; macro CALLS A A + endmacro : T CALLS ;") && result("T", 0, 0, 0) == 12, "a macro that calls words");
CHECK(ok("macro NOTHING endmacro : T 5 NOTHING ;") && result("T", 0, 0, 0) == 5, "an empty macro");
CHECK(refused("macro M L: endmacro", "not allowed in a macro", 1), "a label in a macro is refused");
CHECK(refused("macro M : X ; endmacro", "not allowed in a macro", 1), "a word in a macro is refused");
CHECK(refused("macro M macro N endmacro endmacro", "not allowed in a macro", 1), "a macro in a macro is refused");
CHECK(refused("macro M 1 2 3", "macro without endmacro", 1), "a macro left open is refused");
CHECK(refused("macro", "macro without a name", 0), "macro with no name is refused");
CHECK(refused(": T endmacro ;", "endmacro without macro", 1), "endmacro alone is refused");
CHECK(refused("macro M M endmacro : T M ;", "nested too deep", 1), "a macro that uses itself is refused");
/* names */
CHECK(refused(": A 1 ;\n: A 2 ;", "already defined", 2), "a word defined twice is refused");
CHECK(refused(": VAR 1 ;", "already defined", 1), "a word named like a constant is refused");
CHECK(refused("macro A 1 endmacro : A 2 ;", "already defined", 1), "a word named like a macro is refused");
CHECK(refused(": dup 1 ;", "cannot be used as a name", 1), "a word named like an opcode is refused");
CHECK(refused(": 12 1 ;", "cannot be used as a name", 1), "a word named like a number is refused");
CHECK(refused(": FOR 1 ;", "cannot be used as a name", 1), "a word named FOR is refused");
CHECK(refused("macro + 1 endmacro", "cannot be used as a name", 1), "a macro named like an opcode is refused");
CHECK(refused(": X: 1 ;", "cannot be used as a name", 1), "a word named like a label is refused");
CHECK(refused(":", ": without a name", 0), ": with no name is refused");
CHECK(refused(": T THIS-NAME-IS-MUCH-TOO-LONG-TO-BE-A-NAME-IN-THIS-ASSEMBLER-BY-A-WIDE-MARGIN ;", "name too long", 1),
"a name of more than 63 characters is refused");
CHECK(ok(": Dup 3 ; : T Dup Dup + ;") && result("T", 0, 0, 0) == 6, "names are case sensitive");
CHECK(ok(": 2DUP over over ; : 1+ 1 + ; : T ( a b -- 2a+2b+1 ) 2DUP + + + 1+ ;") && result("T", 2, 2, 3) == 11,
"names that begin with digits");
/* once it has failed it stays failed, and says why */
CHECK(!ok(": T 1 ;\n: T 2 ;") && !v4_text_assemble(&tx, ": U 3 ;") && !v4_text_finish(&tx)
&& strstr(v4_text_error(&tx), "line 2: already defined: T") != NULL, "the first error is kept: %s", v4_text_error(&tx));
/* a full node */
{
static char big[8 * V4_NODE_WORDS + 64];
size_t at = 0;
at += (size_t)sprintf(big + at, ": T ");
for (i = 0; i < V4_NODE_WORDS; i++) at += (size_t)sprintf(big + at, "1 2 3 ");
CHECK(refused(big, "does not fit", 1), "text that overflows the node is refused");
CHECK(v4_node_guards_intact(&nb), "and wrote nothing outside it");
}
/* a branch always reaches: fill most of the node, then branch across it */
{
static char far[8 * V4_NODE_WORDS + 256];
size_t at = 0;
at += (size_t)sprintf(far + at, ": T ( n -- x ) nop nop nop if FAR drop 7 ; ");
at += (size_t)sprintf(far + at, ": PAD ");
for (i = 0; i < V4_NODE_WORDS - 200u; i++) at += (size_t)sprintf(far + at, "nop ; ");
at += (size_t)sprintf(far + at, ": FAR drop 99 ; ");
CHECK(ok(far) && result("T", 1, 0, 0) == 99 && result("T", 1, 6, 0) == 7,
"a branch from a late slot to the other end of the node: %s", v4_text_error(&tx));
CHECK(v4_text_word(&tx, "FAR") > (v4_cell)(V4_NODE_WORDS - 200u), "FAR is far: %ld", (long)v4_text_word(&tx, "FAR"));
}
CHECK(v4_node_guards_intact(&na) && v4_node_guards_intact(&nb), "guards intact");
printf(" %d checks, %d failures\n", checks, failures);
return failures ? 1 : 0;
}