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

feat(v4.0.0): CASE, ['], S", WORDS, FORGET and FENCE

Browse Source 
- compile.v4: CASE OF ENDOF ENDCASE, as v3 (they nest; a word out of
  place is a control structure mismatch); ['] and [LITERAL].
- quit.v4: S" and its run-time word; at the prompt the text is copied to
  PAD.
- capsule/system.v4: WORDS and VLIST; FORGET (FORTH-79), which gives the
  space back and will not remove a word below FENCE -- the capsule's own
  words -- where v3's FORGET DUP succeeds.
- tests/test_host_quit.c: ten more transcripts of the v3 binary, and
  nesting, the fence and the listing.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 20:49:53 -04:00
co-authored by Claude Opus 5.5
parent c02505db69
commit e7d686c7a2
7 changed files with 174 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/compile.v4
+41 -1
View File
@@ -177,6 +177,13 @@ header LITERAL immediate
header ' immediate
: TICK (') jump LITERAL
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
\ which v3 has as another name for LITERAL.
header ['] immediate compile-only
: BRACKET-TICK (') jump (LIT,)
header [LITERAL] immediate
: BRACKET-LITERAL jump LITERAL
\ ---- colon definitions -----------------------------------------------------------
\ FORTH-79: start a definition; it cannot be found until ; ends it.
@@ -263,7 +270,7 @@ header DOES> immediate compile-only
\ ---- control structures (5.18, section 2) ---------------------------------------------
\ All immediate and compile-only. Each puts what the word that closes it
\ needs on the control-flow stack, with a number on top saying which word put
\ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO. A closing word that
\ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO, 7 CASE, 8 OF. A closing word that
\ finds the wrong number abandons the line.
\ ( tag wanted -- ) if they differ, abandon the line and leave the control
@@ -319,6 +326,39 @@ header REPEAT immediate compile-only
CF> 3 (PAIR) CF> (JUMP,) CF> drop
(C)+6 a! @ (HERE!) 23 jump (OP,)
\ CASE: the value being chosen on stays on the stack through the clauses.
\ CASE x1 OF a ENDOF x2 OF b ENDOF c ENDCASE
\ lays, for each clause,
\ over xor if M drop jump N M: drop drop a jump END N:
\ and ENDCASE lays the drop that the part after the last ENDOF leaves the
\ value for, with END after it. The control-flow stack holds the jumps to
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
: (of) over xor ;
header CASE immediate compile-only
: CASE 0 >CF 7 jump >CF
header OF immediate compile-only
: OF
CF> 7 (PAIR)
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
8 jump >CF
header ENDOF immediate compile-only
: ENDOF
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
CF> (C)+7 a! ! \ how many jumps to END so far
2 (BRANCH>) >CF \ one more
(C)+7 a! @ 1 + >CF
(C)+6 a! @ (HERE!) \ N:
7 jump >CF
header ENDCASE immediate compile-only
: ENDCASE
CF> 7 (PAIR) CF> (C)+7 a! !
23 (OP,)
L: (C)+7 a! @ if DONE -1 + !
CF> (HERE!) jump L
DONE: drop ;
\ DO loops: the limit and index are on the return stack, limit below (5.18).
: (do) over push push drop ;
: (?do) over over xor ;
v4/capsule/core.v4
+1 -1
View File
@@ -14,7 +14,7 @@
\ 1 Negative count 2 Not a number 3 Number too long
\ 4 Not a character 5 Dictionary full 6 Name missing
\ 7 Control structure mismatch 8 Control structures too deep
\ 9 Shift count out of range
\ 9 Shift count out of range 10 Protected word
\ -1 the word has printed its own message
macro SWAP over push push drop pop pop endmacro
v4/capsule/quit.v4
+19
View File
@@ -96,6 +96,7 @@ header ABORT
-if POS drop 2 jump (REPL)
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9
-1 + if M10
drop 2 jump (REPL)
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (REPL)
M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (REPL)
@@ -106,6 +107,7 @@ header ABORT
M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (REPL)
M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (REPL)
M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (REPL)
M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (REPL)
\ The table the loader gives the node: six words, one for each kind of
\ fault in the node's order, each a jump. A jump fills its word, so they
@@ -170,3 +172,20 @@ header ABORT" immediate
NOW: drop if NO
drop WBUF COUNT TYPE CR jump ABORT
NO: drop ;
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
push 1 + pop ; \ baddr+1 n
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
header S" immediate
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(S") (CALL,) jump (STRING,)
NOW: drop WBUF+1 PAD WBUF C@ CMOVE PAD WBUF jump C@
v4/capsule/system.v4
+45
View File
@@ -0,0 +1,45 @@
\ system.v4 -- words about the dictionary as a whole: WORDS, FORGET, FENCE.
\
\ DECOMPOSITION.md 5.13 and 5.15. Part of the compiler capsule; rests on
\ dict.v4, quit.v4 and forth.v4.
\
\ Constants the loader supplies:
\ FENCE word address of the variable: FORGET will not remove an entry
\ that starts below the address it holds
header FENCE inline : FENCE' FENCE ;
\ ( -- ) the names in the dictionary, the newest first, a blank after
\ each, a new line whenever one has passed column 64. Hidden entries -- a
\ definition under way -- are not shown. (Q)+0 is the column.
header WORDS
: WORDS
0 (Q) a! !
LATEST
L: if DONE
dup -3 + a! @ 2 and if SHOW drop jump NXT
SHOW: drop
dup -2 + a! @ 4* COUNT 31 and \ xt baddr u
dup (Q) a! @ + 1 + !
TYPE SPACE
(Q) a! @ -64 + -if WRAP drop jump NXT
WRAP: drop CR 0 (Q) a! !
NXT: -1 + a! @ jump L
DONE: drop jump CR
header VLIST
: VLIST jump WORDS
\ FORGET xxx FORTH-79: remove xxx and every word defined after it. The
\ space they took is free again. A word that is not there is an error, and
\ so is one below FENCE, which is where the capsule's own words are (code
\ 10, "Protected word").
header FORGET
: FORGET
32 WORD (LOOKUP) if MISSING
dup -2 + a! @ \ xt name
dup FENCE a! @ inv + 1 + -if OK \ name - fence
drop drop drop NODE-ERROR b! 10 !b ;
OK: drop
4* DP a! ! \ the space from its name on
-1 + a! @ (LATEST) a! ! ; \ and the entry before it is the newest
MISSING: drop (UNKNOWN) drop ;
v4/tests/host_map.h
+2
View File
@@ -40,6 +40,7 @@
#define FVARS (TOP - 105) /* (F): forth.v4, 7 cells */
#define SVARS (TOP - 540 - (v4_cell)V4_DATA_DEPTH) /* (S): where PICK and ROLL set stack values aside, one cell for each cell of the stack */
#define WVARS (TOP - 99) /* (W): numout.v4, 3 cells */
#define FENCE (TOP - 26) /* FORGET's lower limit */
#define HLD (TOP - 25) /* where the pictured number has got to */
#define QVARS (TOP - 52) /* (Q): quit.v4, 2 cells */
@@ -116,6 +117,7 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
v4_text_constant(tx, "(X)", XVARS);
v4_text_constant(tx, "MAX-INT", (v4_cell)(V4_MSB - 1u));
v4_text_constant(tx, "HLD", HLD);
v4_text_constant(tx, "FENCE", FENCE);
v4_text_constant(tx, "HEND", HEND);
v4_text_constant(tx, "-HFLOOR", -(HEND - 62));
v4_text_constant(tx, "DSTACK-DEPTH", DSTACK_REG);
v4/tests/test_host_quit.c
+59 -2
View File
@@ -81,6 +81,7 @@ static void boot_with(unsigned depth)
n.mem[CFP] = CFS_W;
n.mem[BASE] = 10;
n.mem[NODE_ERROR] = 0;
n.mem[FENCE] = DICT_W;
v4_node_console_attach(&n, CONSOLE_TX);
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
v4_node_fault_attach(&n, w_fault);
@@ -184,6 +185,24 @@ static const transcript script[] = {
{ "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 },
/* 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 },
@@ -312,8 +331,8 @@ int main(void)
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" };
CHECK(host_load(&tx, &n, files, 9), "the capsule assembles");
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" };
CHECK(host_load(&tx, &n, files, 10), "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");
@@ -637,6 +656,44 @@ int main(void)
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");
}
/* ---- 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");
}
/* ---- a full dictionary ---- */
boot_bare();
n.mem[DP] = (DICT_END_W - 2) * 4;