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

fix(v4.0.0): shorter chains of calls in the compiler capsule

Browse Source 
Measured, compiling a DO loop left one return entry spare under
INTERPRET and a defining word called from inside another word
overflowed the nine-entry return stack (D-2); the prompt loop will take
one more.

C@ and C! shift without a loop.  The code generator shifts each opcode
into the word being built, so nothing is placed by a counted shift, and
the address masks come from a table.  The dictionary search, the
in-liner, the end of a loop and the making of a data word are each one
word reached by a jump.

Every kind of line now leaves at least three return entries spare while
it compiles; a word run from the interpreter has six; and CREATE ...
DOES> works from the prompt, from a word, and from a word that calls
that.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 11:17:58 -04:00
co-authored by Claude Opus 5.5
parent dac7ffac92
commit 806f876ee0
9 changed files with 165 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files
docs/v4.0.0/DECOMPOSITION.md
+7 -2
View File
@@ -753,8 +753,13 @@ 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
- The capsule's words call each other as little as they can: byte access shifts without a loop,
opcodes are shifted into the word being built instead of placed by a counted shift, and the long
jobs (laying a loop's end, making a data word) are single words reached by a jump. Measured on the
golden model: a word run from the interpreter has **6 return entries** to itself, every kind of
line leaves at least 3 spare while it is compiled, and a defining word (`CREATE … DOES>`) works
from the prompt, from a word, and from a word that calls that. A `DO` loop takes two return
entries. `*` 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).
v4/capsule/codegen.v4
+32 -29
View File
@@ -19,44 +19,46 @@
\ bits whose lowest is bit 27 - 5k, and a branch there has 27 - 5k address bits.
\
\ Rests on core.v4 and dict.v4. Constants the loader supplies:
\ (CG) word address of thirteen cells of scratch for this file
\ (CG) word address of fourteen cells of scratch for this file
\ CG-BSLOTS how many slots, counted from slot 0, may hold a branch
\ Like WORD, these run under whatever the user has on the stacks, so what they
\ work on is in (CG) and they keep at most three cells of their own on the
\ data stack (D-2):
\ work on is in (CG), they keep at most three cells of their own on the data
\ stack, and they call each other as little as they can (D-2):
\ (CG)+0 the word being built (CG)+1 its next free slot
\ (CG)+2 how many literals it owes, and (CG)+3 .. (CG)+8 the literals
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH>) is making
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH0) made
\ (CG)+11 the target a branch is to reach (CG)+12 which literal (FLUSH) is at
\ (CG)+13 what (FLUSH) fills unused slots with: nop, or 0 after a branch
\
\ The word being built is kept right-justified: each opcode is shifted in
\ below the ones before it, and (FLUSH) shifts in what fills the rest and the
\ two spare bits. So nothing is ever shifted by a counted loop, which would
\ want a return-stack entry for its count.
\ ( x n -- x' ) x shifted left n places, n >= 0
: (LSHIFT) if Z -1 + push L: 2* next L ; Z: drop ;
\ ( k -- n ) the number of the lowest bit of slot k: 27 - 5k
: (LOWBIT) dup 2* 2* + NEGATE 27 + ;
\ ( k -- mask ) the address bits of a branch in slot k
: (MASK) (LOWBIT) 1 SWAP (LSHIFT) -1 + ;
\ ( k -- mask ) the address bits of a branch in slot k: 2^(27-5k) - 1
: (MASK)
if K0 -1 + if K1 -1 + if K2
drop 4095 ;
K2: drop 131071 ;
K1: drop 4194303 ;
K0: drop 134217727 ;
\ ( -- ) forget the word being built
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! ;
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! 28 (CG)+13 a! ! ;
\ ( op -- ) into the next free slot. The slot must be free. The shift is
\ (LSHIFT) in line; the slot's lowest bit is never bit 0, so it shifts at
\ least once.
\ ( x -- ) five bits into the next free slot, which must be free
: (PUT)
(CG)+1 a! @ dup 1 + ! \ op k
(LOWBIT) -1 + push L: 2* next L
(CG) a! @ + ! ;
(CG) a! @ 2* 2* 2* 2* 2* + !
(CG)+1 a! @ 1 + ! ;
\ ( -- ) append the word being built, its unused slots nop, then the
\ ( -- ) append the word being built, its unused slots filled, then the
\ literals it owes; nothing if no slot is in use
: (FLUSH)
(CG)+1 a! @ if EMPTY drop
P: (CG)+1 a! @ -6 + if FULL drop 28 (PUT) jump P
P: (CG)+1 a! @ -6 + if FULL drop (CG)+13 a! @ (PUT) jump P
FULL: drop
(CG) a! @ ,
(CG) a! @ 2* 2* , \ the two spare bits
0 (CG)+12 a! !
L: (CG)+12 a! @ (CG)+2 a! @ xor if DONE
drop (CG)+12 a! @ dup 1 + ! (CG)+3 + a! @ ,
@@ -85,16 +87,20 @@
\ ( op -- ) a branch (jump 2, call 3, next 5, if 6, -if 7) whose address is
\ not filled in yet. Its ref -- the branch's word address times 8, plus its
\ slot -- is left in (CG)+10. It ends by jumping to (FLUSH), so that the
\ chain of calls under it is one shorter.
\ slot -- is left in (CG)+10. The rest of its word is filled with 0, which
\ is its address field. It ends by jumping to (FLUSH), so that the chain of
\ calls under it is one shorter.
: (BRANCH0)
(CG)+1 a! @ CG-BSLOTS - -if MOVE drop jump PLACED
(CG)+1 a! @ CG-BSLOTS inv + 1 + -if MOVE drop jump PLACED \ slot - CG-BSLOTS
MOVE: drop (FLUSH)
PLACED:
\ the word will be appended at HERE; its literals, if any, come after it
HERE 2* 2* 2* (CG)+1 a! @ + (CG)+10 a! !
(PUT)
6 (CG)+1 a! ! jump (FLUSH)
0 (CG)+13 a! ! jump (FLUSH)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( ref -- ) put the address in (CG)+11 into the branch at ref
: (RESOLVE1)
@@ -106,9 +112,6 @@
\ ( target ref -- ) put the address into the branch at ref
: (RESOLVE) SWAP (CG)+11 a! ! jump (RESOLVE1)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( target op -- ) a branch to a known address
: (BRANCH,) SWAP (CG)+11 a! ! (BRANCH0) (CG)+10 a! @ jump (RESOLVE1)
v4/capsule/compile.v4
+47 -39
View File
@@ -28,10 +28,12 @@
\
\ 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) word address of ten 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)+5 what a loop's end lays after its test
\ (C)+6 (C)+7 a branch and a tag a control word is holding
\ (C)+8 whether a data word's entry was made
\ (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
@@ -65,15 +67,16 @@ macro ROT push SWAP pop SWAP endmacro
\ ---- 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 ;
\ ( w -- op ) the opcode in slot 0 of the instruction word w
: (TOP5) 8/ 8/ 8/ 2/ 2/ 2/ 31 and ;
\ ( xt -- ) copy the in-line word at xt into the definition being built
\ ( xt -- ) copy the in-line word at xt into the definition being built.
\ Each slot is read from the top of the word in (C)+0, which is then moved
\ up five bits for the next.
: (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
S: (C) a! @ dup 2* 2* 2* 2* 2* ! (TOP5) \ op
if END \ ; ends the copy
dup -8 + if LIT
drop dup -28 + if NOP \ nop is padding
@@ -86,7 +89,7 @@ macro ROT push SWAP pop SWAP endmacro
\ ( 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,)
dup -3 + a! @ 8 and if CALL drop jump (INLINE,)
CALL: drop jump (CALL,)
header EXECUTE
@@ -130,7 +133,7 @@ header INTERPRET
: INTERPRET
L: 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
dup (FLAGS) a! @ \ xt flags
dup -3 + a! @ \ xt flags
STATE a! @ if INTERP
drop 1 and if COMP \ compiling: immediate words still run
drop EXECUTE jump L
@@ -163,18 +166,13 @@ header ' immediate
\ ---- 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
\ FORTH-79: start a definition; it cannot be found until ; ends it.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
header :
: COLON
(NAMED) if NONE drop
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET
NONE: drop ;
@@ -212,29 +210,33 @@ header [COMPILE] immediate compile-only
: (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
\ ( -- ) an entry for the next word, flagged data, its code a call to the
\ routine whose address is in (C)+3. (C)+8 is left -1 if one was made, else
\ 0. It ends by jumping, and CREATE jumps to it, so that a defining word
\ has as few return entries under it as can be.
: (DATA)
LATEST (C)+2 a! ! \ (NAMED), in line: the calls
32 WORD (HEADER) \ below this are deep enough
0 (C)+8 a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
(CG-RESET)
LATEST (FLAGS) a! @ 4 OR !
(C)+3 a! @ (CALL,) -1 ;
NONE: ;
-1 (C)+8 a! !
(C)+3 a! @ jump (CALL,)
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
header CREATE
: CREATE &(DOVAR) (C)+3 a! ! (DATA) drop ;
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ 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 ;
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ 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 ;
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ 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
@@ -257,7 +259,7 @@ header DOES> immediate compile-only
: (PAIR) xor if OK drop pop drop jump (ABANDON) OK: drop ;
\ ( ref -- ) the branch at ref lands here
: (HERE!) (LABEL) SWAP jump (RESOLVE)
: (HERE!) (FLUSH) HERE 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:
@@ -315,18 +317,24 @@ header REPEAT immediate compile-only
: (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,)
\ The end of a loop. The control-flow stack holds the body's address and 5,
\ or for ?DO its skip, the body and 6; (C)+5 holds the xt of in-line code to
\ lay after the test, or 0. Laid down, in order:
\ <less> ( i' lim -- i' lim s ), the top bit of s set when i' < lim:
\ over over xor -if SAME drop over jump T SAME: drop over over - T:
\ the code in (C)+5, if any
\ -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:
\ It is one word, jumped to by LOOP and +LOOP, so that laying a loop's end
\ takes as few return entries as laying anything else.
: (LOOPS)
&(?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)
(C)+6 a! @ (HERE!)
(C)+5 a! @ if NOMORE (INLINE,) jump TESTED
NOMORE: drop
TESTED:
CF> (C)+7 a! ! \ the tag
7 (BRANCH>) (C)+6 a! !
&(again) (INLINE,) CF> (JUMP,)
@@ -343,6 +351,6 @@ header DO immediate compile-only
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)
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
header +LOOP immediate compile-only
: +LOOP &(+inc) (INLINE,) (LESS,) &(a-xor) (INLINE,) jump (LOOP-END)
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
v4/capsule/core.v4
+15 -8
View File
@@ -44,23 +44,30 @@ header DNEGATE
L1: drop 1 + ;
\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2). The result is the same.
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
header C@
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop @ 23 FOR 2/ UNEXT 255 and ;
K2: drop @ 15 FOR 2/ UNEXT 255 and ;
K1: drop @ 7 FOR 2/ UNEXT 255 and ;
drop @ 8/ 8/ 8/ 255 and ;
K2: drop @ 8/ 8/ 255 and ;
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
header C!
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and push 255 and pop
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;
K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;
K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;
K0: drop @ -256 and + ! ;
drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ;
K2: drop 8* 8* 16711680 and @ -16711681 and + ! ;
K1: drop 8* 65280 and @ -65281 and + ! ;
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
header CMOVE
v4/capsule/dict.v4
+21 -23
View File
@@ -118,12 +118,7 @@ header HIDDEN
\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count (D)+4 (CLIP)'s string
\ ( baddr -- baddr ) cut the counted string to 31 characters, in place
: (CLIP)
dup (D)+4 a! ! C@ -32 + -if LONG drop (D)+4 a! @ ;
LONG: drop 31 (D)+4 a! @ C! (D)+4 a! @ ;
\ (D)+3 a count
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
@@ -157,27 +152,30 @@ header HIDDEN
\ ---- looking a name up -----------------------------------------------------
\ ( -- flag ) the name of the entry in (D)+2 is the counted string in (D)+1
: (NAME=)
(D)+2 a! @ >NAME (D) a! !
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
L: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop 0 ;
EQ: drop jump L
SAME: drop -1 ;
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string.
\ Written out in one piece -- the string cut to 31, each entry's flags and
\ name fetched, the two names compared byte by byte -- so that the only call
\ it makes is C@: it is called from the interpreter for every word of every
\ line, with the user's return stack beneath it.
: (LOOKUP)
(CLIP) (D)+1 a! !
dup (D)+1 a! ! \ cut the string to 31 characters
C@ -32 + -if LONG drop jump CUT
LONG: drop 31 (D)+1 a! @ C!
CUT:
LATEST
L: if END
(D)+2 a! !
(D)+2 a! @ (FLAGS) a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop (NAME=) if DIFF drop (D)+2 a! @ ;
DIFF: drop
OLDER: (D)+2 a! @ >LINK a! @ jump L
(D)+2 a! @ -3 + a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop
(D)+2 a! @ -2 + a! @ 4* (D) a! ! \ its name
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
C: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop jump OLDER
EQ: drop jump C
SAME: drop (D)+2 a! @ ;
OLDER: (D)+2 a! @ -1 + a! @ jump L
END: ;
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
v4/tests/host_map.h
+2 -2
View File
@@ -33,8 +33,8 @@
/* each capsule file's scratch cells */
#define PVARS (TOP - 24) /* (P): input.v4, 8 cells */
#define DVARS (TOP - 32) /* (D): dict.v4, 5 cells */
#define CGVARS (TOP - 48) /* (CG): codegen.v4, 13 cells */
#define CVARS (TOP - 58) /* (C): compile.v4, 8 cells */
#define CGVARS (TOP - 48) /* (CG): codegen.v4, 14 cells */
#define CVARS (TOP - 62) /* (C): compile.v4, 10 cells */
/* buffers (word addresses; a byte address is four times this) */
#define CFS_W (TOP - 96) /* the control-flow stack, 32 cells */
v4/tests/test_host_codegen.c
+2 -7
View File
@@ -187,14 +187,9 @@ int main(void)
printf(" code: %ld words\n", (long)v4_text_here(&tx) - 16);
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
/* ---- the arithmetic it rests on ---- */
for (i = 0; i <= 31; i++)
CHECK(get("(LSHIFT)", 2, 1, (v4_cell)i) == (v4_cell)((v4_ucell)1 << i) && get("(LSHIFT)", 2, 5, (v4_cell)i) == (v4_cell)((v4_ucell)5 << i),
"(LSHIFT) by %u", i);
for (i = 0; i < 6; i++) {
CHECK(get("(LOWBIT)", 1, (v4_cell)i, 0) == (v4_cell)V4_SLOT_LOW_BIT(i), "slot %u's lowest bit is %u", i, V4_SLOT_LOW_BIT(i));
/* ---- the address masks ---- */
for (i = 0; i < 4; i++)
CHECK(get("(MASK)", 1, (v4_cell)i, 0) == (v4_cell)v4_iword_slot_mask(i), "slot %u's address mask", i);
}
/* ---- one thing at a time ---- */
nprog = 0;
v4/tests/test_host_compile.c
+29 -13
View File
@@ -270,6 +270,15 @@ int main(void)
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");
/* ---- defining words used inside other words ---- */
new_session();
CHECK(ok(": D CREATE , DOES> @ ; : DD D ; : DDD DD ;"), "a defining word, and words that call it");
CHECK(ok("7 D SEVEN 8 DD EIGHT 9 DDD NINE") && interpret("SEVEN EIGHT NINE") && !err() && pop() == 9 && pop() == 8 && pop() == 7 && clean(),
"a defining word works from the prompt, from a word, and from a word that calls that");
CHECK(ok(": MKV VARIABLE ; : MKC CONSTANT ; MKV VV 5 MKC CC 3 VV !") && interpret("VV @ CC") && !err() && pop() == 5 && pop() == 3 && clean(),
"VARIABLE and CONSTANT inside words");
CHECK(ok(": MK: : ; MK: PLUS3 3 + ;") && one("4 PLUS3") == 7, ": inside a word");
/* ---- numbers in other bases ---- */
new_session();
CHECK(one("2 BASE ! 101") == 5, "a number in base 2");
@@ -314,6 +323,11 @@ int main(void)
&& 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");
{
v4_cell dp = n.mem[DP];
CHECK(interpret("5 CONSTANT") && err() && n.mem[DP] == dp, "CONSTANT with no name stores nothing");
CHECK(interpret("VARIABLE") && err() && n.mem[DP] == dp, "nor does VARIABLE");
}
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");
@@ -358,22 +372,24 @@ int main(void)
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 ---- */
/* ---- how deep words may call each other from the interpreter ----
* Measured by how many marked return entries survive under INTERPRET
* while a word that calls nothing runs: each of them is a level of
* nesting some other word could have used. */
{
char line[64];
unsigned depth = 0;
unsigned r, k;
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);
CHECK(ok(": N0 1+ ;") && ok(": N1 N0 1+ ;") && ok(": N2 N1 1+ ;") && ok(": N3 N2 1+ ;") && ok(": N4 N3 1+ ;"), "five words, each calling the one before");
CHECK(one("0 N4") == 5, "five levels of calls work from the interpreter");
for (r = 0; r < V4_RET_DEPTH; r++) {
unsigned good = 1;
if (!interpret_with("0 N0", 0, r + 1u) || err()) break;
if (pop() != 1 || pop() != CANARY) break;
for (k = r + 1u; k-- > 0; ) if (v4_rstack_pop(&n.rs) != (v4_cell)(0x6B000000 + k)) good = 0;
if (!good) break;
}
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");
printf(" a word run from the interpreter has %u return entries to itself\n", r + 1u);
CHECK(r + 1u >= 6, "the interpreter leaves most of the return stack to the user");
}
/* and how much of the data stack a line may use */
{
v4/tests/test_host_input.c
+10
View File
@@ -246,6 +246,16 @@ int main(void)
CHECK(run("C@", 1, SBUF + (v4_cell)i, 0, 0) && pop() == (v4_cell)('a' + i) && clean(), "C@ [%u]", i);
}
CHECK(run("CMOVE", 3, SBUF, SBUF + 20, 8) && clean() && bytes_are(SBUF + 20, "abcdefgh", 8), "CMOVE");
/* C! writes one byte and nothing else, whatever is above the low byte of what it is given */
for (i = 0; i < 8; i++) {
v4_ucell pat = (v4_ucell)0xA5C3F00Fu, want;
unsigned sh = 8u * (i % 4u);
n.mem[SBUF_W + 8] = (v4_cell)pat; n.mem[SBUF_W + 9] = (v4_cell)pat; n.mem[SBUF_W + 10] = (v4_cell)pat; n.mem[SBUF_W + 7] = (v4_cell)pat;
want = (pat & ~((v4_ucell)0xFFu << sh)) | ((v4_ucell)0x5Eu << sh);
CHECK(run("C!", 2, (v4_cell)-162 /* ...FF5E */, (SBUF_W + 8) * 4 + (v4_cell)i, 0) && clean(), "C! of a wide value [%u]", i);
CHECK((v4_ucell)n.mem[SBUF_W + 8 + (v4_cell)(i / 4u)] == want && (v4_ucell)n.mem[SBUF_W + 9 - (v4_cell)(i / 4u)] == pat
&& (v4_ucell)n.mem[SBUF_W + 7] == pat && (v4_ucell)n.mem[SBUF_W + 10] == pat, "C! changes that byte only [%u]", i);
}
for (i = 0; i < 6; i++) {
static const v4_cell b[] = { 10, 16, 2, 36, 1, 37 };
n.mem[BASE] = b[i];