rajamesandClaude Opus 5.5
8df6c16766
ENGINE.md step 2, the carrier. Ruled 2026-10-05 (V3-PARITY.md 1i), on DECOMPOSITION.md section 6: a write to a port blocks until the neighbour reads. - node: v4_node_port_attach, v4_node_port_served; a store to the port keeps the value as the request and blocks the node - exec: a blocked node executes nothing; served, it goes on from the opcode after the store, in the same instruction word; a fault meanwhile abandons the rest of the word - compile.v4: n KERNEL-WORD name makes a word whose body writes n to the port; its arguments and results are on the data stack - boot: the kernel's words are made by handing the node text, and requests are served between the node's opcodes; one no one serves is error 12 - BYE, the first kernel word: hosted it leaves the program, as hosted v3; on the lone node it is v3's cold restart - ENGINE.md 3a: multiuser, multitasking, preemptive and cooperative, and what that asks of the engine Verified: make -C v4 test passes at both widths, with tests/test_port.c; hosted-check passes on three ISAs; clean qemu with STARFORTH_V4=1 on amd64, aarch64 and riscv64 passes POST with the same hashes as hosted, and a kernel word no one serves and BYE typed at each prompt are answered (logs/20261005-185506, -185734, -190101; -185234 is an amd64 run in which those two lines were not typed). Not done: v3's own C functions serving a node. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
467 lines
19 KiB
Plaintext
467 lines
19 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
|
|
|
|
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:
|
|
\ <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)
|