From dac7ffac928694c4c1f9fc2b84607c8cef3ed42d Mon Sep 17 00:00:00 2001 From: rajames Date: Sun, 4 Oct 2026 10:42:23 -0400 Subject: [PATCH] feat(v4.0.0): the defining and compiling words The fourth layer of the compiler capsule. compile.v4: INTERPRET's loop, STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE [COMPILE] ' EXECUTE, CREATE VARIABLE CONSTANT DOES>, and IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP on a control-flow stack in memory. forth.v4: the first words of the vocabulary, the in-line ones. FORTH source now goes in and running code comes out. 49 programmes were run through the v3 binary and through this; every result agrees, bar COMPILE, which v3 cannot run. The code laid down for each control structure is word for word the expansion DECOMPOSITION.md gives. A line may have six values on the stack while it is interpreted, and words called from the interpreter may nest eight deep. Co-Authored-By: Claude Opus 5.5 --- docs/v4.0.0/DECOMPOSITION.md | 37 +++- v4/capsule/compile.v4 | 348 ++++++++++++++++++++++++++++++ v4/capsule/forth.v4 | 72 +++++++ v4/tests/test_host_compile.c | 398 +++++++++++++++++++++++++++++++++++ 4 files changed, 850 insertions(+), 5 deletions(-) create mode 100644 v4/capsule/compile.v4 create mode 100644 v4/capsule/forth.v4 create mode 100644 v4/tests/test_host_compile.c diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 248a4592..e9cc9935 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -682,10 +682,10 @@ The storage service belongs to the Artemis role, now a device node. | Word | Fate | | --- | --- | | `FIND` | CC | `( -- xt \| 0 )`, FORTH-79 and v3 alike: the compilation address of the next word in the input stream, or 0 if it is not in the dictionary. `32 WORD` then a search from the newest entry back, skipping hidden ones; names are case sensitive, as v3, and 31 characters are significant (FORTH-79). Executed on the golden model's host node (2026-10-04) against a list kept in C, 300 entries. Leaves its caller 7 data cells and 5 return entries. | -| `'` | CC | `( -- addr )`, FORTH-79: the parameter field address of the next word in the input stream; not found is an error (0, and `NODE-ERROR` set). v3's `'` returned what `FIND` returns. For a word that is code the two are the same address; for a data word the parameter field is the cell after its code, which is what FORTH-79's `n ' NAME !` needs. Its compiling behaviour comes with the compiler words. Executed on the golden model's host node (2026-10-04). | +| `'` | CC | `( -- addr )`, FORTH-79: the parameter field address of the next word in the input stream; not found is an error (0, and `NODE-ERROR` set). v3's `'` returned what `FIND` returns. For a word that is code the two are the same address; for a data word the parameter field is the cell after its code, which is what FORTH-79's `n ' NAME !` needs. It is immediate: inside a definition the address is compiled as a literal (FORTH-79), where v3's `'` parsed when the definition ran. Executed on the golden model's host node (2026-10-04). | | `>LINK` `LFA` `LINK>` `>NAME` `NFA` `NAME>` `CFA` `PFA` `>BODY` `TRAVERSE` | CC | The fields of an entry, all reached from its xt, as in v3 where the xt was the entry: `>LINK`/`LFA` the link's address, `LINK>` the older entry's xt, `>NAME`/`NFA` the byte address of the counted name, `NAME>` back to the xt, `CFA` the xt itself, `PFA`/`>BODY` the parameter field, `TRAVERSE` from a name's count byte to past its last character (for `n > 0`; otherwise unchanged, as v3). Executed on the golden model's host node (2026-10-04). | | `SMUDGE` `HIDDEN` | CC | `SMUDGE` toggles the hidden flag of the newest entry; `HIDDEN` sets it. v3 refuses both outside compilation; that check comes with the compiler words. Executed on the golden model's host node (2026-10-04). | -| `INTERPRET` | CC | | +| `INTERPRET` | CC | FORTH-79; source in `v4/capsule/compile.v4`. Takes words from the input stream until it is exhausted: a word in the dictionary is executed, or, when compiling and not immediate, compiled; anything else must be a number in the current `BASE` (a single cell, with an optional leading minus), left on the stack or compiled as a literal. What is neither, or a compile-only word met while interpreting, abandons the line: compiling stops, the definition under way stays hidden, the rest of the input is skipped and `NODE-ERROR` is set (the message and the stack reset come with `QUIT`). Executed on the golden model's host node (2026-10-04). | An entry, as `v4/capsule/dict.v4` builds it. A word's execution address (xt) is the address of its code, and everything else is found from it: @@ -713,7 +713,7 @@ it, `xt + 1`; for any other word the parameter field is the code itself. | Word | Fate | Notes | | --- | --- | --- | | `(` `\` | CC | `(` is `41 WORD drop`; `\` is `SPAN @ >IN !`. In `v4/capsule/input.v4` under the names `PAREN` and `BACKSLASH`. Executed on the golden model's host node (2026-10-04). | -| `EXECUTE` | CAP | `push ;` (tail-jumps to the xt; the xt returns to `EXECUTE`'s caller) | +| `EXECUTE` | CAP | `push ;` (tail-jumps to the xt; the xt returns to `EXECUTE`'s caller). Executed on the golden model's host node (2026-10-04). | | `NOP` | OP | `nop` | | `QUIT` `ABORT` `ABORT"` `(ABORT")` `COLD` `WARM` | CC | | | `BYE` `REBOOT` | HERA | | @@ -732,10 +732,35 @@ it, `xt + 1`; for any other word the parameter field is the code itself. | Word | Fate | Notes | | --- | --- | --- | -| `:` `;` `CREATE` `VARIABLE` `CONSTANT` `DOES>` `IMMEDIATE` `STATE` `[` `]` `LITERAL` `COMPILE` `[COMPILE]` `FORGET` `FENCE` | CC | | +| `:` `;` `EXIT` `IMMEDIATE` `STATE` `[` `]` `LITERAL` `COMPILE` `[COMPILE]` | CC | Source in `v4/capsule/compile.v4`, all to FORTH-79. `:` makes an entry and starts compiling; the word cannot be found until `;`, so a redefinition can use the old word. `;` lays the return, reveals the word and stops compiling. `LITERAL` compiles the number on the stack when compiling. `COMPILE xxx` lays code that compiles `xxx` when the word it is in runs; `[COMPILE] xxx` compiles `xxx` though it is immediate. Executed on the golden model's host node (2026-10-04) against results recorded from the v3 binary; v3's `COMPILE` does not work (`: C1 COMPILE DUP ; IMMEDIATE : U3 C1 + ;` gives `DUP: Stack underflow`), reported, not fixed. | +| `CREATE` `VARIABLE` `CONSTANT` `DOES>` | CC | FORTH-79. A data word's code is one instruction word, a call to its run-time routine, and its parameter field is the cell after it: `(DOVAR)` is `pop ;` (the call's return address is the parameter field's address) and `(DOCON)` is `pop a! @ ;`. `VARIABLE` allots one cell, set to 0. `DOES>` lays a call to `(DOES)` and then `pop`: `(DOES)`, run by the defining word, rewrites the newest entry's code into a call to the code after it and returns from the defining word; that code's `pop` fetches the parameter field address. Executed on the golden model's host node (2026-10-04) against results recorded from the v3 binary. | +| `FORGET` `FENCE` | CC | | | `LIT` | OP | `@p` | | `does_rt` | RET | Internal helper; `DOES>` is implemented by the compiler capsule. | +**How a word is compiled.** v4 code is native: a colon definition is instruction words, and +compiling a word into one lays down a call to it. Two flags on an entry change that. An **in-line** +word's code is a straight run of opcodes and literals ending in `;`, and that run is copied in place +of a call; this is fate IN (§0), and everything that touches the return stack must be in line, since a +call would bury what it works on. A **compile-only** word may not be executed by the interpreter. +`v4/capsule/forth.v4` holds the first words of the vocabulary flagged this way (`DUP`, `+`, `>R`, `I`, +`LEAVE`, `@`, the in-line variables and so on). + +**The short stacks (D-2) and the compiler.** The interpreter and compiler run on the same ten-cell and +nine-entry stacks as the user's words, with the user's values beneath them. Two consequences are +built into the capsule: + +- Every word of the capsule keeps what it works on in memory and has at most three cells of its own on + the data stack. Measured on the golden model: a line may have **6 values on the stack** while the + interpreter reads its next word, and defining and running a word leaves 4 cells under it untouched. +- Words called from the interpreter may nest **8 deep**; a `DO` loop takes two return entries, so two + nested loops leave four. `*` is therefore not `UM* drop` on the host node but N steps of `+*` with + only the count on the return stack; it gives the same low cell (what `+*` loses at the top of `T` + takes N shifts to reach the bit that moves into `A`, and the loop ends first). + +A programme that v3 runs with more than that on its stacks does not run here; that is D-2, not the +compiler. + **The code generator** (`v4/capsule/codegen.v4`) is what these words are built on. It packs opcodes, literals and branches into instruction words at `HERE`, by the rules of §1.2 and §2: slots filled left to right, unused slots `nop`, a literal's value in the cell after its word, `;` `ex` and any branch @@ -761,7 +786,9 @@ lays down was then run. | Word | Fate | v4 definition / notes | | --- | --- | --- | -| `IF` `ELSE` `THEN` `BEGIN` `UNTIL` `AGAIN` `WHILE` `REPEAT` `DO` `?DO` `LOOP` `+LOOP` `LEAVE` `CASE` `OF` `ENDOF` `ENDCASE` | CC | Compile-time structure words. Expansions per §2 and below. | +| `IF` `ELSE` `THEN` `BEGIN` `UNTIL` `AGAIN` `WHILE` `REPEAT` `DO` `?DO` `LOOP` `+LOOP` | CC | Compile-time structure words, immediate and compile-only; source in `v4/capsule/compile.v4`. Expansions per §2 and below. What an opening word leaves for the word that closes it goes on a **control-flow stack in memory** (32 cells), not on the data stack, with a number saying which word left it; a closing word that finds the wrong number, or nothing, abandons the line. A loop that tests at its end (`UNTIL`) must drop the flag on both ways out, so `BEGIN` lays `jump L0 Ld: drop L0:` and `UNTIL` lays `if Ld drop`. Executed on the golden model's host node (2026-10-04): the code laid down for each is word for word what the text assembler makes of the expansion given here, and the programmes run give what the v3 binary gave. | +| `LEAVE` `I` `J` `UNLOOP` | CC | In-line words (below), compile-only. | +| `CASE` `OF` `ENDOF` `ENDCASE` | CC | | | `EXIT` | OP | `;` | | `(BRANCH)` | OP | `jump` | | `(0BRANCH)` | IN | `if L … drop` (§2) — executed on the golden model (2026-10-03) as `IF 1 ELSE 2 THEN`, including results recorded from the v3 binary. | diff --git a/v4/capsule/compile.v4 b/v4/capsule/compile.v4 new file mode 100644 index 00000000..8434c87d --- /dev/null +++ b/v4/capsule/compile.v4 @@ -0,0 +1,348 @@ +\ compile.v4 -- the interpreter's inner loop, and the defining and compiling +\ words. +\ +\ DECOMPOSITION.md 5.17 and 5.18: STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE +\ [COMPILE] ' EXECUTE CREATE VARIABLE CONSTANT DOES>, the control structures +\ IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP, and INTERPRET, +\ which they cannot be run without. Part of the compiler capsule. Rests on +\ core.v4, input.v4, dict.v4 and codegen.v4. +\ +\ HOW A WORD IS COMPILED. v4 code is native: a colon definition is +\ instruction words, and compiling a word into one lays down a call to it. +\ Two flags on an entry (dict.v4) change that: +\ inline its code is a straight run of opcodes and literals ending +\ in ; -- that run is copied in place of a call. Everything +\ that touches the return stack must be, since a call would +\ bury what it works on (DECOMPOSITION.md 0, fate IN). +\ compile-only it may not be executed by the interpreter. +\ An immediate word is executed even when compiling. +\ +\ THE STACKS ARE SHORT (D-2): ten cells of data, nine return entries, and no +\ way to see how full they are. The interpreter and compiler run on the same +\ stacks as the user's words, with the user's values beneath them, so: +\ - every word here keeps what it works on in (C), and has at most three +\ cells of its own on the data stack at any moment; +\ - what an IF or a DO leaves for its THEN or LOOP goes on a control-flow +\ stack in memory, not on the data stack, so structures may nest as +\ deep as that stack (32 cells) allows whatever the user has stacked. +\ +\ Constants the loader supplies: +\ STATE word address of the variable: non-zero while compiling +\ (C) word address of eight cells of scratch for this file: +\ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot +\ (C)+2 LATEST before a header is made (C)+3 a data word's routine +\ (C)+6 (C)+7 a branch and a tag a control word is holding +\ (CFP) word address of the control-flow stack's pointer +\ CFBASE CFEND word addresses of its first cell and of the cell past its last + +macro ROT push SWAP pop SWAP endmacro + +\ ---- errors ------------------------------------------------------------------ + +\ ( -- ) give up the line: stop compiling, forget the word being built and +\ whatever control structures were open, skip the rest of the input, and set +\ NODE-ERROR. A definition that was under way stays hidden. (QUIT will add +\ the message and the stack reset.) +: (ABANDON) + 0 STATE a! ! (CG-RESET) + CFBASE (CFP) a! ! + SPAN a! @ >IN a! ! + NODE-ERROR b! -1 !b ; + +\ ---- the control-flow stack ---------------------------------------------------- + +\ ( x -- ) push; a full stack abandons the line +: >CF + (CFP) a! @ CFEND xor if FULL + drop (CFP) a! @ dup 1 + ! a! ! ; + FULL: drop drop jump (ABANDON) + +\ ( -- x ) pop; 0 from an empty stack, which no opening word leaves +: CF> + (CFP) a! @ CFBASE xor if EMPTY + drop (CFP) a! @ -1 + dup ! a! @ ; + EMPTY: ; + +\ ---- compiling one word ------------------------------------------------------ + +\ ( x n -- x' ) x shifted right n places; the bits that come in at the top +\ are masked off by the caller +: (RSHIFT) if Z -1 + push L: 2/ next L ; Z: drop ; + +\ ( xt -- ) copy the in-line word at xt into the definition being built +: (INLINE,) + W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it + 0 (C)+4 a! ! \ slot + S: (C)+4 a! @ (LOWBIT) (C) a! @ SWAP (RSHIFT) 31 and \ op + if END \ ; ends the copy + dup -8 + if LIT + drop dup -28 + if NOP \ nop is padding + drop (OP,) + NXT: (C)+4 a! @ 1 + dup ! -6 + if NEXTW drop jump S + NEXTW: drop (C)+1 a! @ jump W \ the next instruction word follows the literals + LIT: drop drop (C)+1 a! @ dup 1 + ! a! @ (LIT,) jump NXT + NOP: drop drop jump NXT + END: drop ; + +\ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call +: (COMPILE,) + dup (FLAGS) a! @ 8 and if CALL drop jump (INLINE,) + CALL: drop jump (CALL,) + +header EXECUTE +: EXECUTE ( xt -- ) push ; + +\ ---- the interpreter's inner loop --------------------------------------------- + +\ ( -- n flag ) the word WORD has just left, as a single-cell number in the +\ current BASE, and -1; or 0 0 if it is not one. A leading minus sign is +\ allowed. This is what the interpreter uses: NUMBER (input.v4) makes a +\ double and needs more of the stack than can be spared here. +\ (P)+2 the number so far, (P)+3 where it is in the word, (P)+4 the word's +\ length, (P)+5 the sign, (P)+6 the base. +: (NUM?) + WBUF C@ if EMPTY + (P)+4 a! ! 0 (P)+2 a! ! 1 (P)+3 a! ! 0 (P)+5 a! ! + (BASE) (P)+6 a! ! + WBUF+1 C@ -45 + if NEG drop jump DIGITS + NEG: drop -1 (P)+5 a! ! 2 (P)+3 a! ! + (P)+4 a! @ -1 + if EMPTY drop \ a sign alone + DIGITS: + L: (P)+4 a! @ (P)+3 a! @ - -if MORE + drop (P)+2 a! @ (P)+5 a! @ if POS drop NEGATE -1 ; + POS: drop -1 ; + MORE: drop + (P)+3 a! @ dup 1 + ! WBUF + C@ (DIGIT) \ d + -if DIGIT jump BAD1 + DIGIT: dup (P)+6 a! @ - -if BAD2 drop + (P)+2 a! @ (P)+6 a! @ STAR + (P)+2 a! ! + jump L + BAD2: drop + BAD1: drop 0 0 ; + EMPTY: drop 0 0 ; + +\ ( -- ) FORTH-79: take words from the input stream until it is exhausted. +\ A word in the dictionary is executed, or, when compiling and not immediate, +\ compiled. Anything else must be a number in the current BASE: it is left +\ on the stack, or compiled as a literal. What is neither, or a compile-only +\ word met while interpreting, abandons the line. +header INTERPRET +: INTERPRET + L: 32 WORD dup C@ if EOL + drop (LOOKUP) if NUM + dup (FLAGS) a! @ \ xt flags + STATE a! @ if INTERP + drop 1 and if COMP \ compiling: immediate words still run + drop EXECUTE jump L + COMP: drop (COMPILE,) jump L + INTERP: drop 16 and if RUN + drop drop jump (ABANDON) + RUN: drop EXECUTE jump L + NUM: drop (NUM?) if BAD + drop + STATE a! @ if KEEP drop (LIT,) jump L + KEEP: drop jump L + BAD: drop drop jump (ABANDON) + EOL: drop drop ; + +\ ---- state --------------------------------------------------------------------- + +header [ immediate +: LEFT-BRACKET 0 STATE a! ! ; +header ] +: RIGHT-BRACKET -1 STATE a! ! ; + +\ ( x -- ) FORTH-79: if compiling, compile x as a literal +header LITERAL immediate +: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ; + +\ ( -- addr ) FORTH-79: the next word's parameter field address; if +\ compiling, compiled as a literal +header ' immediate +: TICK (') jump LITERAL + +\ ---- colon definitions ----------------------------------------------------------- + +\ ( -- flag ) an entry for the next word in the input stream; -1 if one was +\ made. (C)+2 holds LATEST meanwhile, to tell. +: (NAMED) + LATEST (C)+2 a! ! + 32 WORD (HEADER) + LATEST (C)+2 a! @ xor if NONE drop -1 ; + NONE: ; + +\ FORTH-79: start a definition; it cannot be found until ; ends it +header : +: COLON + (NAMED) if NONE drop + HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET + NONE: drop ; + +\ FORTH-79: compile the return, let the word be found, stop compiling +header ; immediate compile-only +: SEMICOLON + 0 (OP,) + LATEST (FLAGS) a! @ -3 and ! + jump LEFT-BRACKET + +\ FORTH-79: return from the definition at this point +header EXIT immediate compile-only +: EXIT 0 jump (OP,) + +header IMMEDIATE +: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ; + +\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled +header COMPILE immediate compile-only +: COMPILE + 32 WORD (LOOKUP) if MISSING + (LIT,) &(COMPILE,) jump (CALL,) + MISSING: drop jump (ABANDON) + +\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate +header [COMPILE] immediate compile-only +: BRACKET-COMPILE + 32 WORD (LOOKUP) if MISSING jump (COMPILE,) + MISSING: drop jump (ABANDON) + +\ ---- data words --------------------------------------------------------------------- +\ A data word's code is one call to its run-time routine; the call leaves the +\ address of the cell after it -- the parameter field -- on the return stack. + +: (DOVAR) pop ; \ leave the parameter field address +: (DOCON) pop a! @ ; \ leave what it holds + +\ ( -- flag ) an entry for the next word, flagged data, its code a call to +\ the routine whose address is in (C)+3; -1 if one was made +: (DATA) + LATEST (C)+2 a! ! \ (NAMED), in line: the calls + 32 WORD (HEADER) \ below this are deep enough + LATEST (C)+2 a! @ xor if NONE drop + (CG-RESET) + LATEST (FLAGS) a! @ 4 OR ! + (C)+3 a! @ (CALL,) -1 ; + NONE: ; + +\ FORTH-79: an entry whose word leaves the address of its parameter field +header CREATE +: CREATE &(DOVAR) (C)+3 a! ! (DATA) drop ; + +\ FORTH-79: CREATE and one cell. The standard leaves its first value to the +\ programme; here it is 0. +header VARIABLE +: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) if NONE drop 0 jump , NONE: drop ; + +\ ( n -- ) FORTH-79: an entry whose word leaves n +header CONSTANT +: CONSTANT &(DOCON) (C)+3 a! ! (DATA) if NONE drop jump , NONE: drop drop ; + +\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become +\ what each word DEFINER makes does, starting with its parameter field address +\ on the stack. (DOES), run by DEFINER, turns the newest entry's code into a +\ call to the code after it and leaves DEFINER; that code starts with pop, +\ which fetches the parameter field address the call left. +: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0 +header DOES> immediate compile-only +: DOES> &(DOES) (CALL,) 25 jump (OP,) + +\ ---- 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 +\ finds the wrong number abandons the line. + +\ ( tag wanted -- ) if they differ, abandon the line and leave the control +\ word that called this as well: its return address is dropped, so the +\ abandoning returns to the interpreter and nothing more is laid down. +: (PAIR) xor if OK drop pop drop jump (ABANDON) OK: drop ; + +\ ( ref -- ) the branch at ref lands here +: (HERE!) (LABEL) SWAP jump (RESOLVE) + +\ Native if leaves the flag, so both ways out of it drop it (section 2): +\ IF a THEN if L1 drop a jump L2 L1: drop L2: +\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2: +header IF immediate compile-only +: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF +header ELSE immediate compile-only +: ELSE + CF> 1 (PAIR) CF> (C)+6 a! ! \ the if + 2 (BRANCH>) >CF \ the jump over the else part + (C)+6 a! @ (HERE!) 23 (OP,) + 2 jump >CF +header THEN immediate compile-only +: THEN + CF> dup -1 + if PLAIN + drop 2 (PAIR) CF> jump (HERE!) + PLAIN: drop drop + CF> (C)+6 a! ! \ the if + 2 (BRANCH>) >CF + (C)+6 a! @ (HERE!) 23 (OP,) + CF> jump (HERE!) + +\ A loop that tests at its end jumps back with the flag still there, so it +\ jumps back to a drop laid just ahead of the body: +\ BEGIN a UNTIL jump L0 Ld: drop L0: a if Ld drop +\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop +\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0 +\ The control-flow stack holds Ld, L0 and 3. +header BEGIN immediate compile-only +: BEGIN + 2 (BRANCH>) (C)+6 a! ! + (LABEL) >CF 23 (OP,) + (LABEL) dup >CF (C)+6 a! @ (RESOLVE) + 3 jump >CF +header UNTIL immediate compile-only +: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,) +header AGAIN immediate compile-only +: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ; +header WHILE immediate compile-only +: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF +header REPEAT immediate compile-only +: REPEAT + CF> 4 (PAIR) CF> (C)+6 a! ! \ the while + CF> 3 (PAIR) CF> (JUMP,) CF> drop + (C)+6 a! @ (HERE!) 23 jump (OP,) + +\ DO loops: the limit and index are on the return stack, limit below (5.18). +: (do) over push push drop ; +: (?do) over over xor ; +: (inc) pop 1 + pop ; \ index' limit +: (+inc) dup a! pop + pop ; \ index' limit A: the step +: (differ) drop over ; +: (same) drop over over - ; +: (a-xor) a xor ; +: (again) drop push push ; +: (3drop) drop drop drop ; + +\ lay : ( i' lim -- i' lim s ), the top bit of s set when i' < lim +: (LESS,) + &(?do) (INLINE,) 7 (BRANCH>) >CF + &(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! ! + CF> (HERE!) &(same) (INLINE,) + (C)+6 a! @ jump (HERE!) + +\ The end of a loop, after its increment and test. The control-flow stack +\ holds the body's address and 5, or for ?DO its skip, the body and 6. +\ -if EXIT drop push push jump BODY EXIT: drop drop drop +\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST: +: (LOOP-END) + CF> (C)+7 a! ! \ the tag + 7 (BRANCH>) (C)+6 a! ! + &(again) (INLINE,) CF> (JUMP,) + (C)+6 a! @ (HERE!) &(3drop) (INLINE,) + (C)+7 a! @ -5 + if PLAIN + drop (C)+7 a! @ 6 (PAIR) + 2 (BRANCH>) (C)+6 a! ! + CF> (HERE!) &(3drop) (INLINE,) + (C)+6 a! @ jump (HERE!) + PLAIN: drop ; + +header DO immediate compile-only +: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF +header ?DO immediate compile-only +: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF +header LOOP immediate compile-only +: LOOP &(inc) (INLINE,) (LESS,) jump (LOOP-END) +header +LOOP immediate compile-only +: +LOOP &(+inc) (INLINE,) (LESS,) &(a-xor) (INLINE,) jump (LOOP-END) diff --git a/v4/capsule/forth.v4 b/v4/capsule/forth.v4 new file mode 100644 index 00000000..2be89f3c --- /dev/null +++ b/v4/capsule/forth.v4 @@ -0,0 +1,72 @@ +\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are +\ opcodes or short runs of them, and the variables that are in-line addresses. +\ +\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18). +\ A word flagged inline is copied into a definition in place of a call; the +\ ones that touch the return stack are compile-only as well. Rests on core.v4 +\ and compile.v4's loader constants. + +\ ---- stack ---- +header DUP inline : DUP dup ; +header DROP inline : DROP drop ; +header OVER inline : OVER over ; +header SWAP inline : SWAP' SWAP ; +header ROT inline : ROT' ROT ; +header -ROT inline : -ROT SWAP push SWAP pop ; +header ?DUP : ?DUP if Z dup ; Z: ; +header 2DUP inline : 2DUP over over ; +header 2DROP inline : 2DROP drop drop ; + +\ ---- return stack: in line, and only inside a definition ---- +header >R inline compile-only : >R push ; +header R> inline compile-only : R> pop ; +header R@ inline compile-only : R@ pop dup push ; +header I inline compile-only : I pop dup push ; +header J inline compile-only : J pop pop pop dup push a! push push a ; +header LEAVE inline compile-only : LEAVE pop pop drop dup push push ; +header UNLOOP inline compile-only : UNLOOP pop drop pop drop ; + +\ ---- memory ---- +header @ inline : FETCH a! @ ; +header ! inline : STORE a! ! ; +header +! inline : +! a! @ + ! ; +header CELLS inline : CELLS ; \ an address unit is a cell (D-1) + +\ ---- arithmetic ---- +header + inline : PLUS + ; +header - inline : MINUS - ; +\ The low cell of the product, by N steps of +* with nothing but the count on +\ the return stack. UM* drop gives the same cell but needs two more return +\ entries, which a word inside two DO loops does not have (D-2). The low +\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach +\ the bit that moves into A, and the loop ends first. +header * : STAR a! 0 N-1 FOR +* UNEXT drop drop a ; +header NEGATE inline : NEGATE' NEGATE ; +header 1+ inline : 1+ 1 + ; +header 1- inline : 1- -1 + ; +header 2+ inline : 2+ 2 + ; +header 2- inline : 2- -2 + ; +header 2* inline : TWO* 2* ; +header 2/ inline : TWO/ 2/ ; + +\ ---- logic and comparison ---- +header AND inline : AND and ; +header XOR inline : XOR xor ; +header OR inline : OR' OR ; +header 0= : 0= if L1 drop 0 ; L1: drop -1 ; +header 0< : 0< -if L1 drop -1 ; L1: drop 0 ; +header NOT : NOT jump 0= +header = : EQUALS xor jump 0= +header < : LESS + over over xor -if SAME drop drop jump 0< + SAME: drop - jump 0< +header > : GREATER SWAP jump LESS + +\ ---- in-line addresses and constants ---- +header BL inline : BL' BL ; +header TIB inline : TIB' TIB ; +header >IN inline : >IN' >IN ; +header SPAN inline : SPAN' SPAN ; +header BASE inline : BASE' BASE ; +header PAD inline : PAD' PAD ; +header STATE inline : STATE' STATE ; diff --git a/v4/tests/test_host_compile.c b/v4/tests/test_host_compile.c new file mode 100644 index 00000000..f8a3fb47 --- /dev/null +++ b/v4/tests/test_host_compile.c @@ -0,0 +1,398 @@ +/* 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; v3 prints UNKNOWN WORD. The message comes with QUIT. + */ +#include "v4/text.h" +#include "v4/testcode.h" +#include +#include +#include + +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 }, +}; +#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", "forth.v4" }; + CHECK(host_load(&tx, &n, files, 6), "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"); + + /* ---- 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"); + 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); + } + } + + /* ---- how many values a line may have on the stack ---- */ + { + char line[96]; + unsigned k, most = 0; + new_session(); + for (k = 1; k <= 9; k++) { + size_t at = 0; + unsigned m; + for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "%u ", m + 1); + for (m = 1; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "+ "); + if (one(line) == (v4_cell)(k * (k + 1) / 2)) 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 ---- */ + { + char line[64]; + unsigned depth = 0; + new_session(); + CHECK(ok(": N0 1+ ;"), "N0"); + for (i = 1; i <= 8; i++) { + snprintf(line, sizeof line, ": N%u N%u 1+ ;", i, i - 1); + CHECK(ok(line), "N%u compiles", i); + } + for (i = 0; i <= 8; i++) { + snprintf(line, sizeof line, "0 N%u", i); + if (one(line) == (v4_cell)(i + 1)) depth = i + 1; else break; + } + printf(" words called from the interpreter may nest %u deep\n", depth); + CHECK(depth >= 5, "a few levels of calls work from the interpreter"); + } + /* 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; +}