\ compile.v4 -- the interpreter's inner loop, and the defining and compiling \ words. \ \ DECOMPOSITION.md 5.17 and 5.18: STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE \ [COMPILE] ' EXECUTE CREATE VARIABLE CONSTANT DOES>, the control structures \ IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP, and INTERPRET, \ which they cannot be run without. Part of the compiler capsule. Rests on \ core.v4, input.v4, dict.v4 and codegen.v4. \ \ HOW A WORD IS COMPILED. v4 code is native: a colon definition is \ instruction words, and compiling a word into one lays down a call to it. \ Two flags on an entry (dict.v4) change that: \ inline its code is a straight run of opcodes and literals ending \ in ; -- that run is copied in place of a call. Everything \ that touches the return stack must be, since a call would \ bury what it works on (DECOMPOSITION.md 0, fate IN). \ compile-only it may not be executed by the interpreter. \ An immediate word is executed even when compiling. \ \ THE STACKS ARE SHORT (D-2): ten cells of data, nine return entries, and no \ way to see how full they are. The interpreter and compiler run on the same \ stacks as the user's words, with the user's values beneath them, so: \ - every word here keeps what it works on in (C), and has at most three \ cells of its own on the data stack at any moment; \ - what an IF or a DO leaves for its THEN or LOOP goes on a control-flow \ stack in memory, not on the data stack, so structures may nest as \ deep as that stack (32 cells) allows whatever the user has stacked. \ \ Constants the loader supplies: \ STATE word address of the variable: non-zero while compiling \ (C) word address of eight cells of scratch for this file: \ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot \ (C)+2 LATEST before a header is made (C)+3 a data word's routine \ (C)+6 (C)+7 a branch and a tag a control word is holding \ (CFP) word address of the control-flow stack's pointer \ CFBASE CFEND word addresses of its first cell and of the cell past its last macro ROT push SWAP pop SWAP endmacro \ ---- errors ------------------------------------------------------------------ \ ( -- ) give up the line: stop compiling, forget the word being built and \ whatever control structures were open, skip the rest of the input, and set \ NODE-ERROR. A definition that was under way stays hidden. (QUIT will add \ the message and the stack reset.) : (ABANDON) 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! SPAN a! @ >IN a! ! NODE-ERROR b! -1 !b ; \ ---- the control-flow stack ---------------------------------------------------- \ ( x -- ) push; a full stack abandons the line : >CF (CFP) a! @ CFEND xor if FULL drop (CFP) a! @ dup 1 + ! a! ! ; FULL: drop drop jump (ABANDON) \ ( -- x ) pop; 0 from an empty stack, which no opening word leaves : CF> (CFP) a! @ CFBASE xor if EMPTY drop (CFP) a! @ -1 + dup ! a! @ ; EMPTY: ; \ ---- compiling one word ------------------------------------------------------ \ ( x n -- x' ) x shifted right n places; the bits that come in at the top \ are masked off by the caller : (RSHIFT) if Z -1 + push L: 2/ next L ; Z: drop ; \ ( xt -- ) copy the in-line word at xt into the definition being built : (INLINE,) W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it 0 (C)+4 a! ! \ slot S: (C)+4 a! @ (LOWBIT) (C) a! @ SWAP (RSHIFT) 31 and \ op if END \ ; ends the copy dup -8 + if LIT drop dup -28 + if NOP \ nop is padding drop (OP,) NXT: (C)+4 a! @ 1 + dup ! -6 + if NEXTW drop jump S NEXTW: drop (C)+1 a! @ jump W \ the next instruction word follows the literals LIT: drop drop (C)+1 a! @ dup 1 + ! a! @ (LIT,) jump NXT NOP: drop drop jump NXT END: drop ; \ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call : (COMPILE,) dup (FLAGS) a! @ 8 and if CALL drop jump (INLINE,) CALL: drop jump (CALL,) header EXECUTE : EXECUTE ( xt -- ) push ; \ ---- the interpreter's inner loop --------------------------------------------- \ ( -- n flag ) the word WORD has just left, as a single-cell number in the \ current BASE, and -1; or 0 0 if it is not one. A leading minus sign is \ allowed. This is what the interpreter uses: NUMBER (input.v4) makes a \ double and needs more of the stack than can be spared here. \ (P)+2 the number so far, (P)+3 where it is in the word, (P)+4 the word's \ length, (P)+5 the sign, (P)+6 the base. : (NUM?) WBUF C@ if EMPTY (P)+4 a! ! 0 (P)+2 a! ! 1 (P)+3 a! ! 0 (P)+5 a! ! (BASE) (P)+6 a! ! WBUF+1 C@ -45 + if NEG drop jump DIGITS NEG: drop -1 (P)+5 a! ! 2 (P)+3 a! ! (P)+4 a! @ -1 + if EMPTY drop \ a sign alone DIGITS: L: (P)+4 a! @ (P)+3 a! @ - -if MORE drop (P)+2 a! @ (P)+5 a! @ if POS drop NEGATE -1 ; POS: drop -1 ; MORE: drop (P)+3 a! @ dup 1 + ! WBUF + C@ (DIGIT) \ d -if DIGIT jump BAD1 DIGIT: dup (P)+6 a! @ - -if BAD2 drop (P)+2 a! @ (P)+6 a! @ STAR + (P)+2 a! ! jump L BAD2: drop BAD1: drop 0 0 ; EMPTY: drop 0 0 ; \ ( -- ) FORTH-79: take words from the input stream until it is exhausted. \ A word in the dictionary is executed, or, when compiling and not immediate, \ compiled. Anything else must be a number in the current BASE: it is left \ on the stack, or compiled as a literal. What is neither, or a compile-only \ word met while interpreting, abandons the line. header INTERPRET : INTERPRET L: 32 WORD dup C@ if EOL drop (LOOKUP) if NUM dup (FLAGS) a! @ \ xt flags STATE a! @ if INTERP drop 1 and if COMP \ compiling: immediate words still run drop EXECUTE jump L COMP: drop (COMPILE,) jump L INTERP: drop 16 and if RUN drop drop jump (ABANDON) RUN: drop EXECUTE jump L NUM: drop (NUM?) if BAD drop STATE a! @ if KEEP drop (LIT,) jump L KEEP: drop jump L BAD: drop drop jump (ABANDON) EOL: drop drop ; \ ---- state --------------------------------------------------------------------- header [ immediate : LEFT-BRACKET 0 STATE a! ! ; header ] : RIGHT-BRACKET -1 STATE a! ! ; \ ( x -- ) FORTH-79: if compiling, compile x as a literal header LITERAL immediate : LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ; \ ( -- addr ) FORTH-79: the next word's parameter field address; if \ compiling, compiled as a literal header ' immediate : TICK (') jump LITERAL \ ---- colon definitions ----------------------------------------------------------- \ ( -- flag ) an entry for the next word in the input stream; -1 if one was \ made. (C)+2 holds LATEST meanwhile, to tell. : (NAMED) LATEST (C)+2 a! ! 32 WORD (HEADER) LATEST (C)+2 a! @ xor if NONE drop -1 ; NONE: ; \ FORTH-79: start a definition; it cannot be found until ; ends it header : : COLON (NAMED) if NONE drop HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET NONE: drop ; \ FORTH-79: compile the return, let the word be found, stop compiling header ; immediate compile-only : SEMICOLON 0 (OP,) LATEST (FLAGS) a! @ -3 and ! jump LEFT-BRACKET \ FORTH-79: return from the definition at this point header EXIT immediate compile-only : EXIT 0 jump (OP,) header IMMEDIATE : IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ; \ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled header COMPILE immediate compile-only : COMPILE 32 WORD (LOOKUP) if MISSING (LIT,) &(COMPILE,) jump (CALL,) MISSING: drop jump (ABANDON) \ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate header [COMPILE] immediate compile-only : BRACKET-COMPILE 32 WORD (LOOKUP) if MISSING jump (COMPILE,) MISSING: drop jump (ABANDON) \ ---- data words --------------------------------------------------------------------- \ A data word's code is one call to its run-time routine; the call leaves the \ address of the cell after it -- the parameter field -- on the return stack. : (DOVAR) pop ; \ leave the parameter field address : (DOCON) pop a! @ ; \ leave what it holds \ ( -- flag ) an entry for the next word, flagged data, its code a call to \ the routine whose address is in (C)+3; -1 if one was made : (DATA) LATEST (C)+2 a! ! \ (NAMED), in line: the calls 32 WORD (HEADER) \ below this are deep enough LATEST (C)+2 a! @ xor if NONE drop (CG-RESET) LATEST (FLAGS) a! @ 4 OR ! (C)+3 a! @ (CALL,) -1 ; NONE: ; \ FORTH-79: an entry whose word leaves the address of its parameter field header CREATE : CREATE &(DOVAR) (C)+3 a! ! (DATA) drop ; \ FORTH-79: CREATE and one cell. The standard leaves its first value to the \ programme; here it is 0. header VARIABLE : VARIABLE &(DOVAR) (C)+3 a! ! (DATA) if NONE drop 0 jump , NONE: drop ; \ ( n -- ) FORTH-79: an entry whose word leaves n header CONSTANT : CONSTANT &(DOCON) (C)+3 a! ! (DATA) if NONE drop jump , NONE: drop drop ; \ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become \ what each word DEFINER makes does, starting with its parameter field address \ on the stack. (DOES), run by DEFINER, turns the newest entry's code into a \ call to the code after it and leaves DEFINER; that code starts with pop, \ which fetches the parameter field address the call left. : (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0 header DOES> immediate compile-only : DOES> &(DOES) (CALL,) 25 jump (OP,) \ ---- control structures (5.18, section 2) --------------------------------------------- \ All immediate and compile-only. Each puts what the word that closes it \ needs on the control-flow stack, with a number on top saying which word put \ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO. A closing word that \ finds the wrong number abandons the line. \ ( tag wanted -- ) if they differ, abandon the line and leave the control \ word that called this as well: its return address is dropped, so the \ abandoning returns to the interpreter and nothing more is laid down. : (PAIR) xor if OK drop pop drop jump (ABANDON) OK: drop ; \ ( ref -- ) the branch at ref lands here : (HERE!) (LABEL) SWAP jump (RESOLVE) \ Native if leaves the flag, so both ways out of it drop it (section 2): \ IF a THEN if L1 drop a jump L2 L1: drop L2: \ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2: header IF immediate compile-only : IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF header ELSE immediate compile-only : ELSE CF> 1 (PAIR) CF> (C)+6 a! ! \ the if 2 (BRANCH>) >CF \ the jump over the else part (C)+6 a! @ (HERE!) 23 (OP,) 2 jump >CF header THEN immediate compile-only : THEN CF> dup -1 + if PLAIN drop 2 (PAIR) CF> jump (HERE!) PLAIN: drop drop CF> (C)+6 a! ! \ the if 2 (BRANCH>) >CF (C)+6 a! @ (HERE!) 23 (OP,) CF> jump (HERE!) \ A loop that tests at its end jumps back with the flag still there, so it \ jumps back to a drop laid just ahead of the body: \ BEGIN a UNTIL jump L0 Ld: drop L0: a if Ld drop \ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop \ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0 \ The control-flow stack holds Ld, L0 and 3. header BEGIN immediate compile-only : BEGIN 2 (BRANCH>) (C)+6 a! ! (LABEL) >CF 23 (OP,) (LABEL) dup >CF (C)+6 a! @ (RESOLVE) 3 jump >CF header UNTIL immediate compile-only : UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,) header AGAIN immediate compile-only : AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ; header WHILE immediate compile-only : WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF header REPEAT immediate compile-only : REPEAT CF> 4 (PAIR) CF> (C)+6 a! ! \ the while CF> 3 (PAIR) CF> (JUMP,) CF> drop (C)+6 a! @ (HERE!) 23 jump (OP,) \ DO loops: the limit and index are on the return stack, limit below (5.18). : (do) over push push drop ; : (?do) over over xor ; : (inc) pop 1 + pop ; \ index' limit : (+inc) dup a! pop + pop ; \ index' limit A: the step : (differ) drop over ; : (same) drop over over - ; : (a-xor) a xor ; : (again) drop push push ; : (3drop) drop drop drop ; \ lay : ( i' lim -- i' lim s ), the top bit of s set when i' < lim : (LESS,) &(?do) (INLINE,) 7 (BRANCH>) >CF &(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! ! CF> (HERE!) &(same) (INLINE,) (C)+6 a! @ jump (HERE!) \ The end of a loop, after its increment and test. The control-flow stack \ holds the body's address and 5, or for ?DO its skip, the body and 6. \ -if EXIT drop push push jump BODY EXIT: drop drop drop \ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST: : (LOOP-END) CF> (C)+7 a! ! \ the tag 7 (BRANCH>) (C)+6 a! ! &(again) (INLINE,) CF> (JUMP,) (C)+6 a! @ (HERE!) &(3drop) (INLINE,) (C)+7 a! @ -5 + if PLAIN drop (C)+7 a! @ 6 (PAIR) 2 (BRANCH>) (C)+6 a! ! CF> (HERE!) &(3drop) (INLINE,) (C)+6 a! @ jump (HERE!) PLAIN: drop ; header DO immediate compile-only : DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF header ?DO immediate compile-only : ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF header LOOP immediate compile-only : LOOP &(inc) (INLINE,) (LESS,) jump (LOOP-END) header +LOOP immediate compile-only : +LOOP &(+inc) (INLINE,) (LESS,) &(a-xor) (INLINE,) jump (LOOP-END)