rajamesandClaude Opus 5.5
1bf19d6224
capsules/v4/sys: the nucleus's fourteen sources as .f18 blobs (made once by v4/tools/v4tof18.py: header becomes the ROM's directives, every other token and line kept), the memory map as map-<width>.f18 (mkmap sys, from one table in host_map.h that host_load reads too), and end.f18, the switch-on state mkimage.c set in C, the image record, and start (IDLE). test_host_rom_nucleus.c: the ROM, fed those blobs through the console, builds RAM identical word for word to mkimage.c's, outside its own state and the image record, and starts at (IDLE), at both widths. The cost: 60.7 million instructions, 1.5 s on the C model. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
467 lines
21 KiB
Plaintext
467 lines
21 KiB
Plaintext
\ 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
|
|
|
|
set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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 ---------------------------------------------------------------------
|
|
|
|
set HDR-NFA here ", [ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: LEFT-BRACKET 0 STATE a! ! ;
|
|
set HDR-NFA here ", ] #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: RIGHT-BRACKET -1 STATE a! ! ;
|
|
|
|
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
|
|
set HDR-NFA here ", LITERAL #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", ' #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: TICK (') jump LITERAL
|
|
|
|
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
|
|
\ which v3 has as another name for LITERAL.
|
|
set HDR-NFA here ", ['] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: BRACKET-TICK (') jump (LIT,)
|
|
set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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.
|
|
set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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.
|
|
set HDR-NFA here ", KERNEL-WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", EXIT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: EXIT 0 jump (OP,)
|
|
|
|
set HDR-NFA here ", IMMEDIATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
|
|
|
|
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
|
|
set HDR-NFA here ", COMPILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", CREATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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.
|
|
set HDR-NFA here ", VARIABLE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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:
|
|
set HDR-NFA here ", IF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF
|
|
set HDR-NFA here ", ELSE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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.
|
|
set HDR-NFA here ", BEGIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: BEGIN
|
|
2 (BRANCH>) (C)+6 a! !
|
|
(LABEL) >CF 23 (OP,)
|
|
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
|
|
3 jump >CF
|
|
set HDR-NFA here ", UNTIL #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,)
|
|
set HDR-NFA here ", AGAIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ;
|
|
set HDR-NFA here ", WHILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF
|
|
set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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 ;
|
|
set HDR-NFA here ", CASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: CASE 0 >CF 7 jump >CF
|
|
set HDR-NFA here ", OF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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:
|
|
\ <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 ;
|
|
|
|
set HDR-NFA here ", DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF
|
|
set HDR-NFA here ", ?DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
|
|
set HDR-NFA here ", LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
|
|
set HDR-NFA here ", +LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
|