\ 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: written for ten cells of data and nine return entries \ (D-2; the host node now has 32 of each, D-17), and one more of either is a \ fault (D-16). 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 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 \ (C)+9 the error code a line is being abandoned with \ (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. It returns to \ whatever called INTERPRET, which is QUIT (quit.v4): QUIT sees NODE-ERROR \ and prints ERROR. \ (ABANDON-AS) is the same with an error code (core.v4) for the prompt to \ print the message of. : (ABANDON-AS) ( code -- ) (C)+9 a! ! 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! SPAN a! @ >IN a! ! (C)+9 a! @ NODE-ERROR b! !b ; : (ABANDON) -1 jump (ABANDON-AS) \ ---- 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 8 jump (ABANDON-AS) \ control structures too deep \ ( -- 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 ------------------------------------------------------ \ ( 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. \ 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) 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 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 -3 + a! @ 8 and if CALL drop jump (INLINE,) CALL: drop jump (CALL,) \ ---- access control (5.20) ------------------------------------------------------- \ Each entry's flags cell also holds its access control fields: \ bit 5 (32) denied: the word may not be used \ bit 6 (64) pinned: the fields cannot be changed \ bits 8 .. 15 the mode: 0 TTL, 1 STRICT \ bits 16 .. 31 the TTL, a count of uses left before the next recheck \ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0. \ \ (ACL?) is run by INTERPRET for every word it is about to execute or \ compile. As v3: if the TTL is 0 the word is rechecked, otherwise the TTL \ is counted down; then a denied word is refused. The recheck is the word \ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded -- \ and with none there the word is allowed and given the longest TTL. \ \ v3 checks every execution, inside definitions too. v4 code is native: a \ compiled call goes straight to its word. So v4 checks a word when it is \ compiled as well as when it is interpreted -- a denied word cannot be \ built into anything new -- but a call compiled while the word was allowed \ is not checked again. \ ( xt -- ) recheck : (ACL-RECHECK) (ACL-HOOK) a! @ if NONE push ex \ call it with the xt ; NONE: drop -3 + a! @ 65535 and -33 and $FFFF0000 + ! ; \ ( xt -- xt ) as above; a denied word ends the line : (ACL?) dup -3 + a! @ \ xt flags dup $FFFF0000 and if ZERO drop -65536 + ! jump TEST \ one use fewer ZERO: drop drop dup (ACL-RECHECK) TEST: dup -3 + a! @ 32 and if OK drop drop $33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) \ v3's line: WARN: in yellow $3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4) (.WORD) 39 EMIT CR DSTACK-DEPTH b! a !b \ as v3, the stack is emptied pop drop jump (ABANDON) OK: drop ; \ ( -- ) print the word WORD has just left : (.WORD) WBUF COUNT jump TYPE 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, with v3's message: \ UNKNOWN WORD: 'xxx' xxx: compile-only header INTERPRET : INTERPRET L: 32 WORD dup C@ if EOL drop (LOOKUP) if NUM dup -3 + a! @ \ xt flags STATE a! @ if INTERP drop 1 and if COMP \ compiling: immediate words still run drop (ACL?) EXECUTE jump L COMP: drop (ACL?) (COMPILE,) jump L INTERP: drop 16 and if RUN drop drop (.WORD) \ ": compile-only" $6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR jump (ABANDON) RUN: drop (ACL?) EXECUTE jump L NUM: drop (NUM?) if BAD drop STATE a! @ if KEEP drop (LIT,) jump L KEEP: drop jump L BAD: drop drop (UNKNOWN) 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 \ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL], \ which v3 has as another name for LITERAL. header ['] immediate compile-only : BRACKET-TICK (') jump (LIT,) header [LITERAL] immediate : BRACKET-LITERAL jump LITERAL \ ---- colon definitions ----------------------------------------------------------- \ FORTH-79: start a definition; it cannot be found until ; ends it. The \ CONTEXT vocabulary is set to the CURRENT one. \ (C)+2 holds LATEST while the entry is made, to tell whether one was. header : : COLON CURRENT a! @ CONTEXT a! ! 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 jump (ABANDON) \ no entry: the rest of the line is not a definition \ 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 \ ( n -- ) KERNEL-WORD xxx A WORD THAT ASKS THE KERNEL (docs/v4.0.0/ \ ENGINE.md 3.3). xxx is made a word whose whole body is "write n to the \ port": n is the number of a request, the port is the node's way to its \ kernel, and the write blocks the node until the kernel has served it \ (DECOMPOSITION.md section 6). xxx's arguments are whatever it finds on \ the data stack and its results are what the kernel leaves there. This is \ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a \ node. Not FORTH-79 and not in v3, where such a word is registered from C. \ The constant (PORT) is the port's word address. header KERNEL-WORD : KERNEL-WORD COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b jump SEMICOLON \ 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 (UNKNOWN) 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 (UNKNOWN) 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 \ ( -- ) 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) 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 ! -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! ! 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) (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) (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 \ 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, 7 CASE, 8 OF. A closing word that \ finds the wrong number abandons the line. \ ( tag wanted -- ) if they differ, abandon the line and leave the control \ 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 7 jump (ABANDON-AS) OK: drop ; \ ( ref -- ) the branch at ref lands here : (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: \ 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,) \ CASE: the value being chosen on stays on the stack through the clauses. \ CASE x1 OF a ENDOF x2 OF b ENDOF c ENDCASE \ lays, for each clause, \ over xor if M drop jump N M: drop drop a jump END N: \ and ENDCASE lays the drop that the part after the last ENDOF leaves the \ value for, with END after it. The control-flow stack holds the jumps to \ END, how many there are, and 7; inside a clause, the jump to N and 8. : (of) over xor ; header CASE immediate compile-only : CASE 0 >CF 7 jump >CF header OF immediate compile-only : OF CF> 7 (PAIR) &(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M 23 (OP,) 2 (BRANCH>) >CF \ drop, jump N (C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop 8 jump >CF header ENDOF immediate compile-only : ENDOF CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N CF> (C)+7 a! ! \ how many jumps to END so far 2 (BRANCH>) >CF \ one more (C)+7 a! @ 1 + >CF (C)+6 a! @ (HERE!) \ N: 7 jump >CF header ENDCASE immediate compile-only : ENDCASE CF> 7 (PAIR) CF> (C)+7 a! ! 23 (OP,) L: (C)+7 a! @ if DONE -1 + ! CF> (HERE!) jump L DONE: drop ; \ DO loops: the limit and index are on the return stack, limit below (5.18). : (do) over push push drop ; : (?do) over over xor ; : (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 ; \ 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! @ (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,) (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,) 0 (C)+5 a! ! jump (LOOPS) header +LOOP immediate compile-only : +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)