diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index e9cc9935..348841fd 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -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). diff --git a/v4/capsule/codegen.v4 b/v4/capsule/codegen.v4 index 6bff312c..de601a0c 100644 --- a/v4/capsule/codegen.v4 +++ b/v4/capsule/codegen.v4 @@ -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) diff --git a/v4/capsule/compile.v4 b/v4/capsule/compile.v4 index 8434c87d..dd058922 100644 --- a/v4/capsule/compile.v4 +++ b/v4/capsule/compile.v4 @@ -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 : ( 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: +\ ( 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) diff --git a/v4/capsule/core.v4 b/v4/capsule/core.v4 index e0e87ac1..fce7452f 100644 --- a/v4/capsule/core.v4 +++ b/v4/capsule/core.v4 @@ -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 diff --git a/v4/capsule/dict.v4 b/v4/capsule/dict.v4 index 134eaf0b..f0f17cab 100644 --- a/v4/capsule/dict.v4 +++ b/v4/capsule/dict.v4 @@ -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 diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index 9da92798..c0353b7e 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -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 */ diff --git a/v4/tests/test_host_codegen.c b/v4/tests/test_host_codegen.c index 1af129cb..17ce4315 100644 --- a/v4/tests/test_host_codegen.c +++ b/v4/tests/test_host_codegen.c @@ -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; diff --git a/v4/tests/test_host_compile.c b/v4/tests/test_host_compile.c index f8a3fb47..93bd6650 100644 --- a/v4/tests/test_host_compile.c +++ b/v4/tests/test_host_compile.c @@ -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 */ { diff --git a/v4/tests/test_host_input.c b/v4/tests/test_host_input.c index 85769f0a..f2ac3b4e 100644 --- a/v4/tests/test_host_input.c +++ b/v4/tests/test_host_input.c @@ -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];