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

feat(v4.0.0): the editor, redone in FORTH; COLD WARM PAGE VERSION DEFER

Browse Source 
- capsule/editor.fth: the block editor as FORTH source, which the node
  compiles itself.  It is a vocabulary, EDITOR, used at the ordinary
  prompt: n EDIT, then L N B T P E D S H R I WIPE DONE.  v3's EDIT, a
  shell of its own, is not carried over (ruled 2026-10-05); v3's L S and
  SHOW are kept in FORTH as they were, with COPY.
- system.v4: COLD (the system as the loader left it), WARM, PAGE,
  VERSION, 79-STANDARD (FORTH-79: silent), and DEFER IS DEFER@ as v3.
- input.v4: where words are split at blanks a zero byte reads as a blank,
  so a block never written, or filled a line at a time, loads cleanly.
- tests/test_host_quit.c: the editor's source fed to the prompt line by
  line, every command on empty and full screens, what reaches storage;
  the system words; deferred words.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-05 10:25:20 -04:00
co-authored by Claude Opus 5.5
parent c8dc14897c
commit a1afb44598
8 changed files with 298 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/tests/host_map.h
+2
View File
@@ -64,6 +64,7 @@
#define SRC (BVARS + 8)
#define SRC_HOOK (BVARS + 9)
#define STORAGE_REG (BVARS + 10)
#define BOOT_CELLS (BVARS + 14) /* (BOOT): DP and LATEST as the loader left them, 2 cells */
#define BUF0_W (BVARS - 2 * 256) /* the two block buffers, 256 cells each */
#define BUF1_W (BUF0_W + 256)
#define QVARS (BUF0_W - 4) /* (Q): quit.v4, system.v4 and blocks.v4, 4 cells */
@@ -128,6 +129,7 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
v4_text_constant(tx, "(W)", WVARS);
v4_text_constant(tx, "(X)", XVARS);
v4_text_constant(tx, "(B)", BVARS);
v4_text_constant(tx, "(BOOT)", BOOT_CELLS);
v4_text_constant(tx, "SCR", SCR);
v4_text_constant(tx, "BLK", BLK);
v4_text_constant(tx, "(SRC)", SRC);
v4/tests/test_host_quit.c
+146
View File
@@ -98,6 +98,8 @@ static void boot_with(unsigned depth)
n.mem[CFP] = CFS_W;
n.mem[BASE] = 10;
n.mem[NODE_ERROR] = 0;
n.mem[BOOT_CELLS] = n.mem[DP];
n.mem[BOOT_CELLS + 1] = capsule_latest;
n.mem[FENCE] = DICT_W;
n.mem[CONTEXT] = LATEST;
n.mem[CURRENT] = LATEST;
@@ -148,6 +150,36 @@ static const char *say(const char *input)
out[n.console_len] = 0;
return out;
}
/* Feed a file of FORTH source to the prompt, a line at a time, as if typed.
* True if every line was accepted: the node said " ok" and nothing else. */
static int load_source(const char *name)
{
char path[512], line[160];
FILE *f;
unsigned num = 0;
snprintf(path, sizeof path, "%s/%s", V4_CAPSULE_DIR, name);
f = fopen(path, "r");
if (!f) { printf(" cannot open %s\n", path); return 0; }
while (fgets(line, sizeof line, f)) {
size_t len = strlen(line);
num++;
if (len == 0 || line[len - 1] != '\n' || len > 80) { printf(" %s line %u: too long\n", name, num); fclose(f); return 0; }
if (strcmp(say(line), " ok\nok> ") != 0) { printf(" %s line %u: %s", name, num, line); printf(" -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; }
}
fclose(f);
return n.mem[STATE] == 0;
}
/* What the editor's L prints for a screen of blanks. */
static const char *blank_screen(int num)
{
static char text[2048];
size_t at = (size_t)snprintf(text, sizeof text, "Screen %d:\n", num);
for (unsigned k = 0; k < 16; k++) at += (size_t)snprintf(text + at, sizeof text - at, "%2u: %-64s\n", k, "");
snprintf(text + at, sizeof text - at, " ok\nok> ");
return text;
}
static void show(const char *label, const char *s)
{
printf(" %s\"", label);
@@ -932,6 +964,120 @@ int main(void)
CHECK(strncmp(say("50 LIST\n"), "\nBlock 50\n00: \n01: ", 81) == 0 && n.mem[SCR] == 50,
"a block of zeros lists as blanks, and SCR is the block listed");
/* ---- the editor: FORTH source, compiled by the node ---- */
boot_bare();
CHECK(load_source("editor.fth"), "editor.fth compiles, every line of it");
CHECK(is(say("ORDER .S\n"), "Search order: FORTH \nCurrent: FORTH\n<0> \n ok\nok> "), "and leaves FORTH as it found it");
{
char want[2048], blank[65];
size_t at;
unsigned k;
memset(blank, ' ', 64); blank[64] = 0;
#define SCREEN(num, ...) do { static const char *const t_[] = { __VA_ARGS__ }; \
at = (size_t)snprintf(want, sizeof want, "Screen %d:\n", num); \
for (k = 0; k < 16; k++) at += (size_t)snprintf(want + at, sizeof want - at, "%2u: %-64s\n", k, k < sizeof t_ / sizeof t_[0] ? t_[k] : ""); \
snprintf(want + at, sizeof want - at, " ok\nok> "); } while (0)
SCREEN(9, "");
CHECK(is(say("9 EDIT\n"), want), "EDIT lists the screen");
CHECK(is(say("ORDER\n"), "Search order: EDITOR FORTH\nCurrent: FORTH\n ok\nok> ") && n.mem[SCR] == 9, "and the editor's words are now found first");
CHECK(is(say("0 P first line\n"), " ok\nok> ") && is(say("1 P second, with blanks before it\n"), " ok\nok> ")
&& is(say("3 P fourth\n"), " ok\nok> ") && is(say("15 P last\n"), " ok\nok> "), "P puts text on a line");
SCREEN(9, "first line", " second, with blanks before it", "", "fourth", "", "", "", "", "", "", "", "", "", "", "", "last");
CHECK(is(say("L\n"), want), "L lists it");
CHECK(is(say("1 T 2 T\n"), " 1: second, with blanks before it \n 2: \n ok\nok> "), "T types a line");
CHECK(is(say("2 S\n"), " ok\nok> ") && is(say("2 P put in the gap\n"), " ok\nok> "), "S spreads");
SCREEN(9, "first line", " second, with blanks before it", "put in the gap", "", "fourth", "", "", "", "", "", "", "", "", "", "", "");
CHECK(is(say("L\n"), want), "the lines below move down and the last is lost");
CHECK(is(say("1 D\n"), " ok\nok> "), "D deletes");
SCREEN(9, "first line", "put in the gap", "", "fourth");
CHECK(is(say("L\n"), want), "the lines below move up");
CHECK(is(say("5 I 0 H 7 R 2 E\n"), " ok\nok> "), "I inserts the deleted line; H and R copy one; E erases one");
SCREEN(9, "first line", "put in the gap", "", "fourth", "", " second, with blanks before it", "", "first line");
CHECK(is(say("L\n"), want), "as it should be");
CHECK(is(say("0 D 0 D 0 D 0 D 0 D 15 S 15 D 0 S 0 D\n"), " ok\nok> "), "at the ends");
SCREEN(9, " second, with blanks before it", "", "first line");
CHECK(is(say("L\n"), want), "nothing is disturbed");
CHECK(disk[9 * V4_BLOCK_BYTES] == 0, "nothing has reached storage yet");
CHECK(is(say("16 T\n"), "Line out of range\n ok\nok> ") && is(say("-1 E\n"), "Line out of range\n ok\nok> ") && is(say("16 P x\n"), "Line out of range\n ok\nok> "),
"a line that is not there");
CHECK(is(say("9 EDIT\n"), want), "(ABORT left FORTH as CONTEXT; EDIT again)");
CHECK(is(say("DONE ORDER\n"), "Search order: FORTH \nCurrent: FORTH\n ok\nok> ") && memcmp(disk + 9 * V4_BLOCK_BYTES, " second, with blanks", 21) == 0
&& disk[9 * V4_BLOCK_BYTES + 128] == 'f' && disk[9 * V4_BLOCK_BYTES + 1023] == ' ', "DONE writes the screen and goes back to FORTH");
/* text typed into a screen is a programme */
CHECK(is(say("20 EDIT\n"), blank_screen(20)) && is(say("0 P : HELLO .\" Hello from a block\" ;\n"), " ok\nok> ")
&& is(say("1 P HELLO \\ and say it\n"), " ok\nok> ") && is(say("2 P 3 4 + .\n"), " ok\nok> ") && is(say("DONE 20 LOAD\n"), "Hello from a block7 ok\nok> "),
"a screen that has been edited can be loaded");
CHECK(is(say("9 21 COPY 21 LIST\n"), out) && strstr(out, "Block 21\n00: second, with blanks before it") && strstr(out, "02: first line "), "COPY copies a screen");
CHECK(is(say("FLUSH\n"), " ok\nok> ") && memcmp(disk + 21 * V4_BLOCK_BYTES, disk + 9 * V4_BLOCK_BYTES, V4_BLOCK_BYTES) == 0, "and the copy reaches storage");
/* each change on its own reaches storage */
CHECK(is(say("30 EDIT\n"), blank_screen(30)) && is(say("0 P only this\n"), " ok\nok> ") && is(say("DONE\n"), " ok\nok> ")
&& memcmp(disk + 30 * V4_BLOCK_BYTES, "only this ", 10) == 0, "P alone is written");
CHECK(is(say("30 EDIT\n"), out) && is(say("0 E DONE\n"), " ok\nok> ") && disk[30 * V4_BLOCK_BYTES] == ' ', "E alone is written");
/* D and I with every line in use */
CHECK(is(say("31 EDIT\n"), blank_screen(31)), "another screen");
for (k = 0; k < 16; k++) {
char line[32];
snprintf(line, sizeof line, "%u P line %c\n", k, 'A' + k);
CHECK(is(say(line), " ok\nok> "), "line %u", k);
}
CHECK(is(say("3 D\n"), " ok\nok> "), "delete line 3 of a full screen");
SCREEN(31, "line A", "line B", "line C", "line E", "line F", "line G", "line H", "line I", "line J", "line K", "line L", "line M", "line N", "line O", "line P", "");
CHECK(is(say("L\n"), want), "every line below moved up, the last is blank");
CHECK(is(say("1 I\n"), " ok\nok> "), "insert the deleted line at 1");
SCREEN(31, "line A", "line D", "line B", "line C", "line E", "line F", "line G", "line H", "line I", "line J", "line K", "line L", "line M", "line N", "line O", "line P");
CHECK(is(say("L DONE\n"), want), "every line from 1 moved down");
CHECK(is(say("21 EDIT\n"), out) && is(say("WIPE N\n"), blank_screen(22)) && is(say("B\n"), blank_screen(21)), "WIPE blanks it; N and B move to the next and back");
CHECK(is(say("99 EDIT\n"), "Block out of range\n ERROR\nok> ") && n.mem[SCR] == 21, "EDIT of a block that is not there");
/* v3's three, in FORTH */
CHECK(is(say("FORTH 9 SCR ! 0 L 3 L\n"), " second, with blanks before it \n \n ok\nok> "),
"FORTH's L shows a line, as v3's");
CHECK(is(say("S\" a much longer line than hello\" 3 S\n"), " ok\nok> ")
&& is(say("S\" hello world\" 3 S 3 L\n"), "hello world \n ok\nok> "), "and S sets one from a string, blanks after it");
SCREEN(9, " second, with blanks before it", "", "first line", "hello world");
CHECK(is(say("SHOW\n"), want), "and SHOW shows the screen");
CHECK(is(say("7 PAD 3 16 S\n"), "Line out of range\n ok\nok> "), "a line out of range");
#undef SCREEN
}
/* ---- the small system words ---- */
boot_bare();
CHECK(is(say("79-STANDARD .S\n"), "<0> \n ok\nok> "), "79-STANDARD is satisfied, and says nothing");
{
char want[64];
snprintf(want, sizeof want, "StarForth v4.0.0 F18 %d-bit\n ok\nok> ", V4_CELL_BITS);
CHECK(is(say("VERSION\n"), want), "VERSION");
}
CHECK(is(say("65 EMIT PAGE 66 EMIT\n"), "A\x1b[2J\x1b[HB ok\nok> "), "PAGE, as v3");
CHECK(is(say(": KEEPME 1 ; 1 2 3 WARM 65 EMIT\n.S KEEPME .\n"), "FORTH-79 Warm Start\nSystem restarted.\n ok\nok> <0> \n1 ok\nok> "), "WARM empties the stacks and keeps the dictionary");
{
v4_cell dp = n.mem[BOOT_CELLS];
CHECK(is(say("VOCABULARY VV VV DEFINITIONS : INVV 1 ; HEX 20 BLOCK DROP UPDATE 5 SCR !\n"), " ok\nok> "), "a vocabulary, a base, a block, a screen");
CHECK(is(say("1 2 COLD 65 EMIT\n"), "FORTH-79 Cold Start\nSystem initialized.\n ok\nok> "), "COLD says so");
CHECK(n.mem[DP] == dp && n.mem[LATEST] == capsule_latest && n.mem[CONTEXT] == LATEST && n.mem[CURRENT] == LATEST && n.mem[VOC_LINK] == 0
&& n.mem[BASE] == 10 && n.mem[SCR] == 0 && n.mem[BVARS] == 0 && n.mem[FENCE] == dp / 4, "and everything is as the loader left it");
CHECK(is(say("KEEPME\n"), "UNKNOWN WORD: 'KEEPME'\n ERROR\nok> ") && is(say("VV\n"), "UNKNOWN WORD: 'VV'\n ERROR\nok> ")
&& is(say(".S : NEW 16 . ; NEW\n"), "<0> \n16 ok\nok> "), "what was defined is gone, and the system works");
}
/* deferred words */
boot_bare();
CHECK(is(say("DEFER FOO : BAR 65 EMIT ; ' BAR IS FOO FOO\n"), "A ok\nok> "), "a deferred word does what it is given");
CHECK(is(say("DEFER@ FOO ' BAR = .\n"), "-1 ok\nok> "), "DEFER@ leaves it");
CHECK(is(say(": BAZ 66 EMIT ; : U FOO FOO ; U ' BAZ IS FOO U\n"), "AABB ok\nok> "), "a word that uses it follows the change");
CHECK(is(say(": SETB ['] BAR IS FOO ; : GET DEFER@ FOO ; SETB FOO GET ' BAR = .\n"), "A-1 ok\nok> "), "IS and DEFER@ in a definition");
CHECK(is(say("7 DEFER QUX QUX 65 EMIT\n.S\n"), "Deferred word not set\n ERROR\nok> <1> 7 \n ok\nok> "), "a deferred word with nothing set");
CHECK(is(say(": D3 1 2 3 ; ' D3 IS QUX QUX + + .\n"), "6 ok\nok> ") && is(say("DEFER\n"), "Name missing\n ERROR\nok> ") && is(say("' BAR IS NOSUCH\n"), "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> "),
"its stack effect is the word's; and the errors");
{
/* a deferred word is no deeper than the word it runs */
char line[64];
CHECK(is(say("VARIABLE V VARIABLE C DEFER RR\n"), " ok\nok> ")
&& is(say(": R1 C @ 1- DUP C ! IF RR EXIT THEN 65 EMIT ; ' R1 IS RR\n"), " ok\nok> "), "a word that runs itself through a deferred word");
snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)(V4_RET_DEPTH - 4u));
CHECK(is(say(line), "A ok\nok> "), "each level takes one return entry, as a plain call does");
snprintf(line, sizeof line, "%u C ! RR\n", (unsigned)V4_RET_DEPTH);
CHECK(is(say(line), "Return stack overflow\n ERROR\nok> "), "and too many is an overflow, as for any word");
}
/* ---- vocabularies (FORTH-79) ---- */
boot_bare();
CHECK(is(say("CONTEXT @ CURRENT @ = . ORDER\n"), "-1 Search order: FORTH \nCurrent: FORTH\n ok\nok> "), "at switch-on there is FORTH");