admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(v4): the machine boots from its ROM; the prebuilt nucleus is gone

Browse Source 
The host node starts in its ROM (entry 12), and the boot feeds it the
system's source through the console: capsules/v4/sys/map-64.f18, the
fourteen .f18 blobs and end.f18, each found, hash-checked and
signature-checked as any capsule, then EOT.  The ROM assembles the system
and starts it at (IDLE); the host reads the image record
(v4_image_from_node) for what only the assembled system knows.  A ROM
error is reported with its blob, line and meaning, then PARITY:FAIL.

Deleted: v4/tools/mkimage.c, capsules/v4/nucleus-64.f18, v4/capsule/*.v4,
v4/tools/v4tof18.py.  The .f18 files are the source now.

- text.c speaks the rest of the ROM's language (set, here, store, start;
  v4_text_value, v4_text_start), so the oracle reads the same source:
  test_host_rom_nucleus compares the ROM against text.c on the .f18 files,
  word for word, image record included.  Host tests load the .f18 files.
- mkmap image writes v4_map_image (the map's description of the system);
  hosted and the kernel link the ROM and the map instead of v4_image_64.c.
- Hera (Captain Bob's ruling, option 1): births stream the system the ROM
  assembled, as assembled code; hera.4th is unchanged.
  test_host_unit's host builds the system with the ROM.
- New parity lines: PARITY:V4_F18 per blob, PARITY:V4_ROM words=2049
  rom_hash=0xa6c792b5821010b7 instructions=60725216.

Acceptance: amd64, aarch64, riscv64 boot to ok> with PARITY:V4_POST
tests=538 pass=538 fail=0, POST: PASSED, and PARITY:V4_SYSTEM
word_count=317 dict_hash=0xe5a57f3eb72ff94a on all three -- the same hash
as the prebuilt nucleus gave.  make -C v4 test test-32 hosted-check: all
pass.  Logs: logs/20261015-141648, -141938, -142350.

Startup cost under QEMU TCG, the ROM's assembly (last V4_F18 line to
V4_ROM): amd64 26.7 s of 132 s to ok>; aarch64 41.0 s of 195 s; riscv64
20.5 s of 101 s.  Hosted native: +0.85 s.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-15 14:26:02 -04:00
co-authored by Claude Opus 5.5
parent 1bf19d6224
commit a73580e949
69 changed files with 1164 additions and 4025 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/acl.v4
-83
View File
@@ -1,83 +0,0 @@
\ acl.v4 -- word-level access control: the fields of an entry.
\
\ DECOMPOSITION.md 5.20, as v3: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
\ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
\ ACL-WORD-ID. These are all the capsule does itself; the policy -- what is
\ strict, how long a TTL is, what is pinned -- is FORTH source, ACL.fth, as
\ it is ACL.4th in v3. The fields and the check are described in
\ compile.v4. Rests on compile.v4, quit.v4 and system.v4.
\
\ An xt of 0 is an error (code 16, "Not a word"). A pinned word's fields are
\ not changed by the ! words: they do nothing, as in v3.
\
\ Constants the loader supplies:
\ (ACL-HOOK) word address of the variable: the xt of the recheck word, or 0
\ ( xt -- xt ) refuse 0
: (ACL-XT) if NULL ; NULL: drop NODE-ERROR b! 16 !b 0 ;
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
: (PINNED) -3 + a! @ 64 and ;
header ACL-HOOK inline : ACL-HOOK' (ACL-HOOK) ;
header ACL-MODE@
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
header ACL-TTL@
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
header ACL-ALLOW@
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
header ACL-PINNED?
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
header ACL-PIN
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
header ACL-MODE!
: ACL-MODE! ( mode xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop 255 and 8* @ -65281 and + ! ;
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
header ACL-TTL!
: ACL-TTL! ( n xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop
-if POS drop 0 jump SET
POS: dup -65536 and if SMALL drop drop 65535 jump SET
SMALL: drop
SET: 8* 8* @ 65535 and + ! ;
header ACL-ALLOW!
: ACL-ALLOW! ( flag xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop if DENY drop @ -33 and ! ;
DENY: drop @ 32 OR ! ;
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
\ is 0 and it is allowed. This is the one word that unpins.
header ACL-INHERIT
: ACL-INHERIT
(ACL-XT) SWAP (ACL-XT) \ dst src
-3 + a! @ $FF00 and \ dst mode
SWAP -3 + a! @ 255 and -97 and + ! ; \ the five flags, nothing else
\ ( xt -- ) every entry from xt back that is not pinned: TTL mode, TTL 0,
\ allowed
: (ACL-INIT)
L: if DONE
dup (PINNED) if FREE drop jump NXT
FREE: drop @ 31 and !
NXT: -1 + a! @ jump L
DONE: drop ;
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
header ACL-INIT-PRIMITIVES
: ACL-INIT-PRIMITIVES
(LATEST) a! @ (ACL-INIT)
VOC-LINK a! @
V: if DONE dup a! @ (ACL-INIT) 1 + a! @ jump V
DONE: drop ;
\ ( xt -- heat ) how often the word has been used. The node's heat
\ counters are not readable from a programme yet (D-6): 0.
header ACL-HEAT@
: ACL-HEAT@ (ACL-XT) drop 0 ;
\ ( xt -- n ) a number for the word that never changes: its address
header ACL-WORD-ID
: ACL-WORD-ID (ACL-XT) ;
v4/capsule/blocks.v4
-127
View File
@@ -1,127 +0,0 @@
\ blocks.v4 -- mass storage: blocks of 1024 characters, and text loaded from them.
\
\ DECOMPOSITION.md 5.11, FORTH-79: BLOCK BUFFER UPDATE SAVE-BUFFERS
\ EMPTY-BUFFERS LIST LOAD SCR BLK, and v3's FLUSH THRU and --> . Part of the
\ compiler capsule; rests on everything before it.
\
\ STORAGE IS THE KERNEL'S (docs/v4.0.0/MESH.md section 8, ENGINE.md 3.3), as
\ it is for a v3 VM. A node only ever asks for a block by number, and it
\ asks its kernel: it writes a request to port 0, where its kernel is, and
\ when the write has been served the answer is on the data stack. The
\ node has a window in its memory, four slots of 256 cells; the kernel
\ keeps the record of which block is in which slot, does the copying, and
\ decides when a block is written. The requests (v4/include/v4/blocks.h):
\ BLOCK# ( n -- waddr status ) the slot holding block n
\ BUFFER# ( n -- waddr status ) a slot for block n, not read
\ UPDATE# ( -- status ) the block last asked for is changed
\ SAVE-BUFFERS# ( -- status ) every changed block is written
\ EMPTY-BUFFERS# ( -- ) every slot is let go
\ The status is 0, or 2 storage refused (error 17), or 3 there is no such
\ block (error 13). BLOCK and BUFFER give a byte address, as PAD and TIB
\ are: what C@ CMOVE and TYPE take.
\
\ Constants the loader supplies:
\ BLOCK# BUFFER# UPDATE# SAVE-BUFFERS# EMPTY-BUFFERS# the requests' numbers
\ SCR word address of the variable: the block LIST showed last
\ BLK (SRC) (SRC-HOOK) see input.v4
header SCR inline : SCR' SCR ;
header BLK inline : BLK' BLK ;
\ ( status -- ) a request that did not work is an error
: (B-ERR)
if FINE -2 + if E17 drop NODE-ERROR b! 13 !b ;
E17: drop NODE-ERROR b! 17 !b ;
FINE: drop ;
\ ( waddr status -- baddr ) the slot's byte address, or the error
: (B-GOT)
if OK SWAP drop jump (B-ERR)
OK: drop 2* 2* ;
\ ( n -- baddr ) FORTH-79: the address of a buffer assigned to block n.
\ What the buffer holds is not read from storage.
header BUFFER
: BUFFER BUFFER# (PORT) b! !b jump (B-GOT)
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
\ read from storage if it is not already in one.
header BLOCK
: BLOCK BLOCK# (PORT) b! !b jump (B-GOT)
\ FORTH-79: mark the block most recently asked for as changed, so that it is
\ written before its buffer is used for another.
header UPDATE
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
\ FORTH-79: write every block that has been UPDATEd.
header SAVE-BUFFERS
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
\ As v3: the same.
header FLUSH
: FLUSH jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
header EMPTY-BUFFERS
: EMPTY-BUFFERS EMPTY-BUFFERS# (PORT) b! !b ;
\ ---- LIST ----------------------------------------------------------------------
\ ( n -- ) as v3: a new line, "Block n", then sixteen lines of 64
\ characters, each after its number, and an empty line. SCR is left holding n. A character
\ that is not printable is shown as a blank. (Q)+0 is the line, (Q)+1 the
\ column, (Q)+2 the block's number.
header LIST
: LIST
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
(Q)+2 a! @ dup SCR a! !
CR $636F6C42 (EMIT4) $206B (EMIT4) 0 DOT-R CR \ "Block "
0 (Q) a! !
LN: (Q) a! @ 0 <# # # #> TYPE 58 EMIT SPACE
0 (Q)+1 a! !
CH: SCR a! @ BLOCK (Q) a! @ 2* 2* 2* 2* 2* 2* + (Q)+1 a! @ + C@
dup -32 + -if GE drop drop 32 jump EM
GE: drop dup -127 + -if BIG drop jump EM
BIG: drop drop 32
EM: EMIT
(Q)+1 a! @ 1 + dup ! -64 + if EOL drop jump CH
EOL: drop CR
(Q) a! @ 1 + dup ! -16 + if DONE drop jump LN
DONE: drop jump CR
\ ---- LOAD ----------------------------------------------------------------------
\ The text being interpreted is at (SRC), SPAN characters of it, >IN the
\ place in it. LOAD saves those and BLK on the return stack, points them at
\ the block, interprets it, and puts them back; so a block may LOAD another,
\ and the rest of the line LOAD was on is interpreted afterwards. (v3's
\ LOAD loses the rest of its line.)
\ ( -- ) what WORD calls before it reads: while a block is being loaded,
\ make sure it is in a buffer and (SRC) is that buffer.
: (BLK-SRC)
BLK a! @ if TERM BLOCK (SRC) a! ! ;
TERM: drop ;
\ ( n -- ) FORTH-79: interpret block n, then go on with what follows.
header LOAD
: LOAD
-if POS jump BAD
POS: if BAD
BLK a! @ push >IN a! @ push SPAN a! @ push (SRC) a! @ push
BLK a! ! 0 >IN a! ! 1024 SPAN a! !
&(BLK-SRC) (SRC-HOOK) a! !
INTERPRET
pop (SRC) a! ! pop SPAN a! ! pop >IN a! ! pop BLK a! ! ;
BAD: drop NODE-ERROR b! 13 !b ;
\ ( -- ) go on with the next block. Only in a block being loaded: at the
\ terminal it is an error (code 14).
header --> immediate
: NEXT-BLOCK
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
TERM: drop NODE-ERROR b! 14 !b ;
\ ( first last -- ) as v3: LOAD each block from first to last.
header THRU
: THRU
push
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
GO: drop dup push LOAD pop 1 + jump L
v4/capsule/codegen.v4
-119
View File
@@ -1,119 +0,0 @@
\ codegen.v4 -- the code generator: opcodes, literals and branches packed into
\ instruction words at HERE.
\
\ This is what the compiling words ( : ; IF LOOP LITERAL ... ) are built on.
\ It lays code down exactly as DECOMPOSITION.md 1.2 and 2 require and as the
\ test harness's own packers do (v4/include/v4/asm.h, text.h):
\
\ - opcodes fill slots 0 .. 5 of a word left to right; a full word is
\ appended to the dictionary and a new one started; unused slots are nop
\ - a literal is @p in a slot and its value in the cell after the word;
\ several in one word follow it in order
\ - ; and ex close the word, since nothing after them runs
\ - a branch closes the word: the bits to its right are its address
\ - a branch goes only in a slot whose address field reaches all of the
\ node's memory; otherwise the word is closed first and the branch starts
\ the next one. So no branch ever needs a reach check.
\
\ An instruction word is 32 bits at every cell width (D-9): slot k is the five
\ bits whose lowest is bit 27 - 5k, and a branch there has 27 - 5k address bits.
\
\ Rests on core.v4 and dict.v4. Constants the loader supplies:
\ (CG) word address of fourteen cells of scratch for this file
\ CG-BSLOTS how many slots, counted from slot 0, may hold a branch
\ Like WORD, these run under whatever the user has on the stacks, so what they
\ work on is in (CG), they keep at most three cells of their own on the data
\ stack, and they call each other as little as they can (D-2):
\ (CG)+0 the word being built (CG)+1 its next free slot
\ (CG)+2 how many literals it owes, and (CG)+3 .. (CG)+8 the literals
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH0) made
\ (CG)+11 the target a branch is to reach (CG)+12 which literal (FLUSH) is at
\ (CG)+13 what (FLUSH) fills unused slots with: nop, or 0 after a branch
\
\ The word being built is kept right-justified: each opcode is shifted in
\ below the ones before it, and (FLUSH) shifts in what fills the rest and the
\ two spare bits. So nothing is ever shifted by a counted loop, which would
\ want a return-stack entry for its count.
\ ( k -- mask ) the address bits of a branch in slot k: 2^(27-5k) - 1
: (MASK)
if K0 -1 + if K1 -1 + if K2
drop 4095 ;
K2: drop 131071 ;
K1: drop 4194303 ;
K0: drop 134217727 ;
\ ( -- ) forget the word being built
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! 28 (CG)+13 a! ! ;
\ ( x -- ) five bits into the next free slot, which must be free
: (PUT)
(CG) a! @ 2* 2* 2* 2* 2* + !
(CG)+1 a! @ 1 + ! ;
\ ( -- ) append the word being built, its unused slots filled, then the
\ literals it owes; nothing if no slot is in use
: (FLUSH)
(CG)+1 a! @ if EMPTY drop
P: (CG)+1 a! @ -6 + if FULL drop (CG)+13 a! @ (PUT) jump P
FULL: drop
(CG) a! @ 2* 2* , \ the two spare bits
0 (CG)+12 a! !
L: (CG)+12 a! @ (CG)+2 a! @ xor if DONE
drop (CG)+12 a! @ dup 1 + ! (CG)+3 + a! @ ,
jump L
DONE: drop
jump (CG-RESET)
EMPTY: drop ;
\ ( op -- ) any opcode that is neither a branch nor @p
: (OP,)
dup (CG)+9 a! ! (PUT)
(CG)+9 a! @ if ENDS -1 + if ENDS \ ; and ex end the word
drop (CG)+1 a! @ -6 + if ENDS drop ; \ and so does its last slot
ENDS: drop jump (FLUSH)
\ ( x -- ) @p and its value
: (LIT,)
(CG)+2 a! @ dup 1 + ! \ x n
(CG)+3 + a! !
8 (PUT)
(CG)+1 a! @ -6 + if FULL drop ;
FULL: drop jump (FLUSH)
\ ( -- addr ) where the next word will go: a branch target
: (LABEL) (FLUSH) HERE ;
\ ( op -- ) a branch (jump 2, call 3, next 5, if 6, -if 7) whose address is
\ not filled in yet. Its ref -- the branch's word address times 8, plus its
\ slot -- is left in (CG)+10. The rest of its word is filled with 0, which
\ is its address field. It ends by jumping to (FLUSH), so that the chain of
\ calls under it is one shorter.
: (BRANCH0)
(CG)+1 a! @ CG-BSLOTS inv + 1 + -if MOVE drop jump PLACED \ slot - CG-BSLOTS
MOVE: drop (FLUSH)
PLACED:
\ the word will be appended at HERE; its literals, if any, come after it
HERE 2* 2* 2* (CG)+1 a! @ + (CG)+10 a! !
(PUT)
0 (CG)+13 a! ! jump (FLUSH)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( ref -- ) put the address in (CG)+11 into the branch at ref
: (RESOLVE1)
dup 7 and (MASK) push \ ref R: mask
2/ 2/ 2/ a! \ A: the branch's word
(CG)+11 b! @b pop dup push and \ the address bits
@ pop inv and + ! ;
\ ( target ref -- ) put the address into the branch at ref
: (RESOLVE) SWAP (CG)+11 a! ! jump (RESOLVE1)
\ ( target op -- ) a branch to a known address
: (BRANCH,) SWAP (CG)+11 a! ! (BRANCH0) (CG)+10 a! @ jump (RESOLVE1)
: (JUMP,) ( addr -- ) 2 jump (BRANCH,)
: (CALL,) ( addr -- ) 3 jump (BRANCH,)
v4/capsule/compile.v4
-466
View File
@@ -1,466 +0,0 @@
\ 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)
v4/capsule/core.v4
-479
View File
@@ -1,479 +0,0 @@
\ core.v4 -- the core words the host-node capsules rest on.
\
\ Each is the definition DECOMPOSITION.md gives and the golden-model tests
\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c),
\ written here as text for the text assembler (v4/include/v4/text.h).
\
\ Constants the loader supplies: N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX,
\ CONSOLE-RX, CONSOLE-STATUS, BASE, (MSG), (REPLY), (ME), (OUT),
\ (OUT^), (CONSOLE), (ROUTES), (ROUTE#), (ROUTE-DEFAULT), (PRINT-TO),
\ (PRINT-PORT).
\
\ ERRORS (D-18). A word that finds an error takes its arguments off the stack
\ and stores a code in NODE-ERROR. On a node with a prompt that store is a
\ trap: the word goes no further, and the prompt prints the message for the
\ code and ERROR (quit.v4, (RAISED)). The codes:
\ 1 Negative count 2 Not a number 3 Number too long
\ 4 Not a character 5 Dictionary full 6 Name missing
\ 7 Control structure mismatch 8 Control structures too deep
\ 9 Shift count out of range 10 Protected word
\ 11 Division by zero (Q./) 12 Argument out of range
\ 13 Block out of range 14 No block is being loaded
\ 15 Deferred word not set 16 Not a word
\ 17 Storage refused 18 No one on that port
\ 19 Message refused 20 Node gone
\ 21 Interrupted
\ -1 the word has printed its own message
macro SWAP over push push drop pop pop endmacro
macro - push inv pop + inv endmacro \ x y -- x-y
macro NEGATE inv 1 + endmacro
macro NIP push drop pop endmacro
\ ---- section 4: multiply ------------------------------------------------
header UM*
: UM* ( u1 u2 -- ulo uhi )
over 1 and inv 1 + over 2/ and \ u1 u2 t0 t0 = u2 2/ if u1 odd
over a! N-1 push \ A: u2 R: loop count
push over 2/ pop \ u1 u2 s t0 s = u1 2/
L: +* unext \ u1 u2 s hi A: lo
push drop pop \ u1 u2 hi
2* a -if L0 drop 1 + jump L1 L0: drop L1: push
over -if L2 drop dup jump L3 L2: drop 0 L3: push
dup -if L4 drop over 1 and jump L5 L4: drop 0 L5:
pop + pop + push
and 1 and a 2* + pop ;
\ ---- section 5.7: doubles ------------------------------------------------
header D+
: D+ ( d1 d2 -- d3 )
push over push push drop pop \ al bl R: bh ah
over over xor -if L1
drop + -if C1 jump C0
L1: drop over -if L2
drop + jump C1
L2: drop +
C0: pop pop + ;
C1: pop pop + 1 + ;
header DNEGATE
: DNEGATE ( d -- -d )
inv over if L1 drop push inv 1 + pop ;
L1: drop 1 + ;
\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2). The result is the same.
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
header C@
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop @ 8/ 8/ 8/ 255 and ;
K2: drop @ 8/ 8/ 255 and ;
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
header C!
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ;
K2: drop 8* 8* 16711680 and @ -16711681 and + ! ;
K1: drop 8* 65280 and @ -65281 and + ! ;
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
header CMOVE
: CMOVE ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push
over C@ over C! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
\ ---- section 5.10: the console -------------------------------------------
\ ---- what a node prints (docs/v4.0.0/MESH.md section 6) ------------------------
\ A node has no console of its own. It does what a message asks, and what
\ it prints while doing it is sent as a message: to the node in (CONSOLE), or
\ if that is 0 to whoever sent the text; by the port that leads there, or if
\ this node knows of none, by the port the text came on. A message is seven words and then its text, four
\ characters to a word:
\ to, from, type, heat and TTL, ACL tag, sequence, length in characters
\ The types: 1 text to be interpreted 2 what a node printed 3 how the
\ text ended (one word of text: 0 QUIT, 1 completed, 2 an error).
\ The header of the text being served is in the seven cells (MSG); (REPLY)
\ is the port it came on, by its number; (ME) is this node's number.
\
\ Characters are kept in (OUT), 256 of them, a character to a cell, and sent
\ when it is full and when the text has been done with (quit.v4). (OUT^)
\ is where the next goes.
\
\ THE STACK. What prints may be run with the data stack all but full: EMIT
\ has always needed one free cell and no more, and still does -- it keeps
\ the character and A on the return stack while it works. Sending needs
\ three.
\ FINDING THE WAY (MESH.md section 7). A node knows its ports and nothing of
\ the shape they are wired in. Whoever wires it tells it, for a node, which
\ port leads toward that node: the table (ROUTES), (ROUTE#) entries of a
\ node's number and a port's address; and (ROUTE-DEFAULT), the port for any
\ node that is not in the table, or 0.
\ ( node -- port | -1 ) the port, by its number, that leads toward the node
: (WAY)
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
0
NONE: drop drop (ROUTE-DEFAULT) a! @ if NOWAY (PORT) - ;
NOWAY: drop -1 ;
HIT: drop drop @+ pop drop (PORT) - ;
\ WHOLE MESSAGES (MESH.md section 7d). A message waits on a wire, in the
\ fabric, and not in a node: each wire has a queue of whole messages each
\ way. A node asks the fabric to look at one, take it, move it to another
\ wire, drop it, or put one on, by the six addresses after its ports:
\ (WIRE) the port, by its number, that what follows is about
\ (WIRE-A) (WIRE-B) what the operation needs
\ (WIRE-DO) the operation: a store here is the asking
\ (WIRE-HOW) how it went: 0 done, 1 no room, 2 no one on that port,
\ 3 no such message, 4 not a message
\ (WIRE-HAVE) which wires have a message waiting, a bit to a port
\ The operations: 1 look 2 take 3 move 4 drop 5 put 6 first 7 next
\ 8 sleep 9 sleep for room 10 room. Each is whole: all of a message
\ moves or none of it. So a fault or an error in the middle of anything
\ here leaves no message half moved; and nothing here keeps, from one
\ operation to the next, anything a later pass does not set again for
\ itself: every pass over a wire begins by naming the wire and putting its
\ mark at its first message.
\ This replaced a ring of messages waiting in the node's own memory, a
\ list of refusals owed, and messages written and read a word at a time
\ (MESH.md 7a, 7b, 7c.6). The ports themselves are still written a word at
\ a time for the two things that are not messages: a newborn node's
\ nucleus (PORT!, quit.v4) and a node's requests to its kernel.
\
\ THE STACKS. All of this runs on the stacks the node's text is using.
\ (SERVE) and what it calls keep to four cells of the data stack and four
\ entries of the return stack, its own call among them; what they need
\ from one operation to the next is in cells. (ROOM-SERVE) tries that much.
\ ( op -- how ) ask the fabric for the operation, and say how it went
: (DO) (WIRE-DO) b! !b (WIRE-HOW) b! @b ;
\ ( port -- ) what is asked next is about that port's wire, by its number.
\ A number that is no port's is no wire: every operation then answers 2.
: (WIRE!) (WIRE) b! !b ;
\ ( cells port -- how ) has the port's wire that many cells free? 0: it
\ has; 1: it has not; 2: no one is on that port. Only this node puts
\ messages on the wires that lead from it, so room found stays until it
\ uses it.
: (ROOM?) (WIRE!) (WIRE-A) b! !b 10 jump (DO)
\ ( -- ) ROOM FOR WHAT A WAIT DOES. A node that waits within text -- for
\ an answer, or for room to print -- passes on meanwhile what comes for
\ other nodes, on the stacks the text has left it: four cells of the data
\ stack and four entries of the return stack, (SERVE)'s. They are tried
\ before anything is taken off a wire or put on one: if they are not there
\ the fault comes here, and the text ends "Stack overflow" with nothing
\ half done (MESH.md 7c.7, 7d.4).
\ (ROOM-SERVE) tries just those, and is what a wait for room does each time
\ a message wakes it. (ROOM), which AWAIT does once before it waits, tries
\ six cells, as it did when a message was read a word at a time: the wait
\ ends in an error that leaves the stack as it is, and the line from the
\ console that broke it is then done on that stack, where printing needs
\ six (MESH.md 7c.7).
: (ROOM-SERVE)
0 0 0 0 drop drop drop drop
0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ;
: (ROOM)
0 0 0 0 0 0 drop drop drop drop drop drop
0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ;
\ ( to type -- ) the first six words of a message this node puts, in
\ (OUT-HDR): to, from, type, and the three that are carried: how many nodes
\ may pass it on, sixteen (the TTL: MESH.md 7b.3); ACL tag; sequence.
: (HDR)
push (OUT-HDR) a! !+ (ME) b! @b !+ pop !+ 16 !+ 0 !+ 0 !+ ;
\ ( text port -- how ) put the message whose seven words are in (OUT-HDR)
\ and whose text is at the word address given on the wire of the port, by
\ its number. How it went is the fabric's answer: 0 it is on the wire.
\ THE ROOM KEPT FOR AN ANSWER. While this node does text, (KEEP) is the
\ port its word of how the text ended will go by, and nothing else it puts
\ on that wire may take the last 8 cells: a message that would is refused
\ here, 1, as if the wire were full. With no text being done (KEEP) is -1.
: (PUT-ON)
push (WIRE-B) b! !b pop
dup (WIRE!)
(KEEP) a! @ xor if KEPT
GO: drop (OUT-HDR) (WIRE-A) b! !b 5 jump (DO)
KEPT: drop (OUT-HDR)+6 a! @ 3 + 2/ 2/ 15 + (WIRE-A) b! !b 10 (DO) if GO ;
\ REFUSALS (MESH.md 7b, 7d.4). A message this node cannot pass on is
\ dropped and counted in (LOST), and whoever waits on it is told, by a
\ message of type 4, a NACK, whose one word is the node the refused message
\ was for: its sender; or, for a node's answer (type 3), the node the
\ answer was for, which is the one that waits, about the node that
\ answered. The NACK is put at once. If it cannot go -- no way, no one on
\ the port, no room -- it is counted in (LOST) too, and that is the end of
\ it. Nothing is told for a NACK or for a GONE, type 5: there is no NACK
\ for a NACK.
\ ( -- ) the message the mark of the wire in (WIRE) is at, whose seven
\ words are in (IN), is refused. A refusal for this node itself -- its own
\ message came back to it -- is counted in (REFUSED) as one that came by a
\ wire would be; or, if it is about the node this one is waiting on,
\ (A-SELF) is set for AWAIT to find (quit.v4).
\ (WIRE) is not what it was afterwards: the NACK went by another.
\ If the drop does not drop -- the wire was cut after the message was looked
\ at, which let it go already -- nothing is counted and no one is told.
: (REFUSE)
4 (DO) if DROPPED drop ; \ it was not there to drop -- its wire has been cut: nothing is counted or told
DROPPED: drop
(LOST) a! @ 1 + !
(IN)+2 a! @ -4 + if NOT -1 + if NOT 2 + if ANSWER
drop (IN) a! @ (ONE) a! ! (IN)+1 a! @ jump TELL \ about whom it was for; to its sender
ANSWER: drop (IN)+1 a! @ (ONE) a! ! (IN) a! @ \ about the node that answered; to whom the answer was for
TELL: dup (ME) a! @ xor if SELF drop
dup 4 (HDR) 4 (OUT-HDR)+6 a! !
(WAY) (ONE) SWAP (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! ;
SENT: drop ;
SELF: drop drop
(AWAIT-FROM) a! @ if COUNT (ONE) a! @ xor if MINE
COUNT: drop (REFUSED) a! @ 1 + ! ;
MINE: drop 1 (A-SELF) a! ! ;
NOT: drop ;
\ ( port -- bit ) the bit for a port, by its number, in a word of a bit to a port
: (WBIT)
push 1 pop if Z -1 + FOR 2* NEXT ;
Z: drop ;
\ ( -- ) A MESSAGE FOR ANOTHER NODE is passed on (MESH.md section 7): the
\ one the mark of the wire in (WIRE) is at, whose seven words are in (IN),
\ is moved, whole, to the wire that leads toward that node. It is refused
\ instead if it has been passed on as often as a message may be; or if
\ there is no way, or no one on the port.
\ WITH NO ROOM on that wire -- or none but the room kept on it, (KEEP) --
\ text, a NACK and a GONE are refused, at once. But what a node printed
\ (type 2) and its word of how text ended (type 3) are NOT let go for want
\ of room: the message is left where it is, on the wire it came by, and
\ gone past; what is behind it is served; and it is moved on a later pass,
\ when there is room. Printing waits; it is not lost (MESH.md 7d.1,
\ ruling 3). (H-PORT) and (H-NEED) are the port of the first message left
\ so on this pass and the cells it needs there: a node that then sleeps,
\ sleeps for that room, (SLEEP), and is woken by room on any wire.
\ (H-MASK) has a bit for each port something was left for: what is behind
\ it for the same port is left too, though it be shorter and would fit, so
\ that what a node printed goes on in the order it came.
\ HOW OFTEN. A message's fourth word is how many more nodes may pass it
\ on; a node sends it with 16, and a move takes one off. The node that
\ finds 1 there refuses it. A device sends it with 0, which is taken for
\ 16: so 0 down to -14 are passed on and -15 is refused. Anything else is
\ nothing a node or a device sent, and is refused.
: (PASS)
(IN)+3 a! @ -if POS
14 + -if OK jump SPENT
POS: if OK -1 + if SPENT -16 + -if SPENT
OK: drop
(IN) a! @ (WAY) (P-WAY) a! !
(IN)+6 a! @ 3 + 2/ 2/ 7 + \ the cells it takes,
(P-WAY) a! @ (KEEP) a! @ xor if KEPT drop jump NEED
KEPT: drop 8 + \ and the room kept, if it is that wire
NEED: (P-NEED) a! !
(P-WAY) a! @ -if WAY \ no way: refused
SPENT: drop jump (REFUSE)
WAY: (WBIT) (H-MASK) a! @ and if CLEAR \ something is left for that port already?
FULL: drop (IN)+2 a! @ -2 + if HOLD -1 + if HOLD jump SPENT \ no room: only output and answers wait
CLEAR: drop
(P-NEED) a! @ (P-WAY) a! @ (ROOM?) (S-WIRE) a! @ (WIRE!)
if GO -1 + if FULL jump SPENT \ no one on that port: refused
GO: drop (P-WAY) a! @ (WIRE-A) b! !b 3 (DO) if MOVED jump SPENT
MOVED: drop ;
HOLD: drop
(P-WAY) a! @ (WBIT) dup inv (H-MASK) a! @ and + !
(H-PORT) a! @ -if HELD drop (P-WAY) a! @ (H-PORT) a! ! (P-NEED) a! @ (H-NEED) a! ! 7 (DO) drop ;
HELD: drop 7 (DO) drop ;
\ ( -- ) SLEEP until a message comes -- or, if (SERVE) left a message
\ on a wire for want of room, until there is that room or a message comes
\ or any wire of this node's gains room (operation 9, MESH.md 7d.3).
: (SLEEP)
(H-PORT) a! @ -if ROOM drop 8 (DO) drop ;
ROOM: (WIRE!) (H-NEED) a! @ (WIRE-A) b! !b 9 (DO) drop ;
\ ( -- ) ONE PASS OVER EVERY WIRE THAT HAS A MESSAGE. What is for another
\ node is passed on, or refused; what is for this node is left where it
\ is. Fetching (WIRE-HAVE) is what tells the fabric this node has seen
\ what had come: a sleep after this is woken only by what comes later
\ (MESH.md 7d.3). (S-HAVE) keeps which wires they were, for whoever then
\ looks for what is this node's own, (MINE).
: (SERVE)
(WIRE-HAVE) b! @b dup (S-HAVE) a! ! (S-MASK) a! !
0 (S-WIRE) a! ! -1 (H-PORT) a! ! 0 (H-MASK) a! !
W: (S-MASK) a! @ if END
dup 2/ ! 1 and if NEXTW
drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop
M: (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED jump NEXTW
LOOKED: drop
(IN) a! @ (ME) a! @ xor if MINE drop (PASS) jump M
MINE: drop 7 (DO) drop jump M
NEXTW: drop (S-WIRE) a! @ 1 + ! jump W
END: drop ;
\ WHAT IS FOR THIS NODE is gone through after (SERVE), a message at a time:
\ (MINE0) begins, and each (MINE) puts the mark of a wire at the next
\ message for this node and its seven words in (IN). Whoever asked then
\ takes or drops that message -- the mark is then at the one that followed
\ -- or leaves it and goes past it, (SKIP). The wire is (S-WIRE).
\ ( -- ) begin with the wires (SERVE) found a message on
: (MINE0) (S-HAVE) a! @ (S-MASK) a! ! -1 (S-WIRE) a! ! 0 (S-ON) a! ! ;
\ ( -- flag ) the next message for this node; 0: there are no more
: (MINE)
L: (S-ON) a! @ if WIRE
drop (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED
drop 0 (S-ON) a! ! jump L \ this wire has no more
LOOKED: drop (IN) a! @ (ME) a! @ xor if HIT
drop 7 (DO) drop jump L
HIT: drop -1 ;
WIRE: drop (S-WIRE) a! @ 1 + ! \ the next wire that had one
(S-MASK) a! @ if NONE
dup 2/ ! 1 and if NOT
drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop 1 (S-ON) a! ! jump L
NOT: drop jump L
NONE: ;
\ ( -- ) go past the message (MINE) found: it stays on its wire
: (SKIP) (S-WIRE) a! @ (WIRE!) 7 (DO) drop ;
\ ( -- ) A TAKE DID NOT TAKE the message (MINE) found. The fabric takes
\ only the message last looked at (MESH.md 7d.3), so either the wire has
\ been cut -- and there is nothing there, or another message that has not
\ been looked at -- or the message cannot be taken at all. It is dropped,
\ and counted in (LOST); if it cannot be dropped either it is gone past.
\ Either way whoever goes through the messages next is at another one:
\ nothing goes round on one that will not be taken.
: (UNTAKEN)
(S-WIRE) a! @ (WIRE!) 4 (DO) if GONE drop jump (SKIP)
GONE: drop (LOST) a! @ 1 + ! ;
\ ( -- how ) take the message (MINE) found, which has one word of text:
\ its seven words stay in (IN), and its word goes to (ONE). 0: it is
\ taken. Anything else: it is not -- the wire was cut after the message
\ was looked at -- and (ONE) is not its word: nothing is to be done for it.
: (TAKE1) (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b (ONE) (WIRE-B) b! !b 2 jump (DO)
\ ( -- how ) WAIT UNTIL THE WIRE of the port (W-PORT) has (W-NEED) cells
\ free. 0: it has. 2: no one is on that port. The node sleeps until
\ there is room, or a message comes, or another wire of its own gains
\ room; woken with no room yet, it passes on what is for other nodes,
\ (SERVE), and sleeps again. It is the one thing a node waits to put:
\ what a text prints (MESH.md 7d.1, ruling 3).
\ NOTHING BREAKS THIS WAIT but the room coming or the wire being cut
\ (ruled 2026-10-08): text for this node that comes meanwhile, from its
\ console or anyone, stays on its wire and is done when this text has been
\ finished with. A text whose printing can never go, because a stuck node
\ is on the way, waits until that node is killed (MESH.md 7d.6).
: (WAIT-ROOM)
L: (W-PORT) a! @ (WIRE!) (W-NEED) a! @ (WIRE-A) b! !b 9 (DO)
if DONE -1 + if WOKEN drop 2 ;
WOKEN: drop (WIRE-HAVE) b! @b if QUIET \ no wire has a message: there is nothing to pass on,
drop (ROOM-SERVE) (SERVE) jump L \ and no more of the stacks is asked for than a wait needs
QUIET: drop jump L
DONE: ;
\ ( -- ) send what has been printed, to where (PRINT-TO) says, by the port
\ (PRINT-PORT): a message of type 2, its characters four to a word, the
\ first lowest. quit.v4 sets those two when text for this node arrives.
\ It waits for room on the wire, and for the 8 cells kept as well when the
\ wire is the one the answer goes by. The characters are made ready in
\ (OUT-TEXT), not where they are: until the message is on the wire the
\ buffer is as it was, and a fault on the way leaves it to be sent again.
\ The three cells after the last character are made zero first, so that
\ nothing printed earlier goes on the wire in the last word (they are in
\ the buffer, or the four free cells after it).
\ The three cells and two return entries this needs are tried first.
\ WITH NO ONE ON THE PORT -- when it waits for room, or when it comes to
\ put -- what was printed cannot be sent. While the text is being done
\ that is its error, 18; and the data stack is emptied first, as a fault
\ empties it. A word that raises an error has taken its own arguments
\ off; this one comes from under whatever word was printing, in the
\ middle of its work, and what that word had on the stack is nothing its
\ caller can use (as first built those values were left there). Once it has been finished with, what it printed
\ is let go and counted in (LOST), and the text is said to have ended in
\ an error: (LINE-STATUS), which is the word then sent of how it ended.
: (FLUSH-OUT)
(OUT^) a! @ (OUT) xor if NONE drop
0 0 0 drop drop drop 0 push 0 push pop drop pop drop
(OUT^) a! @ (OUT) - 3 + 2/ 2/ 7 +
(PRINT-PORT) a! @ (KEEP) a! @ xor if SAME drop jump NEED
SAME: drop 8 +
NEED: (W-NEED) a! ! (PRINT-PORT) a! @ (W-PORT) a! !
(WAIT-ROOM) if ROOM
NOONE: drop (QUIET) a! @ if TELL
drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! 2 (LINE-STATUS) a! ! ;
TELL: drop DSTACK-DEPTH b! a !b NODE-ERROR b! 18 !b ; \ the data stack is emptied, as by a fault: see below
ROOM: drop
(PRINT-TO) a! @ 2 (HDR)
(OUT^) a! @ a! 0 !+ 0 !+ 0 !
(OUT^) a! @ (OUT) - dup (OUT-HDR)+6 a! !
3 + 2/ 2/ -1 + push (OUT-TEXT) pop (OUT) a!
FOR @+ @+ 8* + @+ 8* 8* + @+ 8* 8* 8* + over b! !b 1 + NEXT
drop
(OUT-TEXT) (PRINT-PORT) a! @ (PUT-ON) if SENT jump NOONE
SENT: drop (OUT) (OUT^) a! ! ;
NONE: drop ;
\ EMIT puts the character with what has been printed. Everything the node
\ prints goes through EMIT. A is kept: the words that print have always
\ been free to use it across an EMIT. As v3, only the low 8 bits of the
\ character are printed.
\ A BUFFER FOUND FULL is sent first. It is full when a flush of it ended
\ in a fault -- the stack too deep to begin a message -- and what is printed
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
header EMIT
: EMIT ( c -- )
255 and a push push \ A, and then the character, to the return stack
(OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT
STALE: drop (FLUSH-OUT)
PUT:
(OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on
a (OUT)+256 xor if FULL drop pop a! ;
FULL: drop (FLUSH-OUT) pop a! ;
header KEY
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
header CR
: CR ( -- ) 10 jump EMIT
header SPACE
: SPACE ( -- ) 32 jump EMIT
header COUNT
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
header TYPE
: TYPE ( baddr u -- )
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
DONE: drop drop ;
\ ( x -- ) up to four characters packed in one cell, the first in the low
\ byte: how the capsule prints its own short messages, a literal at a time.
: (EMIT4)
L: if DONE dup EMIT 8/ jump L
DONE: drop ;
\ ---- section 5.8: the number base ----------------------------------------
: (BASE) ( -- b ) \ BASE, or 10 when it is outside 2 .. 36
BASE b! @b dup -2 + -if L1 drop drop 10 ;
L1: drop dup -37 + -if L2 drop ;
L2: drop drop 10 ;
v4/capsule/dict.v4
-233
View File
@@ -1,233 +0,0 @@
\ dict.v4 -- the dictionary: its space, its entries, and looking a name up.
\
\ DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND ' ,
\ and the entry-field words >LINK LFA LINK> >NAME NFA NAME> CFA PFA >BODY
\ TRAVERSE SMUDGE HIDDEN. Part of the compiler capsule: it runs on the host
\ node. Rests on core.v4 and input.v4.
\
\ AN ENTRY. A word's execution address (xt) is the address of its code, and
\ everything else is found from it:
\
\ name the count byte, then the characters, four bytes to a cell,
\ padded with zeros to a whole cell
\ xt - 3 flags: 1 immediate, 2 hidden, 4 data
\ xt - 2 the word address of the name
\ xt - 1 the link: the xt of the entry before this one, 0 for the first
\ xt the code
\
\ A name holds at most 31 characters; longer ones are cut to 31 both when
\ defined and when looked up, so 31 characters are significant (FORTH-79).
\ A "data" word is one whose code is a single call to its run-time routine,
\ with its parameter field in the cell after it: xt + 1. For any other word
\ the parameter field is the code itself.
\
\ THE SPACE. DP is a byte address, so that C, can pack characters; HERE is
\ the next whole cell. An address unit is a cell (D-1): ALLOT counts cells.
\
\ Constants the loader supplies:
\ DP word address of the variable: the next free byte
\ (LATEST) word address of the variable: the xt of the newest entry of the
\ FORTH vocabulary, or 0
\ CONTEXT CURRENT word addresses of the variables: each holds the address
\ of a vocabulary's head cell -- the cell that holds the xt of
\ that vocabulary's newest entry. FORTH's head cell is (LATEST).
\
\ VOCABULARIES (FORTH-79). A name is looked up in the CONTEXT vocabulary and
\ then, if that is not FORTH, in FORTH. A new entry goes into the CURRENT
\ vocabulary: it is linked to that vocabulary's newest entry and becomes it.
\ DBASE DLIMIT byte addresses of the start and end of dictionary space
\ PAD byte address of the scratch area for strings, 84 bytes or more
\ (D) word address of five cells of scratch for this file
\ (WORD-DEFINED) (WORD-FORGOTTEN) word addresses of two variables: see
\ "telling the kernel" below
\ PAD is in line.
macro 4* 2* 2* endmacro
macro 4/ 2/ 2/ endmacro
macro OR over inv and xor endmacro
\ ---- the space (5.12) ------------------------------------------------------
\ These reach DP through B and leave A alone, so that , and C, can keep what
\ they are storing in A while the space is taken: nothing of theirs is then
\ on the data stack under (DP+), which itself needs three cells (D-2).
: (DERR) ( -- 0 ) NODE-ERROR b! 5 !b 0 ; \ dictionary full
\ ( n -- flag ) move DP by n bytes if it stays inside the dictionary space
\ and say -1; otherwise leave it, set NODE-ERROR and say 0. The two
\ subtractions are x + ~y + 1, which unlike the in-line - needs no return
\ entry: these words are called at the bottom of long chains of calls.
: (DP+)
DP b! @b +
dup DBASE inv + 1 + -if LOW drop drop jump (DERR) \ new - DBASE
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
HIGH: drop DP b! !b -1 ;
header HERE
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
header ALIGN
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
header ALLOT
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
header ,
: , ( x -- )
a!
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
dup inv DLIMIT + -3 + -if ROOM \ DLIMIT - (it + 4)
drop drop NODE-ERROR b! 5 !b ;
ROOM: drop dup 4 + !b \ DP is past it
4/ b! a !b ;
header C,
: C, ( c -- )
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
header 2,
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
header LATEST
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
header >LINK
: >LINK ( xt -- addr ) -1 + ;
header LFA
: LFA ( xt -- addr ) jump >LINK
header LINK>
: LINK> ( addr -- xt ) a! @ ;
header >NAME
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
header NFA
: NFA ( xt -- baddr ) jump >NAME
header NAME>
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
header CFA
: CFA ( xt -- xt ) ;
header PFA
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
header >BODY
: >BODY ( xt -- addr ) jump PFA
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
header TRAVERSE
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
header SMUDGE
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
header HIDDEN
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
\ ---- telling the kernel (docs/v4.0.0/ENGINE.md 3b) ------------------------------
\ A word's code is here on the node; its accounts are a record its kernel
\ keeps. So the kernel has to be told of every entry that is made and of
\ every entry that goes. An entry is made in one place, (HEADER); entries go
\ in two, FORGET and COLD (system.v4). Each tells through a variable that
\ holds the xt of a word to run, or 0 for a node whose host keeps no records:
\ (WORD-DEFINED) ( xt -- ) an entry has been made; its code will be at xt
\ (WORD-FORGOTTEN) ( w -- ) every entry at word address w or above is gone
\ On the bare-metal system the kernel puts words of its own there.
\ ( -- ) tell of the entry just made, whose code starts at HERE
: (DEFINED)
(WORD-DEFINED) b! @b if NONE HERE SWAP push ;
NONE: drop ;
\ ( w -- ) tell that the entries from word address w up have gone
: (FORGOTTEN)
(WORD-FORGOTTEN) b! @b if NONE push ;
NONE: drop drop ;
\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count (D)+4 whether a lookup has gone on to FORTH
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
: (NEED) (D)+3 a! @ 4 + -4 and 12 + ;
\ ( baddr -- ) an entry for the counted string at baddr; its code starts at
\ HERE afterwards. An empty name, or no room, makes nothing and sets
\ NODE-ERROR.
: (HEADER)
dup (D)+2 a! ! \ (CLIP), in line
C@ -32 + -if LONG drop jump CLIPPED
LONG: drop 31 (D)+2 a! @ C!
CLIPPED:
(D)+2 a! @ C@ if EMPTY \ len
(D)+3 a! !
ALIGN
(NEED) (DP+) if FULL drop \ there is room;
(NEED) NEGATE (DP+) drop \ DP back where it was
HERE (D) a! ! \ where the name starts
(D)+3 a! @ C,
L: (D)+3 a! @ if DONE -1 + !
(D)+2 a! @ 1 + dup ! C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop
0 , (D) a! @ , LATEST ,
HERE CURRENT a! @ a! !
jump (DEFINED)
FULL: drop ; \ (DP+) has set NODE-ERROR
EMPTY: drop NODE-ERROR b! 6 !b ; \ name missing
\ ---- looking a name up -----------------------------------------------------
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string.
\ Written out in one piece -- the string cut to 31, each entry's flags and
\ name fetched, the two names compared byte by byte -- so that the only call
\ it makes is C@: it is called from the interpreter for every word of every
\ line, with the user's return stack beneath it.
: (LOOKUP)
dup (D)+1 a! ! \ cut the string to 31 characters
C@ -32 + -if LONG drop jump CUT
LONG: drop 31 (D)+1 a! @ C!
CUT:
0 (D)+4 a! ! \ not yet on to FORTH
CONTEXT a! @ a! @
L: if END
(D)+2 a! !
(D)+2 a! @ -3 + a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop
(D)+2 a! @ -2 + a! @ 4* (D) a! ! \ its name
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
C: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop jump OLDER
EQ: drop jump C
SAME: drop (D)+2 a! @ ;
OLDER: (D)+2 a! @ -1 + a! @ jump L
END: (D)+4 a! @ if FIRST drop ; \ FORTH has been searched: not found
FIRST: drop -1 (D)+4 a! !
CONTEXT a! @ (LATEST) xor if ISFORTH \ CONTEXT is FORTH: that was it
drop drop (LATEST) a! @ jump L
ISFORTH: drop ;
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
header FIND
: FIND 32 WORD jump (LOOKUP)
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
\ input stream. Not found is an error: 0, and NODE-ERROR is set. This is '
\ when interpreting; compile.v4 adds what ' does when compiling.
\ ( -- 0 ) say that the word WORD has just left is not known, as v3 does:
\ UNKNOWN WORD: 'xxx'
: (UNKNOWN)
$4E4B4E55 (EMIT4) $204E574F (EMIT4) $44524F57 (EMIT4) $27203A (EMIT4)
WBUF COUNT TYPE 39 EMIT CR
NODE-ERROR b! -1 !b 0 ;
: (') 32 WORD (LOOKUP) if MISSING jump PFA
MISSING: drop jump (UNKNOWN)
v4/capsule/forth.v4
-229
View File
@@ -1,229 +0,0 @@
\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are
\ opcodes or short runs of them, and the variables that are in-line addresses.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18).
\ A word flagged inline is copied into a definition in place of a call; the
\ ones that touch the return stack are compile-only as well. Rests on core.v4,
\ compile.v4's loader constants, and quit.v4, which the division words leave
\ through when the divisor is zero. (F) is seven cells of scratch for
\ this file.
\ ---- stack ----
header DUP inline : DUP dup ;
header DROP inline : DROP drop ;
header OVER inline : OVER over ;
header SWAP inline : SWAP' SWAP ;
header ROT inline : ROT' ROT ;
header -ROT inline : -ROT SWAP push SWAP pop ;
header ?DUP : ?DUP if Z dup ; Z: ;
header 2DUP inline : 2DUP over over ;
header 2DROP inline : 2DROP drop drop ;
\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
\ stack that has no addresses: the values above the one wanted are set aside
\ in (S), and put back. (F)+3 how many are still to set aside, (F)+4 where
\ the next goes, (F)+5 the value wanted, (F)+6 how many are set aside. With n on top of a stack that is
\ otherwise one short of full there is no room at all, so until a value has been set aside nothing here pushes
\ anything while n is still there, and never more than one cell after.
\ FORTH-79: how many values were on the stack before DEPTH
header DEPTH
: DEPTH DSTACK-DEPTH b! @b ;
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
: (INDEX)
R-CLEAR (EMIT4) $6E49203A (EMIT4) $696C6176 (EMIT4) $6E692064 (EMIT4) $786564 (EMIT4) CR
2 jump (DONE)
\ ( x1 .. xn-1 -- ) A: n, which is 2 or more. Set the n-1 values above
\ the n-th aside. If there are not that many, the pop that finds the stack
\ empty is a fault: "Stack underflow". The count is taken down only after a
\ value has been set aside, when there is room to do the arithmetic.
: (DIG)
(F)+3 b! a !b
(F)+4 b! (S) !b
(F)+6 b! 0 !b
L: (F)+4 b! @b a! !+
a (F)+4 b! !b
(F)+6 b! @b 1 + !b
(F)+3 b! @b -1 + dup !b
-1 + if DONE drop jump L
DONE: drop ;
\ ( -- x1 .. xk ) put them back. The test that ends it pushes one cell:
\ after the last value is back the stack may be one short of full.
: (BURY)
L: (F)+6 b! @b if DONE -1 + !b
(F)+4 a! @ -1 + dup ! a! @
jump L
DONE: drop ;
\ ( n -- x ) FORTH-79: a copy of the n-th value, not counting n itself.
\ 1 PICK is DUP, 2 PICK is OVER. n less than one is an error.
header PICK
: PICK
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop \ n is 1 when half of it is 0
(DIG) dup (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop dup ;
BAD: drop $4B434950 jump (INDEX)
\ ( n -- ) FORTH-79: the n-th value, not counting n itself, is taken out
\ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n
\ less than one is an error.
header ROLL
: ROLL
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop
(DIG) (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop ;
BAD: drop $4C4C4F52 jump (INDEX)
\ ---- return stack: in line, and only inside a definition ----
header >R inline compile-only : >R push ;
header R> inline compile-only : R> pop ;
header R@ inline compile-only : R@ pop dup push ;
header I inline compile-only : I pop dup push ;
header J inline compile-only : J pop pop pop dup push a! push push a ;
header LEAVE inline compile-only : LEAVE pop pop drop dup push push ;
header UNLOOP inline compile-only : UNLOOP pop drop pop drop ;
\ ---- memory ----
header @ inline : FETCH a! @ ;
header ! inline : STORE a! ! ;
header +! inline : +! a! @ + ! ;
header CELLS inline : CELLS ; \ an address unit is a cell (D-1)
\ ---- arithmetic ----
header + inline : PLUS + ;
header - inline : MINUS - ;
\ The low cell of the product, by N steps of +* with nothing but the count on
\ the return stack. UM* drop gives the same cell but needs two more return
\ entries, which a word inside two DO loops does not have (D-2). The low
\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach
\ the bit that moves into A, and the loop ends first.
header * : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
header NEGATE inline : NEGATE' NEGATE ;
header 1+ inline : 1+ 1 + ;
header 1- inline : 1- -1 + ;
header 2+ inline : 2+ 2 + ;
header 2- inline : 2- -2 + ;
header 2* inline : TWO* 2* ;
header 2/ inline : TWO/ 2/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
\ does anything else, and a zero divisor prints v3's message --
\ /: Division by zero
\ -- and ends the line with ERROR, from however deep, as an address fault
\ does. The word's operands are taken off the stack, as v3 takes them, and
\ its caller is not returned to.
\ ( name2 name1 -- ) the word's name: its first four characters, and the
\ rest or 0 (EMIT4). The return stack is emptied before anything is called:
\ the word may have been run with it full.
: (DIV0)
R-CLEAR (EMIT4) (EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b"
$657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero"
2 jump (DONE)
\ ( d n -- rem quot ) truncating toward zero: the quotient has the sign of
\ d xor n, the remainder the sign of d. This is section 4's SM/REM with its
\ UM/MOD -- restoring division, one step a bit, the divisor in A -- written
\ into it, and the two signs kept in (F) where section 4 has them on the
\ return stack. A word that divides is then four return entries deep, not
\ eight, so division can be used inside words that other words call (D-2).
\ The answer is the same. Exact when the quotient fits a cell; its callers
\ have seen to it that n is not zero.
: SM/REM
over over xor (F) a! ! \ the quotient's sign, in its top bit
over (F)+1 a! ! \ the remainder's
-if L0 inv 1 + L0: a! \ A: |n|
-if L1 DNEGATE L1: \ |d|
N-1 FOR
-if S0
2* over -if S1 drop 1 + jump S2
S1: drop S2: push 2* pop
jump SUB
S0:
2* over -if S3 drop 1 + jump S4
S3: drop S4: push 2* pop
dup a xor -if S5
drop -if NOSUB jump SUB
S5: drop dup inv a + inv -if S6
drop jump NOSUB
S6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop \ urem uquot
(F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
header S>D
: S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
header M*
: M* ( n1 n2 -- d )
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop jump DNEGATE P: drop ;
\ ( n1 n2 n3 -- rem quot ) n1 * n2 as a double, divided by n3, which is
\ not zero. M* is written in, and n3 waits in (F)+2, so that the multiply
\ is as few return entries down as it can be.
: (*/MOD)
(F)+2 a! !
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop DNEGATE jump Q P: drop Q:
(F)+2 a! @ jump SM/REM
header /MOD
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: drop drop 0 $444F4D2F jump (DIV0)
header /
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: drop drop 0 $2F jump (DIV0)
header MOD
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: drop drop 0 $444F4D jump (DIV0)
header */MOD
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
header */
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: drop drop drop 0 $2F2A jump (DIV0)
header M/MOD
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
\ ---- logic and comparison ----
header AND inline : AND and ;
header XOR inline : XOR xor ;
header OR inline : OR' OR ;
header 0= : 0= if L1 drop 0 ; L1: drop -1 ;
header 0< : 0< -if L1 drop -1 ; L1: drop 0 ;
header NOT : NOT jump 0=
header = : EQUALS xor jump 0=
header < : LESS
over over xor -if SAME drop drop jump 0<
SAME: drop - jump 0<
header > : GREATER SWAP jump LESS
\ ---- in-line addresses and constants ----
header BL inline : BL' BL ;
header TIB inline : TIB' TIB ;
header >IN inline : >IN' >IN ;
header SPAN inline : SPAN' SPAN ;
header BASE inline : BASE' BASE ;
header PAD inline : PAD' PAD ;
header STATE inline : STATE' STATE ;
v4/capsule/input.v4
-217
View File
@@ -1,217 +0,0 @@
\ input.v4 -- reading a line and splitting it into words and numbers.
\
\ DECOMPOSITION.md 5.9: TIB >IN SPAN SOURCE BL EXPECT QUERY WORD ENCLOSE
\ CONVERT NUMBER, and the comment words ( and \ of 5.15 (named PAREN and
\ BACKSLASH here, since the text assembler reads those two characters as its
\ own comments; the dictionary will give them their names). Part of the compiler
\ capsule: it runs on the host node. Rests on core.v4.
\
\ Constants the loader supplies:
\ TIB byte address of the text input buffer; QUERY fills at most 81 bytes
\ >IN word address of the variable: offset in TIB of the next character
\ SPAN word address of the variable: how many characters the last
\ EXPECT or QUERY read
\ WBUF byte address of WORD's buffer, 257 bytes
\ (P) word address of eight cells of scratch for this file
\ (SRC) word address of the variable: the byte address of the text being
\ interpreted. QUERY makes it TIB; LOAD (blocks.v4) makes it a
\ block buffer. >IN is an offset from it and SPAN its length.
\ (SRC-HOOK) word address of a variable: 0, or the address of a word
\ that WORD calls before it looks at the text, to make sure (SRC)
\ is right. LOAD puts one there: a block buffer can be given to
\ another block between one word of the text and the next.
\ BLK word address of the variable: the block being interpreted, or
\ 0 for the terminal (FORTH-79)
\ TIB >IN SPAN and BL are in-line: written in a definition they are literals.
macro BL 32 endmacro
\ ( -- baddr u ) the input buffer and how much of it is in use
header SOURCE
: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ;
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
\ baddr upward until a new-line or until n have been received; the new-line
\ is taken but not stored. A zero is added after the text, so the buffer
\ must hold n + 1 bytes. No action for n <= 0. SPAN is how many characters
\ were stored (SPAN is not FORTH-79; v3 has it). A line longer than n leaves
\ the rest, its new-line included, to be read next.
\ It is what the prompt reads every line with, with whatever the user has left
\ on the stack beneath it, so it works in (P) -- (P)+0 where the next
\ character goes, (P)+1 how many more may come, (P)+2 where the first went --
\ and has at most three cells of its own on the data stack (D-2).
header EXPECT
: EXPECT
-if NN drop drop ; \ n < 0
NN: if ZERO
(P)+1 a! ! dup (P)+2 a! ! (P) a! !
L: (P)+1 a! @ if END drop
KEY dup -10 + if NL drop \ c
(P) a! @ C!
(P) a! @ 1 + ! (P)+1 a! @ -1 + !
jump L
NL: drop drop jump FIN
END: drop
FIN: 0 (P) a! @ C!
(P) a! @ (P)+2 a! @ - SPAN a! ! ;
ZERO: drop drop ;
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
header QUERY
: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
\ ---- WORD ------------------------------------------------------------------
\ WORD is called from deep inside the interpreter and compiler, with whatever
\ the user has on the stacks beneath it, and the stacks are ten and nine deep
\ (D-2). So everything it works on is in (P), and it never has more than
\ three cells of its own on the data stack:
\ (P)+0 the delimiter (P)+1 the length of the text in TIB
\ (P)+2 the word's length (P)+3 how much of it is still to be copied
\ (P)+6 where it is in TIB (P)+7 where the word starts
\ (CONVERT and NUMBER use (P)+2 .. (P)+5; they and WORD never run inside
\ each other.)
\ ( -- c ) the character WORD is at. A zero reads as a blank when words
\ are being split at blanks: a block that has never been written is all
\ zeros, and so is the end of one whose lines were put there one at a time.
: (SRC@)
(P)+6 a! @ (SRC) a! @ + C@ if Z ;
Z: drop (P) a! @ -32 + if B drop 0 ;
B: drop 32 ;
\ In line, not called: WORD may have only a few return entries to spare.
macro (LEFT) (P)+6 a! @ (P)+1 a! @ - endmacro \ ( -- d ) d < 0 while inside the text
macro (CH) (SRC@) (P) a! @ xor endmacro \ ( -- x ) x = 0 at a delimiter
macro (STEP) (P)+6 a! @ 1 + ! endmacro
\ ( c -- baddr ) FORTH-79: characters are taken from TIB until the
\ delimiter c or the end of the text, leading delimiters ignored, and stored
\ in WBUF as a counted string. The delimiter met -- c, or a zero if the text
\ ran out -- is stored after them and is not counted. >IN is left just past
\ that delimiter. With nothing left the count is 0. The count is a byte,
\ so a word longer than 255 characters is cut to 255.
\ The three parts of WORD. The first is called and returns before anything
\ else is; the last is jumped to; so WORD's calls of C@ and C! are no deeper
\ than if it were written in one piece.
: (WORD-SET) ( c -- )
255 and (P) a! !
(SRC-HOOK) a! @ if NONE push ex \ call it: ex comes back to the next word
jump HOOKED
NONE: drop
HOOKED:
SPAN a! @ -if A drop 0 A: (P)+1 a! !
>IN a! @ -if B drop 0 B: (P)+6 a! ! ;
: (WORD-TAKE) ( -- baddr )
(P)+6 a! @ (P)+7 a! ! \ where it starts
SC: (LEFT) -if SCE drop (CH) if SCE drop (STEP) jump SC \ up to a delimiter
SCE: drop
(P)+6 a! @ (P)+7 a! @ - \ its length
dup -256 + -if CAP drop jump FITS CAP: drop drop 255 FITS:
dup (P)+2 a! ! (P)+3 a! !
(P)+2 a! @ WBUF C!
\ copy it, last character first
CP: (P)+3 a! @ if COPIED -1 + dup ! \ k
dup (P)+7 a! @ + (SRC) a! @ + C@ \ k c
SWAP WBUF+1 + C!
jump CP
COPIED: drop
(LEFT) -if RANOUT
drop (P) a! @ (P)+2 a! @ WBUF+1 + C! \ the delimiter after the text
(P)+6 a! @ 1 + >IN a! ! WBUF ;
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
(P)+6 a! @ >IN a! ! WBUF ;
header WORD
: WORD
(WORD-SET)
SK: (LEFT) -if SKE drop (CH) if SKS drop jump (WORD-TAKE) \ past delimiters
SKS: drop (STEP) jump SK
SKE: drop jump (WORD-TAKE)
\ ( c -- baddr ) as WORD, but leading delimiters are not ignored: the text
\ starts at >IN, and may be empty. This is what ." needs: ." " is an
\ empty string, where WORD would step over its closing quote.
: (PARSE) (WORD-SET) jump (WORD-TAKE)
\ ---- ENCLOSE ---------------------------------------------------------------
\ (P)+0 the delimiter, (P)+1 the string's address.
: (E?) ( i -- i k ) \ k: 0 at the end of the string, 1 at a delimiter, else 2
dup (P)+1 a! @ + C@ if END (P) a! @ xor if DEL drop 2 ;
DEL: drop 1 ;
END: drop 0 ;
: (ESKIP) ( i -- i' ) L: (E?) -1 + if S drop ; S: drop 1 + jump L
: (ESCAN) ( i -- i' ) L: (E?) -2 + if S drop ; S: drop 1 + jump L
\ ( baddr c -- baddr n1 n2 n3 ) in the zero-terminated string at baddr:
\ n1 the offset of the first character that is not c, n2 the offset of the
\ first c after it, n3 the offset of the first character after that run of c.
header ENCLOSE
: ENCLOSE
255 and (P) a! ! dup (P)+1 a! !
0 (ESKIP) dup (ESCAN) dup (ESKIP) ;
\ ---- CONVERT and NUMBER ----------------------------------------------------
\ ( c -- n ) the value of the digit c, 0 .. 35, in either case; -1 if none
: (DIGIT)
dup -48 + -if GE0 drop drop -1 ;
GE0: drop dup -58 + -if GT9 drop -48 + ;
GT9: drop dup -65 + -if GEA drop drop -1 ;
GEA: drop dup -91 + -if GTZ drop -55 + ;
GTZ: drop dup -97 + -if GEa drop drop -1 ;
GEa: drop dup -123 + -if GTz drop -87 + ;
GTz: drop drop -1 ;
\ ( d1 baddr1 -- d2 baddr2 ) FORTH-79: the characters from baddr1 + 1 on are
\ taken as digits in the current BASE, each accumulated into the double after
\ it is multiplied by BASE, until one is not a digit; baddr2 is its address.
\ (P)+2 holds the digit while the double is multiplied and (P)+5 the address,
\ so nothing waits on the return stack across the calls.
header CONVERT
: CONVERT
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
-if DIG drop (P)+5 a! @ ;
DIG: dup (BASE) - -if BIG
drop (P)+2 a! ! \ lo hi
(BASE) UM* drop \ lo hi*base
SWAP (BASE) UM* \ hi*base plo phi
push SWAP pop + \ plo hi'
(P)+2 a! @ 0 D+
(P)+5 a! @ jump L
BIG: drop drop (P)+5 a! @ ;
\ ( baddr -- d flag ) the counted string at baddr as a signed double in the
\ current BASE, and -1; it may begin with a minus sign. If it is empty, is
\ only a sign, or holds anything that is not a digit: 0 0 and 0. The character after the string must not be a digit
\ (WORD puts the delimiter or a zero there); if it is, that too is reported
\ as an error. (P)+3 the address of its last character, (P)+4 the sign.
: (NUMBER?)
dup C@ if ERR2
over + (P)+3 a! ! \ baddr
dup 1 + C@ -45 + if NEG
drop 0 (P)+4 a! ! jump GO
NEG: drop -1 (P)+4 a! ! 1 +
dup (P)+3 a! @ xor if ERR2 drop
GO: push 0 0 pop CONVERT \ lo hi baddr2
(P)+3 a! @ 1 + xor if FINE
drop drop drop jump ERR0
FINE: drop (P)+4 a! @ if POS drop DNEGATE -1 ;
POS: drop -1 ;
ERR2: drop drop
ERR0: 0 0 0 ;
\ ( baddr -- d ) FORTH-79. What is not a number gives 0 and sets NODE-ERROR.
header NUMBER
: NUMBER
(NUMBER?) if BAD drop ;
BAD: drop NODE-ERROR b! 2 !b ;
\ ---- comments (5.15) -------------------------------------------------------
\ PAREN skips to the closing parenthesis; BACKSLASH skips the rest of the line.
header ( immediate
: PAREN 41 WORD drop ;
header \ immediate
\ In a block a line is 64 characters: skip to the start of the next.
: BACKSLASH
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
TERM: drop SPAN a! @ >IN a! ! ;
v4/capsule/log.v4
-72
View File
@@ -1,72 +0,0 @@
\ log.v4 -- logging, as v3: a message has a level, and is printed if the
\ level is at or below LOG-LEVEL.
\
\ DECOMPOSITION.md 5.25: the level constants LOG-ERROR LOG-WARN LOG-INFO
\ LOG-TEST LOG-DEBUG (0 .. 4), LOG-LEVEL! LOG-LEVEL@, LOG-ERROR" ... LOG-DEBUG"
\ and LOG-ERROR-STR ... LOG-DEBUG-STR. Part of the compiler capsule; rests
\ on core.v4, codegen.v4 and quit.v4.
\
\ WHAT IS PRINTED is v3's line without its time of day, which a node has
\ not got: the level's colour, the level's name and a colon, the colour off,
\ the text, a new line --
\ ESC [32m INFO: ESC [0m text
\ On the mesh a message will go to the recorder's log ring (5.25); until
\ then it goes to the console.
\
\ Constants the loader supplies:
\ (LOG-LEVEL) word address of the variable: 2, LOG-INFO, at switch-on
header LOG-ERROR inline : LOG-ERROR 0 ;
header LOG-WARN inline : LOG-WARN 1 ;
header LOG-INFO inline : LOG-INFO 2 ;
header LOG-TEST inline : LOG-TEST 3 ;
header LOG-DEBUG inline : LOG-DEBUG 4 ;
header LOG-LEVEL@
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
header LOG-LEVEL!
: LOG-LEVEL!
-if POS drop 0 jump SET
POS: dup -5 + -if BIG drop jump SET
BIG: drop drop 4
SET: (LOG-LEVEL) a! ! ;
\ ( baddr u level -- ) the message, if the level is at or below LOG-LEVEL
: (LOG)
dup inv (LOG-LEVEL) a! @ + 1 + -if SHOW drop drop drop drop ; \ LOG-LEVEL - level
SHOW: drop
if P0 -1 + if P1 -1 + if P2 -1 + if P3 -1 + if P4
drop jump OUT
P0: drop $31335B1B (EMIT4) $6D (EMIT4) $4F525245 (EMIT4) $203A52 (EMIT4) $6D305B1B (EMIT4) jump OUT
P1: drop $33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P2: drop $32335B1B (EMIT4) $6D (EMIT4) $4F464E49 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P3: drop $35335B1B (EMIT4) $6D (EMIT4) $54534554 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P4: drop $34335B1B (EMIT4) $6D (EMIT4) $55424544 (EMIT4) $203A47 (EMIT4) $6D305B1B (EMIT4) jump OUT
OUT: TYPE jump CR
header LOG-ERROR-STR : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
header LOG-WARN-STR : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
header LOG-INFO-STR : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
header LOG-TEST-STR : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
header LOG-DEBUG-STR : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
\ ( level -- ) the run time of LOG-xxx" : the text is after the call, as
\ for ." ; log it at that level and go on after it.
header (LOG") compile-only
: (LOG")
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
COUNT ROT jump (LOG)
\ ( level -- ) LOG-xxx" text" logs the text -- now, if interpreting; when
\ the word it is compiled into runs, if compiling. (Q)+3 holds the level.
: (LOG-QUOTE)
(Q)+3 a! ! 34 (PARSE) drop
STATE a! @ if NOW
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT (Q)+3 a! @ jump (LOG)
header LOG-ERROR" immediate : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
header LOG-WARN" immediate : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
header LOG-INFO" immediate : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
header LOG-TEST" immediate : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
header LOG-DEBUG" immediate : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
v4/capsule/numout.v4
-153
View File
@@ -1,153 +0,0 @@
\ numout.v4 -- printing numbers: pictured output, the . words, and .S
\
\ DECOMPOSITION.md 5.8: <# # #S HOLD SIGN #> . .R U. U.R D. D.R ? SPACES
\ DECIMAL HEX OCTAL, each the definition given there and executed on the mesh
\ node by test_pictured.c, test_numout.c and test_printing.c; and .S, which
\ D-16 makes possible again. Part of the compiler capsule. Rests on core.v4
\ and forth.v4.
\
\ Constants the loader supplies:
\ HEND byte address just past the hold buffer, which is 64 bytes
\ -HFLOOR minus the lowest address HOLD may store at: -(HEND - 62)
\ HLD word address of the variable: where the picture has got to
\ (W) word address of three cells of scratch for this file:
\ (W)+0 the width a number is to be printed in
\ (W)+1 whether a blank follows it (W)+2 .S's count
macro (-ROT) SWAP push SWAP pop endmacro
\ ---- unsigned division (section 4) ----
\ One step a bit, the divisor in A. Exact for uhi < ud.
: UM/MOD ( ulo uhi ud -- urem uquot )
a! N-1 FOR
-if L0
2* over -if L1 drop 1 + jump L2
L1: drop L2: push 2* pop
jump SUB
L0:
2* over -if L3 drop 1 + jump L4
L3: drop L4: push 2* pop
dup a xor -if L5
drop -if NOSUB jump SUB
L5: drop dup inv a + inv -if L6
drop jump NOSUB
L6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop ;
\ ---- pictured output ----
header <#
: <# ( -- ) HEND HLD b! !b ;
header HOLD
: HOLD ( c -- )
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
OKC: drop HLD b! @b -HFLOOR + -if ROOM
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
ROOM: drop HLD b! @b -1 + dup !b jump C!
header SIGN
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
header #
: # ( ud1 -- ud2 )
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
(BASE) UM/MOD (-ROT) \ qlo qhi rem
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
header #S
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
header #>
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
header SPACES
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
header DECIMAL
: DECIMAL 10 BASE a! ! ;
header HEX
: HEX 16 BASE a! ! ;
header OCTAL
: OCTAL 8 BASE a! ! ;
\ ---- numbers ----
\ One picture for signed singles, one for unsigned, one for doubles. Each
\ plain word is its .R word with a width of 0 and the blank flag set, and all
\ six share one tail, which prints the blank only when the flag is set.
\ ( baddr u -- ) right-justified in the width, then the blank if wanted
: (.TAIL)
(W) b! @b -if POS drop jump OUT \ width < 0
POS: over - SPACES \ width - u spaces
OUT: TYPE (W)+1 b! @b if DONE drop jump SPACE
DONE: drop ;
: (.BODY) ( n width -- )
(W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> jump (.TAIL)
: (U.BODY) ( u width -- )
(W) b! !b 0 <# #S #> jump (.TAIL)
: (D.BODY) ( d width -- )
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
header .R
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
header .
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
header U.R
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
header U.
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
header D.R
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
header D.
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
header ?
: QUESTION a! @ jump DOT
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line. The stack is
\ left as it was. It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
header .S
: DOT-S
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
DEPTH (W)+2 b! !b
L: (W)+2 b! @b if DONE
PICK DOT
(W)+2 b! @b -1 + !b jump L
DONE: drop jump CR
\ ---- DUMP ----
\ ( baddr u -- ) u bytes from the byte address baddr, sixteen to a line: the
\ address, the bytes in hex, and the bytes as characters between bars.
\ Everything it keeps between words is in (DP): the saved BASE, the address,
\ the count and the column. ADDR-DIGITS is two for each byte of a cell.
: (DB) ( -- c ) (DP)+1 b! @b (DP)+3 b! @b + jump C@
header DUMP
: DUMP
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: (DP)+2 b! !b (DP)+1 b! !b
BASE b! @b (DP) b! !b 16 BASE b! !b
LINE: (DP)+2 b! @b if DONE drop
(DP)+1 b! @b 0 <# ADDR-DIGITS (DP)+3 b! !b
AD: # (DP)+3 b! @b -1 + dup !b if ADX drop jump AD
ADX: drop #> TYPE 58 EMIT SPACE
0 (DP)+3 b! !b
HX: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVE
drop SPACE SPACE SPACE jump HN
HAVE: drop (DB) 0 <# # # #> TYPE SPACE
HN: (DP)+3 b! @b 1 + dup !b -16 + -if HXX drop jump HX
HXX: drop SPACE 124 EMIT
0 (DP)+3 b! !b
CH: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVC jump CHX
HAVC: drop (DB)
dup -32 + -if GE drop drop 46 jump EM
GE: drop dup -127 + -if BIG drop jump EM
BIG: drop drop 46
EM: EMIT
(DP)+3 b! @b 1 + dup !b -16 + -if CHX drop jump CH
CHX: drop 124 EMIT CR
(DP)+1 b! @b 16 + !b
(DP)+2 b! @b -16 + -if MORE jump DONE
MORE: !b jump LINE
DONE: drop (DP) b! @b BASE b! !b ;
v4/capsule/qmath.v4
-247
View File
@@ -1,247 +0,0 @@
\ qmath.v4 -- Q48.16 fixed point: a signed double with sixteen bits of
\ fraction (D-8, D-10).
\
\ DECOMPOSITION.md 5.26. Each word is the definition given there and
\ executed on the mesh node by test_foundation.c and test_printing.c, here in
\ the host node's vocabulary. Rests on core.v4, forth.v4, numout.v4 and
\ words.v4.
\
\ ERRORS. Q./ by zero, and Q.SQRT and Q.LOG outside their domain, leave the
\ result D-11 and D-12 give and then raise an error (D-18): codes 11,
\ "Division by zero", and 12, "Argument out of range".
\
\ Constants the loader supplies:
\ MSB MAXHI the high cells of Q min and Q max
\ HIMASK every bit but the top sixteen
\ 2N+15 N-18 N-17 loop counts, N the cell width in bits
\ (Q/) (QE) (QR) (QL) (QT) (QP) word addresses of the words' scratch
\ cells: 5, 8, 5, 7, 6 and 4 of them
\ the logical double shift right: one +* step with S = 0, the top bit cleared
macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
: (QERR11) NODE-ERROR b! 11 !b ;
: (QERR12) NODE-ERROR b! 12 !b ;
\ ---- conversion and constants ----
header Q.FROM-INT
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
header Q.TO-INT
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
header Q.1 inline : Q.1 65536 0 ;
header Q.0 inline : Q.0 0 0 ;
header Q.SCALE inline : Q.SCALE 65536 0 ;
\ ---- the double words under other names ----
header Q.+ : Q.+ jump D+
header Q.- : Q.- jump D-
header Q.ABS : Q.ABS jump DABS
header Q.NEG : Q.NEG jump DNEGATE
header Q.= : Q.= jump D=
header Q.< : Q.< jump D<
header Q.> : Q.> 2SWAP jump D<
header Q.0= : Q.0= jump D0=
header Q.MAX : Q.MAX jump DMAX
header Q.MIN : Q.MIN jump DMIN
\ ---- multiply ----
header Q.*
: Q.* ( a b -- c )
SWAP push over over UM* drop
push push over pop
-if L1 SWAP jump L2 L1: SWAP drop 0 L2:
pop SWAP - push
push over pop UM* pop +
ROT pop dup push
over -if L3 drop dup jump L4 L3: drop 0 L4:
push UM* pop - D+
ROT pop UM*
SWAP push 0 D+ pop
push over pop SWAP Q.TO-INT push Q.TO-INT pop SWAP ;
\ ---- divide ----
: D2*C ( lo hi cin -- lo' hi' cout )
a! dup -if L1 drop 1 jump L2 L1: drop 0 L2: push
over -if L3 drop 1 jump L4 L3: drop 0 L4:
over + +
push 2* a + pop pop ;
: (UQ/) ( a0 a1 b0 b1 -- q0 q1 )
(Q/)+2 a! SWAP !+ ! (Q/) a! SWAP !+ ! 0 0 0
2N+15 FOR
push (Q/) a! @+ @ pop D2*C
push (Q/)+1 a! ! (Q/) a! ! pop D2*C
if CMP drop jump TAKE
CMP: drop (Q/)+3 b! @b
over over xor if EQH -if SAMEH
drop drop -if NT1 jump TAKE NT1: jump NOTAKE
SAMEH: drop over SWAP push inv pop + inv
-if T2 drop jump NOTAKE T2: drop jump TAKE
EQH: drop drop over (Q/)+2 b! @b
over over xor -if SAMEL
drop drop -if NT3 drop jump TAKEL NT3: drop jump NOTAKEL
SAMEL: drop push inv pop + inv
-if T4 drop jump NOTAKEL T4: drop jump TAKEL
TAKEL: drop (Q/)+2 b! @b push inv pop + inv 0 1 jump END
NOTAKEL: 0 jump END
TAKE: push (Q/)+2 b! @b over over push inv pop + inv push
over over xor -if SB drop NIP -if NB drop 1 jump BD NB: drop 0 jump BD
SB: drop push inv pop + inv -if NB2 drop 1 jump BD NB2: drop 0
BD: pop pop (Q/)+3 b! @b push inv pop + inv
push SWAP pop SWAP - 1 jump END
NOTAKE: 0
END:
NEXT
push (Q/) a! @+ @ pop D2*C drop push push drop drop pop pop ;
header Q./
: Q./ ( a b -- q )
over over OR if ZERO drop
push over pop SWAP over xor (Q/)+4 b! !b
-if L1 DNEGATE L1: push push -if L2 DNEGATE L2: pop pop
dup if CHK drop jump DIV
CHK: drop over -131072 and if CHK2 drop jump DIV
CHK2: drop push push dup pop dup push N-18 FOR 2* UNEXT
over over xor -if SAME drop drop -if NOOV jump OV
SAME: drop push inv pop + inv -if OV
NOOV: drop pop pop jump DIV
OV: drop drop drop pop pop drop drop
(Q/)+4 b! @b -if OVP drop 0 MSB ; OVP: drop -1 MAXHI ;
DIV: (UQ/) (Q/)+4 b! @b -if L3 drop DNEGATE ; L3: drop ;
ZERO: drop drop drop
over over OR if Z0 drop -if ZP drop drop 0 MSB jump (QERR11)
ZP: drop drop -1 MAXHI jump (QERR11)
Z0: drop jump (QERR11)
\ ---- e to the x ----
header Q.EXP
: Q.EXP ( q -- e )
over over OR if ONE drop
dup (QE)+6 b! !b -if L1 DNEGATE L1:
over over -1048576 -1 D+ push drop pop -if BIG drop
over over (QE)+2 a! SWAP !+ ! over over (QE) a! SWAP !+ !
65536 0 D+ (QE)+4 a! SWAP !+ !
2 (QE)+7 b! !b
LOOP:
(QE)+2 a! @+ @ (QE) a! @+ @ Q.*
(QE)+7 b! @b Q.FROM-INT Q./
over over (QE)+2 a! SWAP !+ !
(QE)+4 a! @+ @ D+ (QE)+4 a! SWAP !+ !
(QE)+2 a! @+ @ if HI0 drop drop jump CONT
HI0: drop -if SM drop jump CONT
SM: -50 + -if CONT1 drop jump DONE
CONT1: drop
CONT: (QE)+7 b! @b 1 + dup !b -11 + -if DONE1 drop jump LOOP
DONE1: drop
DONE: (QE)+4 a! @+ @ (QE)+6 b! @b -if POS drop 65536 0 2SWAP jump Q./
POS: drop ;
BIG: drop drop drop (QE)+6 b! @b -if BIGP drop 0 0 ; BIGP: drop -1 MAXHI ;
ONE: drop drop drop 65536 0 ;
\ ---- square root ----
header Q.SQRT
: Q.SQRT ( q -- r )
dup -if POS drop drop drop 0 0 jump (QERR12)
POS: drop over over OR if ZERO drop
over 65536 xor over OR if ONE drop
over over (QR) a! SWAP !+ ! (UD2/) 16384 0 D+ (QR)+2 a! SWAP !+ !
8 (QR)+4 b! !b
LOOP: (QR) a! @+ @ (QR)+2 a! @+ @ Q./ (QR)+2 a! @+ @ D+ (UD2/)
over over (QR)+2 a! @+ @ DNEGATE D+ -if L1 DNEGATE L1:
if HI0 drop drop jump NXT
HI0: drop -if SM drop jump NXT
SM: -10 + -if NXT1 drop drop drop (QR)+2 a! @+ @ ;
NXT1: drop
NXT: (QR)+2 a! SWAP !+ !
(QR)+4 b! @b -1 + dup !b if DONE drop jump LOOP
DONE: drop (QR)+2 a! @+ @ ;
ZERO: drop ;
ONE: drop ;
\ ---- natural logarithm ----
header Q.LOG
: Q.LOG ( x -- ln x )
dup -if POS drop jump ERR
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
DOWN: dup if CHKLO drop jump SHR
CHKLO: drop over -131072 and if DOWNDONE drop
SHR: (UD2/) (QL)+2 b! @b 1 + !b jump DOWN
DOWNDONE: drop drop
UP: dup -65536 and if UPSHIFT drop jump NORM
UPSHIFT: drop 2* (QL)+2 b! @b -1 + !b jump UP
NORM: dup (QL) b! !b -65536 + (QL)+1 b! !b 6 (QL)+3 b! !b
NEWTON: (QL)+1 b! @b dup (QL)+4 b! !b 65536 + (QL)+5 b! !b
131072 (QL)+6 b! !b
EXPL: (QL)+4 b! @b 0 (QL)+1 b! @b 0 Q.* drop
0 (QL)+6 b! @b 0 Q./ drop dup (QL)+4 b! !b
dup (QL)+5 b! @b + !b
-50 + -if EXPC drop jump EXPD
EXPC: drop (QL)+6 b! @b 65536 + dup !b -720896 + -if EXPD2 drop jump EXPL
EXPD2: drop
EXPD: (QL) b! @b (QL)+5 b! @b push inv pop + inv
dup (QL)+4 b! !b
if DZ -if DPOS
inv 1 + 0 (QL)+5 b! @b 0 Q./ drop
(QL)+1 b! @b SWAP push inv pop + inv -if KEEP drop 0 KEEP: (QL)+1 b! !b
jump TEST
DPOS: 0 (QL)+5 b! @b 0 Q./ drop (QL)+1 b! @b + !b jump TEST
DZ: drop
TEST: (QL)+4 b! @b -if AP inv 1 + AP: -100 + -if CONT drop jump FIN
CONT: drop (QL)+3 b! @b -1 + dup !b if FIN0 drop jump NEWTON
FIN0: drop
FIN: (QL)+1 b! @b (QL)+2 b! @b
-if KP inv 1 + 45426 UM* drop inv 1 + jump KS KP: 45426 UM* drop
KS: + dup -if SP drop -1 ; SP: drop 0 ;
ZERO: drop
ERR: drop drop 0 0 jump (QERR12)
\ ---- sine and cosine ----
: (Q.REDUCE) ( x -- r )
dup (QT) b! !b -if L1 DNEGATE L1:
0 411774 UM/MOD drop 411774 UM/MOD drop
(QT) b! @b -if P1 drop inv 1 + jump J1 P1: drop J1:
dup -205888 + -if BIG drop
dup 205887 + -if OK drop 411774 + ;
OK: drop ;
BIG: drop -411774 + ;
\ The Taylor loop both use; each sets (QT) up and jumps here.
: (TRIG)
T: (QT)+2 b! @b 0 (QT)+1 b! @b 0 Q.* drop
0 (QT)+4 b! @b dup -1 + UM* drop 65536 UM* drop 0 Q./ drop
dup (QT)+2 b! !b
(QT)+5 b! @b if ADDT drop inv 1 + jump ACC ADDT: drop
ACC: (QT)+3 b! @b + !b (QT)+5 b! @b inv !b
(QT)+2 b! @b -10 + -if CONT drop jump END
CONT: drop (QT)+4 b! @b 2 + dup !b -12 + -if END2 drop jump T
END2: drop
END: (QT)+3 b! @b (QT) b! @b -if PR drop inv 1 + jump SD PR: drop
SD: dup -if SP drop -1 ; SP: drop 0 ;
header Q.SIN
: Q.SIN ( x -- sin x )
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
dup (QT)+2 b! !b dup (QT)+3 b! !b
0 over 0 Q.* drop (QT)+1 b! !b
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
header Q.COS
: Q.COS ( x -- cos x )
(Q.REDUCE) -if A1 inv 1 + A1:
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
65536 (QT)+2 b! !b 65536 (QT)+3 b! !b
2 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
\ ---- printing ----
\ The integer part, a point, five digits, a blank; always in decimal.
header Q.PRINT
: Q.PRINT ( q -- )
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
BASE b! @b (QP) b! !b 10 BASE b! !b
65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT
0 <# # # # # # drop drop 46 HOLD
(QP)+1 b! @b (QP)+2 b! @b dup push
push a! 0 pop 15 FOR +* UNEXT drop drop a
pop 15 FOR 2/ UNEXT HIMASK and
#S (QP)+3 b! @b SIGN #>
(QP) b! @b BASE b! !b
TYPE jump SPACE
v4/capsule/quit.v4
-585
View File
@@ -1,585 +0,0 @@
\ quit.v4 -- a line of text, interpreted; how it ends; and the words that
\ print text written in the source.
\
\ DECOMPOSITION.md 5.15 and 5.10: QUIT ABORT ABORT" (ABORT") ." (."). Part of
\ the compiler capsule. Rests on all the files before it.
\
\ A NODE IS SENT TEXT (docs/v4.0.0/MESH.md section 6). It does not read its
\ own command line and prints no prompt. A node with nothing to do sleeps;
\ a message comes to one of its wires; if that is text for this node it is
\ taken and interpreted; what it printed goes back as a message, and then
\ a message saying how the text ended:
\ 1 it completed a console says " ok"
\ 2 it ended in an error the message is already printed; " ERROR"
\ 0 QUIT nothing is said
\ What a console then shows is v3's:
\ ok> 65 EMIT the console's prompt, and the line
\ A ok what the line printed, then " ok"
\ ok> NOSUCH
\ UNKNOWN WORD: 'NOSUCH'
\ ERROR
\ ok> -1 @
\ Address out of range an address fault (D-14), from any depth
\ ERROR
\ KEY, EXPECT and QUERY are FORTH-79 words that read characters, as before;
\ they are not how text reaches the node. They still read the console's
\ registers, CONSOLE-RX and CONSOLE-STATUS, and not a message.
\
\ THE STACKS are guarded (D-16): each counts what it holds, and a push onto
\ a full one or a pop from an empty one is a fault. So QUIT and ABORT, which
\ never return to whatever ran them, must empty the return stack, and ABORT
\ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that.
\
\ Constants the loader supplies:
\ (LINE-STATUS) word address of the variable: how the last text ended
\ (MSG) (REPLY) (ME) (OUT) (OUT^) see core.v4, "what a node prints"
\ (PORT) word address of the node's port 0
\ (Q) word address of four cells of scratch, which system.v4 and
\ blocks.v4 use too
\ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers
\ ( -- ) empty the return stack. `a` is only something to store: any
\ store to the register empties the stack, and `a` needs nothing to be on
\ the data stack. One cell of the data stack is used for a moment.
macro R-CLEAR RSTACK-DEPTH b! a !b endmacro
\ ( -- ) stop compiling; forget the word being built and any open control
\ structures. A definition that was under way stays hidden.
: (RESET) 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! ;
\ ( s -- ) the text is done with. What it printed is sent, then a message
\ saying how it ended -- 0 QUIT, 1 completed, 2 an error -- and the node waits
\ for the next. (DONE) is entered with the same number and, for an error,
\ stops compiling first; it is always jumped to, never called, by
\ something that has emptied the return stack (or by a fault, which empties
\ it). (LINE-STATUS) keeps how the last text ended, and is the one word of
\ the message's text.
\ THE ANSWER IS NOT REFUSED HERE: the text was not begun until the wire it
\ goes by had room for it, and that room has been kept, (KEEP), which is
\ let go only now (MESH.md 7d.4). If no one is on that port any more it
\ is counted in (LOST).
\ FOUR CELLS OF THE DATA STACK are tried first: what a node does between
\ texts -- this, passing messages on, taking the next text in -- and the
\ interpreter need that many, so text may leave 28 values on a stack of 32
\ and no more. Text that leaves more ends here, "Stack overflow", with
\ the stack emptied, and not later, in the middle of the text after it.
: (FINISH) ( s -- )
1 (QUIET) a! ! \ from here nothing is this text's doing
(LINE-STATUS) b! !b
0 0 0 0 drop drop drop drop
(FLUSH-OUT)
-1 (KEEP) a! !
(MSG)+1 a! @ 3 (HDR) 4 (OUT-HDR)+6 a! ! \ to whoever sent the text: type 3, four characters
(LINE-STATUS) (DONE-PORT) a! @ (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! jump (IDLE)
SENT: drop jump (IDLE)
: (DONE)
if GO -1 + if OK
drop (RESET) 2 jump (FINISH)
OK: drop 1 jump (FINISH)
GO: drop 0 jump (FINISH)
\ ( -- flag ) A GONE has been taken: its seven words are in (IN), the
\ node it is about in (ONE), and (S-WIRE) is the wire it came by. It is
\ believed only if it came by the port that leads to this node's centre
\ and says it is from the centre (MESH.md 7b.4): the way to the node is
\ then forgotten, and the flag is -1. Otherwise nothing is done, and 0.
\ (As first built only what it said it was from was looked at, and one
\ that came by another port was believed.)
: (GONE?)
(CENTRE) if NOT (IN)+1 a! @ xor if FROM drop 0 ;
NOT: ;
FROM: drop (ROUTE-DEFAULT) a! @ (PORT) - (S-WIRE) a! @ xor if YES drop 0 ;
YES: drop (ONE) a! @ NO-ROUTE -1 ;
\ ( -- ) WAITING (MESH.md 7d.4). A node with nothing to do passes on
\ what has come for other nodes, (SERVE), and then goes through what has
\ come for itself, the lowest port first and each wire from its front:
\ text is taken, into TIB, and done: (LINE), and then (FINISH) says
\ how it ended. But not unless the wire its answer goes by --
\ the way to whoever sent it; with none known, or no one on
\ that port, the wire it came on -- has room for the answer,
\ 8 cells. If it has not, the text stays on its wire and the
\ node looks further: there may be several such, on wires
\ whose answers go different ways, and each is begun when
\ its own has the room. That room is kept from then until
\ the answer has gone.
\ TEXTS WHOSE ANSWERS GO THE SAME WAY ARE BEGUN IN THE ORDER
\ THEY CAME. Once one has been left for want of room, every
\ text behind it on this pass whose answer goes by that port
\ is left too, though the room has come since: (D-MASK) has
\ a bit for each such port. (As first built only the room
\ was asked, each time; room that came between the look at
\ one text and at the next began the second first. Found
\ by the final review of step 6e.)
\ a NACK is taken and counted in (REFUSED)
\ a GONE is taken, and believed if this node's centre sent it
\ an answer no one is waiting for is dropped: a SEND that is not waited
\ on is ordinary use, and its answer is not a loss.
\ any other is dropped, and counted in (LOST): what a node printed
\ that came here, a type there is none of, or a NACK or GONE
\ that is not as long as one is. (LOST) counts what should
\ have been delivered or acted on and was not.
\ A TAKE THAT DOES NOT TAKE -- the wire was cut after the message was
\ looked at -- leaves nothing to act on: no text is done and nothing is
\ believed for it, (UNTAKEN). The same for a drop that does not drop.
\ With nothing to begin it sleeps, executing nothing, until a message
\ comes; or, if text is waiting for room for its answer, or (SERVE) left a
\ message for want of room, until there is room on any wire that leads
\ from it or a message comes. Then it does all of this again.
\ It has fetched which wires have a message before it looks at any, and
\ sleeps after: a message that comes while it looks wakes it at once, and
\ one it left on a wire does not keep it awake (MESH.md 7d.3).
\ (KEEP) and (AWAIT-FROM) are put back here every time: whatever was
\ abandoned on the way, a node with nothing to do keeps no room and waits
\ for no one.
: (IDLE)
L: 1 (QUIET) a! ! \ nothing here is any text's doing: see (RAISED)
-1 (KEEP) a! ! 0 (AWAIT-FROM) a! ! -1 (DEFER) a! ! 0 (D-MASK) a! !
(SERVE) (MINE0)
M: (MINE) if REST
drop (IN)+2 a! @ -1 + if TEXT -3 + if NACK -1 + if GONE
OTHER: drop 4 (DO) if LETGO drop (SKIP) jump M \ it was not there to drop: nothing is counted
LETGO: drop (IN)+2 a! @ -3 + if ANSWER \ let go. An answer no one waits for is ordinary:
drop (LOST) a! @ 1 + ! jump M \ anything else should not have come here, and is counted
ANSWER: drop jump M
NACK: drop (IN)+6 a! @ -4 + if N1 jump OTHER
N1: drop (TAKE1) if N2 drop (UNTAKEN) jump M \ not taken: nothing is done for it
N2: drop (REFUSED) a! @ 1 + ! jump M \ a message of this node's was refused: counted
GONE: drop (IN)+6 a! @ -4 + if G1 jump OTHER
G1: drop (TAKE1) if G2 drop (UNTAKEN) jump M
G2: drop (GONE?) drop jump M
TEXT: drop
(IN)+1 a! @ (WAY) -if T1 drop (S-WIRE) a! @ \ the way back; with none known, the wire it came on
T1: (DONE-PORT) a! !
(DONE-PORT) a! @ (WBIT) (D-MASK) a! @ and if FREE1 jump FULL \ text ahead of it waits for room on that wire
FREE1: drop
8 (DONE-PORT) a! @ (ROOM?) if START -1 + if FULL
drop (S-WIRE) a! @ (DONE-PORT) a! ! \ no one is on that port: back by the wire it came on,
(S-WIRE) a! @ (WBIT) (D-MASK) a! @ and if FREE2 jump FULL
FREE2: drop
8 (S-WIRE) a! @ (ROOM?) -1 + if FULL jump START \ if that has the room -- or has no one on it either
FULL: drop (DONE-PORT) a! @ (WBIT) dup inv (D-MASK) a! @ and + !
(DEFER) a! @ -if LATER drop (DONE-PORT) a! @ (DEFER) a! ! (SKIP) jump M
LATER: drop (SKIP) jump M
REST: drop
(DEFER) a! @ -if ROOM drop (SLEEP) jump L
ROOM: (WIRE!) 8 (WIRE-A) b! !b 9 (DO) drop jump L
START: drop
(S-WIRE) a! @ dup (REPLY) a! ! (WIRE!)
(MSG) (WIRE-A) b! !b TIB 2/ 2/ (WIRE-B) b! !b 2 (DO) \ its seven words, and its text
if TAKEN drop (UNTAKEN) jump M \ not taken: the wire was cut since it was looked at
TAKEN: drop
0 (MSG)+6 a! @ TIB + C! \ a zero after the text
(MSG)+6 a! @ SPAN a! !
(DONE-PORT) a! @ (KEEP) a! ! \ the room for its answer is kept from here
(CONSOLE) a! @ if P0 jump P1 \ where what it prints goes: the console,
P0: drop (MSG)+1 a! @ \ or whoever sent it;
P1: dup (PRINT-TO) a! !
(WAY) -if Q1 drop (REPLY) a! @ \ by the way there, or the wire the text came on
Q1: (PRINT-PORT) a! !
jump (LINE)
\ ( -- ) THE TEXT, INTERPRETED. It is in TIB with a zero after it and its
\ length in SPAN, and the return stack is empty. It is interpreted with one
\ return entry under it, this word's call of INTERPRET; whatever is on the
\ data stack stays there.
: (LINE)
0 (QUIET) a! ! \ an error from here on is this text's
0 BLK a! ! \ the terminal, whatever was being loaded
TIB (SRC) a! ! 0 >IN a! !
0 NODE-ERROR b! !b
INTERPRET
NODE-ERROR b! @b if GOOD
drop 2 jump (DONE)
GOOD: drop 1 jump (DONE)
\ ---- the node among others (MESH.md sections 6 and 7) ---------------------------
\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel.
\ ( node port -- ) the port, by its number, leads toward that node
header ROUTE
: ROUTE
(ROUTE#) a! @ -16 + if FULL drop
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
push !+ pop !+
(ROUTE#) a! @ 1 + ! ;
FULL: drop drop drop NODE-ERROR b! 12 !b ;
\ ( node port -- ) the node on the other end of the port, by its number;
\ 0: none, or a device. Whoever wires the node tells it, and tells it again
\ when the wiring changes. It is how a node knows who its centre is, the
\ one node whose GONE it believes: (CENTRE).
header NEIGHBOUR
: NEIGHBOUR
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( port -- ) the port, by its number, leads toward every node not told of
header DEFAULT-ROUTE
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
\ ( node -- ) forget the way to that node, if one is known: what is for it
\ then goes by the way for every node not told of, if there is one. The
\ last way in the table takes its place.
header NO-ROUTE
: NO-ROUTE
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
drop ;
NONE: drop drop ;
HIT: drop drop pop drop
a -1 + push \ where its entry is
(ROUTE#) a! @ -1 + dup ! \ one way fewer
2* (ROUTES) + a! @+ @ \ the last entry: node port
pop a! SWAP !+ ! ;
\ ( about node type -- ) send the node a message of one word, `about`:
\ a GONE is type 5 (MESH.md 7b). With no way to the node it is error 12.
\ It goes or is refused at once; refused -- no one on the port, or no room
\ on the wire -- it is counted in (LOST) (MESH.md 7d.4).
: (SEND1)
push dup (WAY) -if GO
drop drop drop pop drop NODE-ERROR b! 12 !b ;
GO: (W-PORT) a! ! SWAP (ONE) a! !
pop (HDR) 4 (OUT-HDR)+6 a! !
(ONE) (W-PORT) a! @ (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! ;
SENT: drop ;
\ ( n node -- ) tell the node that node n is gone. It acts on that only
\ if this node is its centre: it forgets the way to n, and if it is waiting
\ for n's answer the wait ends.
header GONE
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
header NO-ROUTES
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
\ ( baddr u node port -- ) send the node u characters of text to
\ interpret, by the port given, by its number. The text is made ready in
\ (SEND-TEXT), four characters to a word, the message is put on the wire
\ whole, and it is on its way when this returns. IT GOES OR IS REFUSED AT
\ ONCE (MESH.md 7d.1, ruling 3): with no room on the wire it is counted in
\ (REFUSED), as a refusal that came back would be, and is error 19, Message
\ refused; with no one on the port, error 18. Nothing is on a
\ wire until the put, the last thing done. More characters than a message
\ carries, or fewer than none, is error 12. What lies after the text in
\ this node's memory does not go with it: the last word is made zero past
\ the last character.
: (SEND-ON)
push 1 (HDR)
-if POS
BAD: drop drop pop drop NODE-ERROR b! 12 !b ;
LONG: drop jump BAD
POS: dup -1025 + -if LONG
drop dup (OUT-HDR)+6 a! !
(SEND-TEXT) (SEND^) a! !
3 + 2/ 2/ if NONE -1 +
FOR dup C@ over 1 + C@ 8* + over 2 + C@ 8* 8* + over 3 + C@ 8* 8* 8* +
(SEND^) b! @b a! !+ a !b 4 + NEXT
drop
(OUT-HDR)+6 a! @ 3 and if PUT \ the last word: nothing in it past the last character
(SEND^) b! @b -1 + a!
-1 + if M1 -1 + if M2
drop @ 16777215 and ! jump PUT0
M2: drop @ 65535 and ! jump PUT0
M1: drop @ 255 and ! jump PUT0
NONE: drop
PUT: drop
PUT0: (SEND-TEXT) pop (PUT-ON)
if SENT -1 + if FULL drop NODE-ERROR b! 18 !b ;
FULL: drop (REFUSED) a! @ 1 + ! NODE-ERROR b! 19 !b ;
SENT: drop ;
\ ( baddr u node -- ) send the node u characters of text to interpret,
\ by the way this node knows to it. What it prints there goes to that
\ node's console. With no way to the node it is error 12.
header SEND
: SEND
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
GO: jump (SEND-ON)
\ ( baddr u node port -- ) the same by a port this node names, by its
\ number, whatever ways it knows: for a neighbour that has no number of
\ its own yet, to which text is sent as to node 0.
header SEND-ON
: SEND-ON
dup -if POS jump BAD
POS: -PORTS + -if BAD drop jump (SEND-ON)
BAD: drop drop drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- n ) the number of this node's centre: the node on the port that
\ leads to everything it has no other way to. 0: it has none, or has not
\ been told who is there (NEIGHBOUR).
: (CENTRE)
(ROUTE-DEFAULT) a! @ if NONE (PORT) - (NEAR) + a! @ ;
NONE: ;
\ ( -- n ) the number of this node's console: the one it was told of, or
\ with none told of, whoever sent the text it is doing
: (A-CONSOLE)
(CONSOLE) a! @ if C0 ;
C0: drop (MSG)+1 a! @ ;
\ ( what -- how | ) the wait is over: 1 the answer has come, and its
\ word, in (ONE), is left; 2 refused, error 19; 3 the node is gone, error
\ 20; 4 a line from the console, error 21
: (A-END)
0 (AWAIT-FROM) a! !
-1 + if ANS -1 + if REF -1 + if LEFT drop NODE-ERROR b! 21 !b ;
ANS: drop (ONE) a! @ ;
REF: drop NODE-ERROR b! 19 !b ;
LEFT: drop NODE-ERROR b! 20 !b ;
\ ( node -- how ) WAIT FOR THE NODE'S WORD OF HOW TEXT ENDED: 0 QUIT,
\ 1 completed, 2 an error. (AWAIT-FROM) holds the node while this node
\ waits, and 0 otherwise. It sleeps, executing nothing, until a message
\ comes; then it passes on what is for other nodes, (SERVE), and goes
\ through what is for itself (MESH.md 7d.4):
\ the answer -- a message of type 3 from that node -- is taken, and the
\ wait is over;
\ a NACK is taken: about that node, the wait ends in error 19, Message
\ refused; about another it is counted, as at any time;
\ a GONE is taken: believed (its centre sent it: (GONE?)) and about that
\ node, the wait ends in error 20, Node gone;
\ text from its console ends the wait in error 21, Interrupted (7b.6).
\ The text is not taken: it stays on its wire and is done when this
\ text has been finished with. It is the one way to end a wait on
\ a node that is alive and never answers, short of Hera's killing
\ that node;
\ anything else stays on its wire, in its order, for when this node has
\ nothing to do.
\ WHAT HAS COME ALREADY is on the wires and is found the first time
\ through: the node looks before it sleeps. A message it left on a wire
\ does not keep it awake.
\ The stack what it does needs is tried first, (ROOM), core.v4: text that
\ has left too little ends "Stack overflow" with nothing taken off a wire.
header AWAIT
: AWAIT
(ONE) a! ! (ROOM) \ if this faults, no one is waited for:
(ONE) a! @ (AWAIT-FROM) a! ! 0 (A-SELF) a! ! \ (AWAIT-FROM) is set only when the stack has been tried
L: (SERVE)
(A-SELF) a! @ if SCAN drop 2 jump (A-END) \ this node's own message for that node came back to it
SCAN: drop (MINE0)
M: (MINE) if SLEEP
drop (IN)+2 a! @ -1 + if TEXT -2 + if ANSWER -1 + if NACK -1 + if GONE
KEEP: drop (SKIP) jump M
TEXT: drop (A-CONSOLE) (IN)+1 a! @ xor if BREAK jump KEEP \ text: from the console?
BREAK: drop 4 jump (A-END)
ANSWER: drop (IN)+1 a! @ (AWAIT-FROM) a! @ xor if A1 jump KEEP
A1: drop (IN)+6 a! @ -4 + if A2 jump KEEP
A2: drop (TAKE1) if A3 drop (UNTAKEN) jump M \ not taken: nothing is done for it
A3: drop 1 jump (A-END)
NACK: drop (IN)+6 a! @ -4 + if N1 jump KEEP
N1: drop (TAKE1) if N0 drop (UNTAKEN) jump M
N0: drop (ONE) a! @ (AWAIT-FROM) a! @ xor if N2 \ about the node waited for?
drop (REFUSED) a! @ 1 + ! jump M \ another: counted
N2: drop 2 jump (A-END)
GONE: drop (IN)+6 a! @ -4 + if G1 jump KEEP
G1: drop (TAKE1) if G0 drop (UNTAKEN) jump M
G0: drop (GONE?) if M0 \ only its centre is believed
drop (ONE) a! @ (AWAIT-FROM) a! @ xor if G2 drop jump M
G2: drop 3 jump (A-END)
M0: drop jump M
SLEEP: drop (SLEEP) jump L
\ ( w port -- ) write a cell to the port, by its number. It waits until
\ the neighbour has taken it. This is how a node is sent a capsule of F18
\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a
\ message, to a node that is executing from its ports.
header PORT!
: PORT!
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- ) WHAT IS IN THE DICTIONARY NOW IS THE SYSTEM: COLD comes back to
\ it and FORGET will not go below it. Whoever has loaded a node's capsules
\ has it do this (system.v4, (BOOT) and FENCE).
header (SEAL)
: (SEAL)
DP a! @ (BOOT) a! !
(LATEST) a! @ (BOOT)+1 a! !
DP a! @ 3 + 2/ 2/ FENCE a! ! ;
\ FORTH-79: clear the return stack, set execution mode, return control to
\ the terminal; no message is given. The data stack is left as it is.
\ NODE-ERROR, by name: how a definition written in FORTH raises an error.
\ A store of a code that is not zero is the trap of D-18 -- the word goes no
\ further, the message for the code is printed (-1: the word has printed
\ its own) and the line ends with ERROR. The codes are listed in core.v4.
header NODE-ERROR inline : NODE-ERROR' NODE-ERROR ;
header (ME) inline : (ME)' (ME) ;
header (CONSOLE) inline : (CONSOLE)' (CONSOLE) ;
header (LOST) inline : (LOST)' (LOST) ;
header (REFUSED) inline : (REFUSED)' (REFUSED) ;
header (WORD-DEFINED) inline : (WORD-DEFINED)' (WORD-DEFINED) ;
header (WORD-FORGOTTEN) inline : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
header QUIT
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
\ FORTH-79: clear the data and return stacks, set execution mode, return
\ control to the terminal. As v3, the line it stops ends with " ok".
\ Both are emptied before anything is called: ABORT may be run with the
\ return stack full.
header ABORT
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
\ ---- faults (D-14, D-16) -------------------------------------------------------
\ Where the node goes when a programme uses an address outside its memory,
\ pushes onto a full stack or pops an empty one. The opcode that faulted did
\ nothing, and both stacks have been emptied. Each handler says what happened;
\ whatever was running is abandoned, as by ABORT, and the line ends with
\ ERROR.
: (FAULT) \ "Address out of range"
$72646441 (EMIT4) $20737365 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR
2 jump (DONE)
: (D-OVER) \ "Stack overflow"
$63617453 (EMIT4) $766F206B (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
: (D-UNDER) \ "Stack underflow"
$63617453 (EMIT4) $6E75206B (EMIT4) $66726564 (EMIT4) $776F6C (EMIT4) CR
2 jump (DONE)
: (R-OVER) \ "Return stack overflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $65766F20 (EMIT4) $6F6C6672 (EMIT4) $77 (EMIT4) CR
2 jump (DONE)
: (R-UNDER) \ "Return stack underflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $646E7520 (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
\ A word has stored an error code in NODE-ERROR (D-18; the codes are listed
\ in core.v4). Print its message -- a negative code means the word printed
\ its own -- and end the line with ERROR. The return stack has been
\ emptied; the data stack is as the word left it.
\ (QUIET) is 1 while the node is doing something that is no text's doing:
\ passing a message on, or sending what a text printed and word of how it
\ ended. An error then has nobody to be told to, and telling it would
\ begin another message for a text that is over. Nothing the nucleus does
\ there raises one as it stands -- with no one on a port it counts what it
\ could not send, and goes on -- so this is a guard: if one is raised, what
\ was being sent is let go and counted, and the node goes back to waiting.
: (RAISED)
(QUIET) a! @ if SPEAK
drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! jump (IDLE)
SPEAK: drop
NODE-ERROR b! @b
-if POS drop 2 jump (DONE)
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9
-1 + if M10 -1 + if M11 -1 + if M12 -1 + if M13 -1 + if M14
-1 + if M15 -1 + if M16 -1 + if M17 -1 + if M18
-1 + if M19 -1 + if M20 -1 + if M21
drop 2 jump (DONE)
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (DONE)
M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (DONE)
M3: drop $626D754E (EMIT4) $74207265 (EMIT4) $6C206F6F (EMIT4) $676E6F (EMIT4) CR 2 jump (DONE)
M4: drop $20746F4E (EMIT4) $68632061 (EMIT4) $63617261 (EMIT4) $726574 (EMIT4) CR 2 jump (DONE)
M5: drop $74636944 (EMIT4) $616E6F69 (EMIT4) $66207972 (EMIT4) $6C6C75 (EMIT4) CR 2 jump (DONE)
M6: drop $656D614E (EMIT4) $73696D20 (EMIT4) $676E6973 (EMIT4) CR 2 jump (DONE)
M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (DONE)
M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (DONE)
M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (DONE)
M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M11: drop $69766944 (EMIT4) $6E6F6973 (EMIT4) $20796220 (EMIT4) $6F72657A (EMIT4) CR 2 jump (DONE)
M12: drop $75677241 (EMIT4) $746E656D (EMIT4) $74756F20 (EMIT4) $20666F20 (EMIT4) $676E6172 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M13: drop $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR 2 jump (DONE)
M14: drop $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR 2 jump (DONE)
M15: drop $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR 2 jump (DONE)
M16: drop $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M17: drop $726F7453 (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M18: drop (OUT) (OUT^) a! ! \ what was printed and not sent cannot be sent: it is let go
$6F206F4E (EMIT4) $6F20656E (EMIT4) $6874206E (EMIT4) $70207461 (EMIT4) $74726F (EMIT4) CR 2 jump (DONE)
M19: drop $7373654D (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M20: drop $65646F4E (EMIT4) $6E6F6720 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M21: drop $65746E49 (EMIT4) $70757272 (EMIT4) $646574 (EMIT4) CR 2 jump (DONE)
\ The table the loader gives the node: six words, one for each kind of
\ fault in the node's order, each a jump. A jump fills its word, so they
\ are one after another.
: (FAULTS)
jump (FAULT) jump (D-OVER) jump (D-UNDER) jump (R-OVER) jump (R-UNDER) jump (RAISED)
\ ---- text in the source ---------------------------------------------------------
\ The three run-time words have names, as v3's have, so that SEE can tell a
\ string in a definition from code; they cannot be used from the prompt.
\ ." and ABORT" take the text up to the next " , which may be none at all
\ (input.v4's (PARSE)); with no closing " it is the rest of the line. Inside a definition they lay
\ down a call to their run-time word and, after it, the text as a counted
\ string: the count byte and the characters, four to a cell, the last cell
\ filled with zeros. The run-time word finds the string by the return
\ address the call left, and returns to the cell after the string.
\ ( -- ) lay the counted string in WBUF into the dictionary, as above.
\ (Q)+0 how many bytes are still to go, (Q)+1 which is next.
: (STRING,)
(FLUSH)
WBUF C@ 1 + (Q) a! ! 0 (Q)+1 a! !
L: (Q) a! @ if DONE -1 + !
(Q)+1 a! @ dup 1 + ! WBUF + C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop ;
\ The run time of ." : print the string after the call, go on after it.
\ It takes the return address off before it calls anything and keeps the
\ count there instead, so a word that prints text goes no deeper than one
\ that calls any other word.
header (.") compile-only
: (.")
pop 4* dup C@ \ baddr n
L: if DONE
push 1 + dup C@ EMIT pop -1 + jump L
DONE: drop 4/ 1 + push ; \ the cell after the last character
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
\ it is compiled into runs, if compiling.
header ." immediate
: DOT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(.") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT jump TYPE
\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the
\ string after the call, start a new line and ABORT; otherwise go on after
\ the string.
header (ABORT") compile-only
: (ABORT")
if NO
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
NO: drop pop 4* dup C@ + 4/ 1 + push ;
\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if
\ the flag is not zero, print the text and ABORT.
header ABORT" immediate
: ABORT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(ABORT") (CALL,) jump (STRING,)
NOW: drop if NO
drop WBUF COUNT TYPE CR jump ABORT
NO: drop ;
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
header (S") compile-only
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
push 1 + pop ; \ baddr+1 n
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
header S" immediate
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(S") (CALL,) jump (STRING,)
NOW: drop WBUF+1 PAD WBUF C@ CMOVE PAD WBUF jump C@
v4/capsule/system.v4
-170
View File
@@ -1,170 +0,0 @@
\ system.v4 -- words about the dictionary as a whole: WORDS, FORGET, FENCE.
\
\ DECOMPOSITION.md 5.13 and 5.15. Part of the compiler capsule; rests on
\ dict.v4, quit.v4 and forth.v4.
\
\ Constants the loader supplies:
\ FENCE word address of the variable: FORGET will not remove an entry
\ that starts below the address it holds
\ VOC-LINK word address of the variable: the newest vocabulary, or 0
\ (BOOT) word address of two cells: DP and (LATEST) as the loader left them
header FENCE inline : FENCE' FENCE ;
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
\ A vocabulary is two cells: its head -- the xt of its newest entry, or 0 --
\ and the address of the vocabulary defined before it, or 0. VOC-LINK holds
\ the newest one's address. FORTH's head is (LATEST) and it is in no chain.
header CONTEXT inline : CONTEXT' CONTEXT ;
header CURRENT inline : CURRENT' CURRENT ;
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
header FORTH immediate
: FORTH (LATEST) CONTEXT a! ! ;
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
header DEFINITIONS
: DEFINITIONS CONTEXT a! @ CURRENT a! ! ;
\ VOCABULARY xxx FORTH-79: xxx is a new, empty list of words; executing
\ xxx makes it the CONTEXT vocabulary. When a search of it finds nothing,
\ FORTH is searched.
: (DOVOC) pop CONTEXT a! ! ;
header VOCABULARY
: VOCABULARY
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
0 , VOC-LINK a! @ , HERE -2 + VOC-LINK a! ! ;
NONE: drop ;
\ ( cell -- ) print the name of the vocabulary whose head cell this is
: (.VOC)
dup (LATEST) xor if F drop -1 + -2 + a! @ 4* COUNT 31 and jump TYPE
F: drop drop $54524F46 (EMIT4) $48 (EMIT4) ;
\ ( -- ) as v3's, but true: where names are looked for, and where new ones go
header ORDER
: ORDER
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
CONTEXT a! @ dup (.VOC) SPACE
(LATEST) xor if ONLY drop (LATEST) (.VOC) jump TWO
ONLY: drop
TWO: CR
$72727543 (EMIT4) $3A746E65 (EMIT4) $20 (EMIT4)
CURRENT a! @ (.VOC) jump CR
\ ( -- ) the names in the CONTEXT vocabulary, the newest first, a blank after
\ each, a new line whenever one has passed column 64. Hidden entries -- a
\ definition under way -- are not shown. (Q)+0 is the column.
header WORDS
: WORDS
0 (Q) a! !
CONTEXT a! @ a! @
L: if DONE
dup -3 + a! @ 2 and if SHOW drop jump NXT
SHOW: drop
dup -2 + a! @ 4* COUNT 31 and \ xt baddr u
dup (Q) a! @ + 1 + !
TYPE SPACE
(Q) a! @ -64 + -if WRAP drop jump NXT
WRAP: drop CR 0 (Q) a! !
NXT: -1 + a! @ jump L
DONE: drop jump CR
header VLIST
: VLIST jump WORDS
\ ( cell -- ) take off a vocabulary's list every entry at or above the
\ address in (Q)+0. The newest are first, so it stops at the first one below.
: (PRUNE)
(Q)+1 a! !
L: (Q)+1 a! @ a! @ if DONE
dup (Q) a! @ inv + 1 + -if CUT drop drop ;
CUT: drop -1 + a! @ (Q)+1 a! @ a! ! jump L
DONE: drop ;
\ FORGET xxx FORTH-79: remove xxx and every word defined after it, in
\ whatever vocabulary; the space they took is free again. A vocabulary that
\ goes is no longer CONTEXT or CURRENT: FORTH is. A word that is not there
\ is an error, and so is one below FENCE, which is where the capsule's own
\ words are (code 10, "Protected word").
header FORGET
: FORGET
32 WORD (LOOKUP) if MISSING
-2 + a! @ \ where its name starts
dup FENCE a! @ inv + 1 + -if OK \ name - fence
drop drop NODE-ERROR b! 10 !b ;
OK: drop
dup (Q) a! ! 4* DP a! ! \ the space from its name on
(LATEST) (PRUNE)
V: VOC-LINK a! @ if PRUNED \ vocabularies that go
dup (Q) a! @ inv + 1 + -if GONE drop jump KEPT
GONE: drop 1 + a! @ VOC-LINK a! ! jump V
KEPT: P: if PRUNED \ the lists of those that stay
dup (PRUNE) 1 + a! @ jump P
PRUNED: drop
CONTEXT a! @ (Q) a! @ inv + 1 + -if C1 drop jump C2
C1: drop (LATEST) CONTEXT a! !
C2: CURRENT a! @ (Q) a! @ inv + 1 + -if C3 drop jump TOLD
C3: drop (LATEST) CURRENT a! !
TOLD: (Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.v4)
MISSING: drop (UNKNOWN) drop ;
\ ---- the system as a whole -------------------------------------------------------
\ (BOOT) is two cells the loader fills when the capsule is in place: DP and
\ the newest FORTH entry as they then are. COLD goes back to them.
\ FORTH-79: execute to be sure a FORTH-79 system is there. It is: nothing
\ happens. (v3's prints two lines and leaves a flag.)
header 79-STANDARD
: 79-STANDARD ;
\ ( -- ) which system this is, and its cell width
header VERSION
: VERSION
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
N-1 1 + 0 U-DOT-R $7469622D (EMIT4) CR ;
\ ( -- ) clear the screen and put the cursor at the top, as v3: ESC [2J ESC [H
header PAGE
: PAGE 27 EMIT 91 EMIT 50 EMIT 74 EMIT 27 EMIT 91 EMIT 72 jump EMIT
\ ( -- ) as v3's message, and then ABORT: both stacks emptied, the prompt
header WARM
: WARM
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $72206D65 (EMIT4) $61747365 (EMIT4) $64657472 (EMIT4) $2E (EMIT4) CR
jump ABORT
\ ( -- ) the system as it was when the capsule had just been loaded:
\ everything defined since is gone, there is one vocabulary, numbers are
\ decimal, the block buffers are empty. Then as WARM.
header COLD
: COLD
(BOOT) a! @ DP a! !
(BOOT)+1 a! @ (LATEST) a! !
(BOOT) a! @ 2/ 2/ FENCE a! !
(LATEST) CONTEXT a! ! (LATEST) CURRENT a! ! 0 VOC-LINK a! !
10 BASE a! ! 0 SCR a! ! 2 (LOG-LEVEL) a! ! 0 (ACL-HOOK) a! ! EMPTY-BUFFERS
(BOOT) a! @ 2/ 2/ (FORGOTTEN) \ the kernel's records of what has gone go too (dict.v4)
$54524F46 (EMIT4) $39372D48 (EMIT4) $6C6F4320 (EMIT4) $74532064 (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $69206D65 (EMIT4) $6974696E (EMIT4) $7A696C61 (EMIT4) $2E6465 (EMIT4) CR
jump ABORT
\ ---- deferred words (as v3) -------------------------------------------------------
\ DEFER xxx makes xxx, which does whatever word it has been given:
\ ' yyy IS xxx gives it one; DEFER@ xxx leaves the one it has. A deferred
\ word with none is an error (code 15, "Deferred word not set").
: (DODEFER)
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
UNSET: drop NODE-ERROR b! 15 !b ;
header DEFER
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
: (is!) a! ! ;
: (defer@) a! @ ;
header IS immediate
: IS
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
NOW: drop jump (is!)
header DEFER@ immediate
: DEFER@
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
NOW: drop jump (defer@)
v4/capsule/words.v4
-201
View File
@@ -1,201 +0,0 @@
\ words.v4 -- more of the FORTH vocabulary: the stack, comparison, double,
\ mixed, shift and string words that are short runs of opcodes or small loops.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.7, 5.9)
\ and the mesh-node tests execute (test_cells.c, test_foundation.c,
\ test_strings.c), here as words of the host node's vocabulary. Rests on
\ core.v4, forth.v4 and numout.v4.
\
\ Constants the loader supplies:
\ MAX-INT the largest positive number: every bit but the top one
\ (X) word address of four cells of scratch for COMPARE and SEARCH
\ ---- stack ----
header 2SWAP
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
header 2OVER
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
header 2ROT
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
header 2>R inline compile-only : 2>R SWAP push push ;
header 2R> inline compile-only : 2R> pop pop SWAP ;
header 2R@ inline compile-only : 2R@ pop pop over over push push SWAP ;
header NOP inline : NOP' nop ;
header TRUE inline : TRUE -1 ;
header FALSE inline : FALSE 0 ;
header INVERT inline : INVERT inv ;
\ ---- memory ----
header 2@
: 2@ ( addr -- lo hi ) a! @+ @ ;
header 2!
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
header -!
: -! ( n addr -- ) a! NEGATE @ + ! ;
\ ---- comparison ----
header 0<>
: 0<> if Z drop -1 ; Z: ;
header 0>
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
header <>
: <> xor jump 0<>
header <=
: <= GREATER jump 0=
header >=
: >= LESS jump 0=
header U<
: U< over over xor -if SAME drop NIP jump 0<
SAME: drop - jump 0<
header U>
: U> SWAP jump U<
header ABS
: ABS -if P inv 1 + P: ;
header MAX
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
header MIN
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
header WITHIN
: WITHIN ( n low high -- flag ) push over pop LESS push LESS inv pop and ;
\ ---- shifts ----
\ As v3, a count that is negative or as large as the cell is wide is an
\ error (code 9, "Shift count out of range").
header LSHIFT
: LSHIFT ( x n -- x' )
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2* pop jump L
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
header RSHIFT
: RSHIFT ( x n -- x' ) \ zeros come in at the top
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2/ MAX-INT and pop jump L
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
\ ---- doubles and mixed ----
header D-
: D- DNEGATE jump D+
header DABS
: DABS -if P jump DNEGATE P: ;
header D0=
: D0= OR jump 0=
header D0<
: D0< push drop pop jump 0<
header D=
: D= D- jump D0=
header D2*
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
header D2/
: D2/ push a! 0 pop +* push drop a pop ;
header M+
: M+ S>D jump D+
header M-
: M- S>D DNEGATE jump D+
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
: (D<)
dup push push over pop over over xor if TIE
drop over over xor -if HS drop drop jump S1
HS: drop push inv pop + inv
S1: -if N1 drop -1 jump D1 N1: drop 0
D1: pop SWAP ;
TIE: drop drop drop dup push push over pop
over over xor -if LS drop NIP jump S2
LS: drop push inv pop + inv
S2: -if N2 drop -1 jump D2 N2: drop 0
D2: pop pop ROT ;
header D<
: D< (D<) push drop drop drop drop pop ;
header DMAX
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
header DMIN
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
\ ---- strings and memory ----
header ?TERMINAL
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
header CMOVE>
: CMOVE> ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE -1 + push
over pop dup push + C@
over pop dup push + C!
pop jump OK
DONE: drop drop drop ;
\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
header MOVE
: MOVE ( addr1 addr2 n -- )
-if OK drop drop drop ;
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
header FILL
: FILL ( baddr u c -- )
SWAP push SWAP pop \ c baddr u
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push over over C! 1 + pop -1 + jump OK
DONE: drop drop drop ;
header ERASE
: ERASE ( baddr u -- ) 0 jump FILL
header BLANK
: BLANK ( baddr u -- ) 32 jump FILL
header -TRAILING
: -TRAILING ( baddr u -- baddr u' )
-if L drop 0 ;
L: if DONE over over + -1 + C@ -32 + if SP drop ;
SP: drop -1 + jump L
DONE: ;
header COMPARE
: COMPARE ( a1 u1 a2 u2 -- n )
-if A drop 0 A: (X)+1 b! !b
SWAP -if B drop 0 B: dup (X) b! !b
(X)+1 b! @b
over over - -if GE drop drop jump M
GE: drop push drop pop
M:
L: if EQ push
over C@ over C@ - if SAME
-if GT drop drop drop pop drop -1 ;
GT: drop drop drop pop drop 1 ;
SAME: drop 1 + push 1 + pop pop -1 + jump L
EQ: drop drop drop (X) b! @b (X)+1 b! @b -
-if NN drop -1 ;
NN: if ZZ drop 1 ;
ZZ: ;
header SEARCH
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
-if A drop 0 A: (X)+1 b! !b (X) b! !b
-if B drop 0 B: dup (X)+3 b! !b over (X)+2 b! !b
L: dup (X)+1 b! @b - -if TRY
drop drop drop (X)+2 b! @b (X)+3 b! @b 0 ;
TRY: drop over (X) b! @b (X)+1 b! @b
I: if MATCH push
over C@ over C@ xor if SAME
drop drop drop pop drop push 1 + pop -1 + jump L
SAME: drop 1 + push 1 + pop pop -1 + jump I
MATCH: drop drop drop -1 ;
header SCAN
: SCAN ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if FOUND
drop push 1 + pop -1 + jump L
FOUND: drop
DONE: pop drop ;
header SKIP
: SKIP ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if SAME drop jump DONE
SAME: drop push 1 + pop -1 + jump L
DONE: pop drop ;