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 <noreply@anthropic.com>
This commit is contained in:
rajames
co-authored by
Claude Opus 5.5
Claude Opus 5.5
parent
bbd1b4047f
commit
dac7ffac92
@@ -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. |
|
||||
|
||||
@@ -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 <less>: ( 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)
|
||||
@@ -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 ;
|
||||
@@ -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 <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
static int failures = 0, checks = 0;
|
||||
#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0)
|
||||
|
||||
#define CANARY ((v4_cell)0x0C0FFEE5)
|
||||
|
||||
#include "host_map.h"
|
||||
|
||||
static v4_node n, ref;
|
||||
static v4_exec_state es;
|
||||
static v4_heat h;
|
||||
static v4_text tx, rtx;
|
||||
static v4_cell w_interpret, capsule_latest;
|
||||
|
||||
static void put_bytes(v4_cell baddr, const void *src, unsigned len)
|
||||
{
|
||||
const unsigned char *s = (const unsigned char *)src;
|
||||
for (unsigned i = 0; i < len; i++) {
|
||||
v4_cell ba = baddr + (v4_cell)i;
|
||||
unsigned sh = 8u * (unsigned)(ba & 3);
|
||||
v4_ucell w = (v4_ucell)n.mem[ba >> 2];
|
||||
n.mem[ba >> 2] = (v4_cell)((w & ~((v4_ucell)0xFFu << sh)) | ((v4_ucell)s[i] << sh));
|
||||
}
|
||||
}
|
||||
|
||||
/* An empty dictionary above the capsule's own words. */
|
||||
static void new_session(void)
|
||||
{
|
||||
for (v4_cell i = DICT_W; i < DICT_END_W; i++) n.mem[i] = 0;
|
||||
n.mem[DP] = DICT_W * 4;
|
||||
n.mem[LATEST] = capsule_latest;
|
||||
n.mem[STATE] = 0;
|
||||
n.mem[CFP] = CFS_W;
|
||||
n.mem[BASE] = 10;
|
||||
n.mem[NODE_ERROR] = 0;
|
||||
}
|
||||
/* INTERPRET one line, as QUERY would have left it in TIB. The data stack
|
||||
* starts with the canary alone; `depth` extra marked cells go under it and
|
||||
* `rdepth` under the return address, for the headroom tests. True when
|
||||
* INTERPRET returns. */
|
||||
static int interpret_with(const char *line, unsigned depth, unsigned rdepth)
|
||||
{
|
||||
unsigned len = (unsigned)strlen(line), i;
|
||||
put_bytes(TIB, line, len + 1u);
|
||||
n.mem[SPAN] = (v4_cell)len;
|
||||
n.mem[TO_IN] = 0;
|
||||
n.mem[NODE_ERROR] = 0;
|
||||
v4_dstack_reset(&n.ds);
|
||||
v4_rstack_reset(&n.rs);
|
||||
v4_exec_reset(&es);
|
||||
v4_heat_reset(&h);
|
||||
for (i = 0; i < depth; i++) v4_dstack_push(&n.ds, (v4_cell)(0x5A000000 + i));
|
||||
v4_dstack_push(&n.ds, CANARY);
|
||||
for (i = 0; i < rdepth; i++) v4_rstack_push(&n.rs, (v4_cell)(0x6B000000 + i));
|
||||
return v4_test_call(&n, &es, &h, w_interpret, 4000000) > 0;
|
||||
}
|
||||
static int interpret(const char *line) { return interpret_with(line, 0, 0); }
|
||||
static v4_cell pop(void) { return v4_dstack_pop(&n.ds); }
|
||||
static int clean(void) { return pop() == CANARY; }
|
||||
static int err(void) { return n.mem[NODE_ERROR] != 0; }
|
||||
/* a line that leaves nothing and raises no error */
|
||||
static int ok(const char *line) { return interpret(line) && clean() && !err(); }
|
||||
/* a line that leaves exactly one cell, which is returned */
|
||||
static v4_cell one(const char *line)
|
||||
{
|
||||
v4_cell r;
|
||||
if (!interpret(line) || err()) return (v4_cell)0x0BADBAD;
|
||||
r = pop();
|
||||
return clean() ? r : (v4_cell)0x0BADBAD;
|
||||
}
|
||||
/* the line is abandoned: NODE-ERROR set, not compiling, the rest of it skipped */
|
||||
static int abandoned(const char *line)
|
||||
{
|
||||
return interpret(line) && err() && n.mem[STATE] == 0 && n.mem[TO_IN] == n.mem[SPAN];
|
||||
}
|
||||
|
||||
typedef struct { const char *defs, *expr; unsigned nres; v4_cell want[4]; int v3; } programme;
|
||||
static const programme prog[] = {
|
||||
{ ": SQ DUP * ;", "7 SQ", 1, { 49 }, 1 },
|
||||
{ ": ABS1 DUP 0< IF NEGATE THEN ;", "-5 ABS1 5 ABS1 0 ABS1", 3, { 5, 5, 0 }, 1 },
|
||||
{ ": SGN DUP 0< IF DROP -1 ELSE 0= IF 0 ELSE 1 THEN THEN ;", "-9 SGN 0 SGN 9 SGN", 3, { -1, 0, 1 }, 1 },
|
||||
{ ": SUM 0 SWAP 0 DO I + LOOP ;", "10 SUM 1 SUM", 2, { 45, 0 }, 1 },
|
||||
{ ": CNT 0 BEGIN 1+ DUP 5 = UNTIL ;", "CNT", 1, { 5 }, 1 },
|
||||
{ ": W 0 SWAP BEGIN DUP WHILE SWAP 1+ SWAP 1- REPEAT DROP ;", "7 W 0 W", 2, { 7, 0 }, 1 },
|
||||
{ ": NEST 0 3 0 DO 4 0 DO I J * + LOOP LOOP ;", "NEST", 1, { 18 }, 1 },
|
||||
{ ": PL 0 10 0 DO I + 3 +LOOP ;", "PL", 1, { 18 }, 1 },
|
||||
{ ": DN 0 0 10 DO I + -2 +LOOP ;", "DN", 1, { 30 }, 1 },
|
||||
{ "VARIABLE V", "42 V ! V @ 5 V +! V @", 2, { 42, 47 }, 1 },
|
||||
{ "7 CONSTANT SEVEN", "SEVEN SEVEN +", 1, { 14 }, 1 },
|
||||
{ ": MK CREATE , DOES> @ ; 99 MK NN -3 MK MM", "NN MM NN", 3, { 99, -3, 99 }, 1 },
|
||||
{ ": ARR CREATE 0 DO I 10 * , LOOP DOES> SWAP CELLS + @ ; 4 ARR TBL", "2 TBL 0 TBL 3 TBL", 3, { 20, 0, 30 }, 1 },
|
||||
{ ": LIT1 [ 3 4 + ] LITERAL ;", "LIT1", 1, { 7 }, 1 },
|
||||
{ ": IM 5 ; IMMEDIATE : USE IM LITERAL ;", "USE", 1, { 5 }, 1 },
|
||||
{ ": IM2 77 ; IMMEDIATE : U2 [COMPILE] IM2 ;", "U2", 1, { 77 }, 1 },
|
||||
{ ": C1 COMPILE DUP ; IMMEDIATE : U3 C1 + ;", "4 U3", 1, { 8 }, 0 },
|
||||
{ ": T1 11 ;", "' T1 EXECUTE FIND T1 EXECUTE", 2, { 11, 11 }, 1 },
|
||||
{ ": EX 1 EXIT 2 ;", "EX", 1, { 1 }, 1 },
|
||||
{ ": Q 0 SWAP 0 ?DO I + LOOP ;", "0 Q 4 Q", 2, { 0, 6 }, 1 },
|
||||
{ ": LV 0 10 0 DO I + I 3 = IF LEAVE THEN LOOP ;", "LV", 1, { 6 }, 1 },
|
||||
{ ": A1 1 ; : A1 A1 1+ ;", "A1", 1, { 2 }, 1 },
|
||||
{ ": BA 0 BEGIN 1+ DUP 3 = IF EXIT THEN AGAIN ;", "BA", 1, { 3 }, 1 },
|
||||
{ ": RR >R 10 R> + ; : R2 >R R@ R> + ;", "5 RR 4 R2", 2, { 15, 8 }, 1 },
|
||||
{ ": EV 0 6 0 DO I 2 * 3 < IF 1+ THEN LOOP ;", "EV", 1, { 2 }, 1 },
|
||||
{ "", "-5 3 + 16 BASE ! FF A BASE !", 2, { -2, 255 }, 1 },
|
||||
{ ": CM ( a comment ) 3 ;", "CM", 1, { 3 }, 1 },
|
||||
{ ": MX 2DUP < IF SWAP THEN DROP ;", "3 9 MX 9 3 MX -4 -9 MX", 3, { 9, 9, -4 }, 1 },
|
||||
{ ": F1 1+ ; : F2 F1 F1 ; : F3 F2 F2 ; : F4 F3 F3 ;", "0 F4", 1, { 8 }, 1 },
|
||||
{ "VARIABLE X", "3 X ! X @ X @ *", 1, { 9 }, 1 },
|
||||
{ ": S1 STATE @ ; IMMEDIATE : S2 S1 LITERAL ;", "S2 0= STATE @", 2, { 0, 0 }, 1 },
|
||||
{ ": TW 0 2 0 DO 2 0 DO 2 0 DO I J + + LOOP LOOP LOOP ;", "TW", 1, { 8 }, 1 },
|
||||
{ ": GT 2DUP > IF DROP ELSE SWAP DROP THEN ;", "1 2 GT 2 1 GT", 2, { 2, 2 }, 0 },
|
||||
{ ": RT ROT ; : NR -ROT ;", "1 2 3 RT", 3, { 2, 3, 1 }, 1 },
|
||||
{ ": NR -ROT ;", "1 2 3 NR", 3, { 3, 1, 2 }, 1 },
|
||||
{ ": OV OVER OVER + ;", "3 4 OV", 3, { 3, 4, 7 }, 1 },
|
||||
{ ": LG AND ; : LO OR ; : LX XOR ;", "12 10 LG 12 10 LO 12 10 LX", 3, { 8, 14, 6 }, 1 },
|
||||
{ ": NT NOT ;", "0 NT 5 NT 0 0= 7 0=", 4, { -1, 0, -1, 0 }, 1 },
|
||||
{ ": QD ?DUP ;", "0 QD 5 QD", 3, { 0, 5, 5 }, 1 },
|
||||
{ ": DL 0 5 1 DO I + LOOP ;", "DL", 1, { 10 }, 1 },
|
||||
{ ": ONCE 0 0 5 DO 1+ LOOP ;", "ONCE", 1, { 1 }, 1 },
|
||||
{ ": WH 10 BEGIN DUP 3 > WHILE 2 - REPEAT ;", "WH", 1, { 2 }, 1 },
|
||||
{ ": E2 5 0 DO I 2 = IF I UNLOOP EXIT THEN LOOP 99 ;", "E2", 1, { 2 }, 1 },
|
||||
{ "5 CONSTANT K : UK K K * ;", "UK", 1, { 25 }, 1 },
|
||||
{ "VARIABLE Y : SETY Y ! ; : GETY Y @ ;", "8 SETY GETY", 1, { 8 }, 1 },
|
||||
{ ": IFS 0= IF 10 ELSE 20 THEN ;", "0 IFS 1 IFS", 2, { 10, 20 }, 1 },
|
||||
{ ": DEEP 1 IF 2 IF 3 IF 4 ELSE 5 THEN ELSE 6 THEN ELSE 7 THEN ;", "DEEP", 1, { 4 }, 1 },
|
||||
{ ": TM 2* 2* 1- 2/ ;", "5 TM", 1, { 9 }, 1 },
|
||||
{ ": NEG NEGATE ;", "7 NEG -7 NEG", 2, { -7, 7 }, 1 },
|
||||
};
|
||||
#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;
|
||||
}
|
||||
Reference in New Issue
Block a user