admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0da7e32a0bafe8d4246a0406a373a4865cb14d35
LithosAnanake/v4/capsule/compile.v4
T
rajamesandClaude Opus 5.5 0da7e32a0b feat(v4.0.0): the stacks are guarded (D-16); DEPTH, PICK and ROLL 
Ruled 2026-10-04, revising D-2: stack overflow and underflow are errors
that are shown and return to the prompt, not silent wrap-around.

- Each stack counts what it holds.  Before every opcode the executor
  checks that the stacks hold what it takes and have room for what it
  leaves; otherwise the opcode does nothing and the node faults, as for a
  bad address, to that kind's handler.  Every fault empties both stacks.
- The fault handler is now a table of five jumps: address, data overflow,
  data underflow, return overflow, return underflow.  The host node says
  "Stack overflow", "Stack underflow", "Return stack overflow",
  "Return stack underflow", then ERROR and the prompt.
- Two registers, DSTACK-DEPTH and RSTACK-DEPTH: a fetch reads the depth,
  a store empties the stack.  QUIT, ABORT and the error exits empty the
  return stack before they call anything; ABORT empties the data stack.
- capsule/forth.v4: DEPTH, PICK and ROLL, to FORTH-79 (counting from
  one).  PICK and ROLL set the values above the one wanted aside in
  memory, and work with the stack full.
- Division by zero now takes its operands off the stack, as v3 does.
- A colon with no room for its entry abandons the line.
- tests: every opcode at every depth of both stacks; the faults, the
  registers and the three words from the prompt.

The sizes are unchanged: ten values, nine return entries.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-04 17:31:18 -04:00

367 lines
15 KiB
Plaintext
Raw Blame History

\ 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 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
\ (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)
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 ------------------------------------------------------
\ ( 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,)
\ ( -- ) 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 EXECUTE jump L
COMP: drop (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 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 WORD: '"
$4E4B4E55 (EMIT4) $204E574F (EMIT4) $44524F57 (EMIT4) $27203A (EMIT4)
(.WORD) 39 EMIT CR
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 -----------------------------------------------------------
\ 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
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
\ 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
\ ( -- ) 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. 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!) (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,)
\ 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:
\ <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! @ (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)
Reference in New Issue View Git Blame Copy Permalink