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

feat(v4): the ROM assembles the system's .f18 to the nucleus, word for word

Browse Source 
capsules/v4/sys: the nucleus's fourteen sources as .f18 blobs (made once by
v4/tools/v4tof18.py: header becomes the ROM's directives, every other token
and line kept), the memory map as map-<width>.f18 (mkmap sys, from one
table in host_map.h that host_load reads too), and end.f18, the switch-on
state mkimage.c set in C, the image record, and start (IDLE).

test_host_rom_nucleus.c: the ROM, fed those blobs through the console,
builds RAM identical word for word to mkimage.c's, outside its own state
and the image record, and starts at (IDLE), at both widths.  The cost:
60.7 million instructions, 1.5 s on the C model.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-15 12:27:50 -04:00
co-authored by Claude Opus 5.5
parent 084c520a54
commit 1bf19d6224
22 changed files with 4058 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files
capsules/v4/sys/acl.f18
+83
View File
@@ -0,0 +1,83 @@
\ 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 ;
set HDR-NFA here ", ACL-HOOK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
set HDR-NFA here ", ACL-MODE@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
set HDR-NFA here ", ACL-TTL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
set HDR-NFA here ", ACL-ALLOW@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
set HDR-NFA here ", ACL-PINNED? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
set HDR-NFA here ", ACL-PIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
set HDR-NFA here ", ACL-MODE! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 + ! ;
set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ACL-HEAT@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-HEAT@ (ACL-XT) drop 0 ;
\ ( xt -- n ) a number for the word that never changes: its address
set HDR-NFA here ", ACL-WORD-ID #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-WORD-ID (ACL-XT) ;
capsules/v4/sys/blocks.f18
+127
View File
@@ -0,0 +1,127 @@
\ 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
set HDR-NFA here ", SCR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SCR' SCR ;
set HDR-NFA here ", BLK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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.
set HDR-NFA here ", BUFFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", BLOCK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", UPDATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
\ FORTH-79: write every block that has been UPDATEd.
set HDR-NFA here ", SAVE-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
\ As v3: the same.
set HDR-NFA here ", FLUSH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FLUSH jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
set HDR-NFA here ", EMPTY-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", LIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", LOAD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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).
set HDR-NFA here ", --> #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", THRU #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
capsules/v4/sys/codegen.f18
+119
View File
@@ -0,0 +1,119 @@
\ 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,)
capsules/v4/sys/compile.f18
+466
View File
@@ -0,0 +1,466 @@
\ compile.v4 -- the interpreter's inner loop, and the defining and compiling
\ words.
\
\ DECOMPOSITION.md 5.17 and 5.18: STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE
\ [COMPILE] ' EXECUTE CREATE VARIABLE CONSTANT DOES>, the control structures
\ IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP, and INTERPRET,
\ which they cannot be run without. Part of the compiler capsule. Rests on
\ core.v4, input.v4, dict.v4 and codegen.v4.
\
\ HOW A WORD IS COMPILED. v4 code is native: a colon definition is
\ instruction words, and compiling a word into one lays down a call to it.
\ Two flags on an entry (dict.v4) change that:
\ inline its code is a straight run of opcodes and literals ending
\ in ; -- that run is copied in place of a call. Everything
\ that touches the return stack must be, since a call would
\ bury what it works on (DECOMPOSITION.md 0, fate IN).
\ compile-only it may not be executed by the interpreter.
\ An immediate word is executed even when compiling.
\
\ THE STACKS ARE SHORT: written for ten cells of data and nine return entries
\ (D-2; the host node now has 32 of each, D-17), and one more of either is a
\ fault (D-16). The interpreter and compiler run on the same
\ stacks as the user's words, with the user's values beneath them, so:
\ - every word here keeps what it works on in (C), and has at most three
\ cells of its own on the data stack at any moment;
\ - what an IF or a DO leaves for its THEN or LOOP goes on a control-flow
\ stack in memory, not on the data stack, so structures may nest as
\ deep as that stack (32 cells) allows whatever the user has stacked.
\
\ Constants the loader supplies:
\ STATE word address of the variable: non-zero while compiling
\ (C) word address of ten cells of scratch for this file:
\ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot
\ (C)+2 LATEST before a header is made (C)+3 a data word's routine
\ (C)+5 what a loop's end lays after its test
\ (C)+6 (C)+7 a branch and a tag a control word is holding
\ (C)+8 whether a data word's entry was made
\ (C)+9 the error code a line is being abandoned with
\ (CFP) word address of the control-flow stack's pointer
\ CFBASE CFEND word addresses of its first cell and of the cell past its last
macro ROT push SWAP pop SWAP endmacro
\ ---- errors ------------------------------------------------------------------
\ ( -- ) give up the line: stop compiling, forget the word being built and
\ whatever control structures were open, skip the rest of the input, and set
\ NODE-ERROR. A definition that was under way stays hidden. It returns to
\ whatever called INTERPRET, which is QUIT (quit.v4): QUIT sees NODE-ERROR
\ and prints ERROR.
\ (ABANDON-AS) is the same with an error code (core.v4) for the prompt to
\ print the message of.
: (ABANDON-AS) ( code -- )
(C)+9 a! !
0 STATE a! ! (CG-RESET)
CFBASE (CFP) a! !
SPAN a! @ >IN a! !
(C)+9 a! @ NODE-ERROR b! !b ;
: (ABANDON) -1 jump (ABANDON-AS)
\ ---- the control-flow stack ----------------------------------------------------
\ ( x -- ) push; a full stack abandons the line
: >CF
(CFP) a! @ CFEND xor if FULL
drop (CFP) a! @ dup 1 + ! a! ! ;
FULL: drop drop 8 jump (ABANDON-AS) \ control structures too deep
\ ( -- x ) pop; 0 from an empty stack, which no opening word leaves
: CF>
(CFP) a! @ CFBASE xor if EMPTY
drop (CFP) a! @ -1 + dup ! a! @ ;
EMPTY: ;
\ ---- compiling one word ------------------------------------------------------
\ ( w -- op ) the opcode in slot 0 of the instruction word w
: (TOP5) 8/ 8/ 8/ 2/ 2/ 2/ 31 and ;
\ ( xt -- ) copy the in-line word at xt into the definition being built.
\ Each slot is read from the top of the word in (C)+0, which is then moved
\ up five bits for the next.
: (INLINE,)
W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it
0 (C)+4 a! ! \ slot
S: (C) a! @ dup 2* 2* 2* 2* 2* ! (TOP5) \ op
if END \ ; ends the copy
dup -8 + if LIT
drop dup -28 + if NOP \ nop is padding
drop (OP,)
NXT: (C)+4 a! @ 1 + dup ! -6 + if NEXTW drop jump S
NEXTW: drop (C)+1 a! @ jump W \ the next instruction word follows the literals
LIT: drop drop (C)+1 a! @ dup 1 + ! a! @ (LIT,) jump NXT
NOP: drop drop jump NXT
END: drop ;
\ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call
: (COMPILE,)
dup -3 + a! @ 8 and if CALL drop jump (INLINE,)
CALL: drop jump (CALL,)
\ ---- access control (5.20) -------------------------------------------------------
\ Each entry's flags cell also holds its access control fields:
\ bit 5 (32) denied: the word may not be used
\ bit 6 (64) pinned: the fields cannot be changed
\ bits 8 .. 15 the mode: 0 TTL, 1 STRICT
\ bits 16 .. 31 the TTL, a count of uses left before the next recheck
\ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0.
\
\ (ACL?) is run by INTERPRET for every word it is about to execute or
\ compile. As v3: if the TTL is 0 the word is rechecked, otherwise the TTL
\ is counted down; then a denied word is refused. The recheck is the word
\ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded --
\ and with none there the word is allowed and given the longest TTL.
\
\ v3 checks every execution, inside definitions too. v4 code is native: a
\ compiled call goes straight to its word. So v4 checks a word when it is
\ compiled as well as when it is interpreted -- a denied word cannot be
\ built into anything new -- but a call compiled while the word was allowed
\ is not checked again.
\ ( xt -- ) recheck
: (ACL-RECHECK)
(ACL-HOOK) a! @ if NONE push ex \ call it with the xt
;
NONE: drop -3 + a! @ 65535 and -33 and $FFFF0000 + ! ;
\ ( xt -- xt ) as above; a denied word ends the line
: (ACL?)
dup -3 + a! @ \ xt flags
dup $FFFF0000 and if ZERO
drop -65536 + ! jump TEST \ one use fewer
ZERO: drop drop dup (ACL-RECHECK)
TEST: dup -3 + a! @ 32 and if OK
drop drop
$33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) \ v3's line: WARN: in yellow
$3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4)
(.WORD) 39 EMIT CR
DSTACK-DEPTH b! a !b \ as v3, the stack is emptied
pop drop jump (ABANDON)
OK: drop ;
\ ( -- ) print the word WORD has just left
: (.WORD) WBUF COUNT jump TYPE
set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXECUTE ( xt -- ) push ;
\ ---- the interpreter's inner loop ---------------------------------------------
\ ( -- n flag ) the word WORD has just left, as a single-cell number in the
\ current BASE, and -1; or 0 0 if it is not one. A leading minus sign is
\ allowed. This is what the interpreter uses: NUMBER (input.v4) makes a
\ double and needs more of the stack than can be spared here.
\ (P)+2 the number so far, (P)+3 where it is in the word, (P)+4 the word's
\ length, (P)+5 the sign, (P)+6 the base.
: (NUM?)
WBUF C@ if EMPTY
(P)+4 a! ! 0 (P)+2 a! ! 1 (P)+3 a! ! 0 (P)+5 a! !
(BASE) (P)+6 a! !
WBUF+1 C@ -45 + if NEG drop jump DIGITS
NEG: drop -1 (P)+5 a! ! 2 (P)+3 a! !
(P)+4 a! @ -1 + if EMPTY drop \ a sign alone
DIGITS:
L: (P)+4 a! @ (P)+3 a! @ - -if MORE
drop (P)+2 a! @ (P)+5 a! @ if POS drop NEGATE -1 ;
POS: drop -1 ;
MORE: drop
(P)+3 a! @ dup 1 + ! WBUF + C@ (DIGIT) \ d
-if DIGIT jump BAD1
DIGIT: dup (P)+6 a! @ - -if BAD2 drop
(P)+2 a! @ (P)+6 a! @ STAR + (P)+2 a! !
jump L
BAD2: drop
BAD1: drop 0 0 ;
EMPTY: drop 0 0 ;
\ ( -- ) FORTH-79: take words from the input stream until it is exhausted.
\ A word in the dictionary is executed, or, when compiling and not immediate,
\ compiled. Anything else must be a number in the current BASE: it is left
\ on the stack, or compiled as a literal. What is neither, or a compile-only
\ word met while interpreting, abandons the line, with v3's message:
\ UNKNOWN WORD: 'xxx' xxx: compile-only
set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: INTERPRET
L: 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
dup -3 + a! @ \ xt flags
STATE a! @ if INTERP
drop 1 and if COMP \ compiling: immediate words still run
drop (ACL?) EXECUTE jump L
COMP: drop (ACL?) (COMPILE,) jump L
INTERP: drop 16 and if RUN
drop drop (.WORD) \ ": compile-only"
$6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR
jump (ABANDON)
RUN: drop (ACL?) EXECUTE jump L
NUM: drop (NUM?) if BAD
drop
STATE a! @ if KEEP drop (LIT,) jump L
KEEP: drop jump L
BAD: drop drop (UNKNOWN) drop jump (ABANDON)
EOL: drop drop ;
\ ---- state ---------------------------------------------------------------------
set HDR-NFA here ", [ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LEFT-BRACKET 0 STATE a! ! ;
set HDR-NFA here ", ] #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: RIGHT-BRACKET -1 STATE a! ! ;
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
set HDR-NFA here ", LITERAL #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ;
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
\ compiling, compiled as a literal
set HDR-NFA here ", ' #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TICK (') jump LITERAL
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
\ which v3 has as another name for LITERAL.
set HDR-NFA here ", ['] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-TICK (') jump (LIT,)
set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-LITERAL jump LITERAL
\ ---- colon definitions -----------------------------------------------------------
\ FORTH-79: start a definition; it cannot be found until ; ends it. The
\ CONTEXT vocabulary is set to the CURRENT one.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COLON
CURRENT a! @ CONTEXT a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET
NONE: drop jump (ABANDON) \ no entry: the rest of the line is not a definition
\ FORTH-79: compile the return, let the word be found, stop compiling
set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEMICOLON
0 (OP,)
LATEST (FLAGS) a! @ -3 and !
jump LEFT-BRACKET
\ ( n -- ) KERNEL-WORD xxx A WORD THAT ASKS THE KERNEL (docs/v4.0.0/
\ ENGINE.md 3.3). xxx is made a word whose whole body is "write n to the
\ port": n is the number of a request, the port is the node's way to its
\ kernel, and the write blocks the node until the kernel has served it
\ (DECOMPOSITION.md section 6). xxx's arguments are whatever it finds on
\ the data stack and its results are what the kernel leaves there. This is
\ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a
\ node. Not FORTH-79 and not in v3, where such a word is registered from C.
\ The constant (PORT) is the port's word address.
set HDR-NFA here ", KERNEL-WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KERNEL-WORD
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
jump SEMICOLON
\ FORTH-79: return from the definition at this point
set HDR-NFA here ", EXIT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXIT 0 jump (OP,)
set HDR-NFA here ", IMMEDIATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
set HDR-NFA here ", COMPILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COMPILE
32 WORD (LOOKUP) if MISSING
(LIT,) &(COMPILE,) jump (CALL,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate
set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-COMPILE
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ ---- data words ---------------------------------------------------------------------
\ A data word's code is one call to its run-time routine; the call leaves the
\ address of the cell after it -- the parameter field -- on the return stack.
: (DOVAR) pop ; \ leave the parameter field address
: (DOCON) pop a! @ ; \ leave what it holds
\ ( -- ) an entry for the next word, flagged data, its code a call to the
\ routine whose address is in (C)+3. (C)+8 is left -1 if one was made, else
\ 0. It ends by jumping, and CREATE jumps to it, so that a defining word
\ has as few return entries under it as can be.
: (DATA)
0 (C)+8 a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
(CG-RESET)
LATEST (FLAGS) a! @ 4 OR !
-1 (C)+8 a! !
(C)+3 a! @ jump (CALL,)
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
set HDR-NFA here ", CREATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
\ programme; here it is 0.
set HDR-NFA here ", VARIABLE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
\ ( n -- ) FORTH-79: an entry whose word leaves n
set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ;
\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become
\ what each word DEFINER makes does, starting with its parameter field address
\ on the stack. (DOES), run by DEFINER, turns the newest entry's code into a
\ call to the code after it and leaves DEFINER; that code starts with pop,
\ which fetches the parameter field address the call left.
: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0
set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOES> &(DOES) (CALL,) 25 jump (OP,)
\ ---- control structures (5.18, section 2) ---------------------------------------------
\ All immediate and compile-only. Each puts what the word that closes it
\ needs on the control-flow stack, with a number on top saying which word put
\ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO, 7 CASE, 8 OF. A closing word that
\ finds the wrong number abandons the line.
\ ( tag wanted -- ) if they differ, abandon the line and leave the control
\ word that called this as well: its return address is dropped, so the
\ abandoning returns to the interpreter and nothing more is laid down.
: (PAIR) xor if OK drop pop drop 7 jump (ABANDON-AS) OK: drop ;
\ ( ref -- ) the branch at ref lands here
: (HERE!) (FLUSH) HERE SWAP jump (RESOLVE)
\ Native if leaves the flag, so both ways out of it drop it (section 2):
\ IF a THEN if L1 drop a jump L2 L1: drop L2:
\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2:
set HDR-NFA here ", IF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF
set HDR-NFA here ", ELSE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ELSE
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF \ the jump over the else part
(C)+6 a! @ (HERE!) 23 (OP,)
2 jump >CF
set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: THEN
CF> dup -1 + if PLAIN
drop 2 (PAIR) CF> jump (HERE!)
PLAIN: drop drop
CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF
(C)+6 a! @ (HERE!) 23 (OP,)
CF> jump (HERE!)
\ A loop that tests at its end jumps back with the flag still there, so it
\ jumps back to a drop laid just ahead of the body:
\ BEGIN a UNTIL jump L0 Ld: drop L0: a if Ld drop
\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop
\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0
\ The control-flow stack holds Ld, L0 and 3.
set HDR-NFA here ", BEGIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BEGIN
2 (BRANCH>) (C)+6 a! !
(LABEL) >CF 23 (OP,)
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
3 jump >CF
set HDR-NFA here ", UNTIL #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,)
set HDR-NFA here ", AGAIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ;
set HDR-NFA here ", WHILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF
set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: REPEAT
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
CF> 3 (PAIR) CF> (JUMP,) CF> drop
(C)+6 a! @ (HERE!) 23 jump (OP,)
\ CASE: the value being chosen on stays on the stack through the clauses.
\ CASE x1 OF a ENDOF x2 OF b ENDOF c ENDCASE
\ lays, for each clause,
\ over xor if M drop jump N M: drop drop a jump END N:
\ and ENDCASE lays the drop that the part after the last ENDOF leaves the
\ value for, with END after it. The control-flow stack holds the jumps to
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
: (of) over xor ;
set HDR-NFA here ", CASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CASE 0 >CF 7 jump >CF
set HDR-NFA here ", OF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: OF
CF> 7 (PAIR)
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
8 jump >CF
set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDOF
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
CF> (C)+7 a! ! \ how many jumps to END so far
2 (BRANCH>) >CF \ one more
(C)+7 a! @ 1 + >CF
(C)+6 a! @ (HERE!) \ N:
7 jump >CF
set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDCASE
CF> 7 (PAIR) CF> (C)+7 a! !
23 (OP,)
L: (C)+7 a! @ if DONE -1 + !
CF> (HERE!) jump L
DONE: drop ;
\ DO loops: the limit and index are on the return stack, limit below (5.18).
: (do) over push push drop ;
: (?do) over over xor ;
: (inc) pop 1 + pop ; \ index' limit
: (+inc) dup a! pop + pop ; \ index' limit A: the step
: (differ) drop over ;
: (same) drop over over - ;
: (a-xor) a xor ;
: (again) drop push push ;
: (3drop) drop drop drop ;
\ The end of a loop. The control-flow stack holds the body's address and 5,
\ or for ?DO its skip, the body and 6; (C)+5 holds the xt of in-line code to
\ lay after the test, or 0. Laid down, in order:
\ <less> ( i' lim -- i' lim s ), the top bit of s set when i' < lim:
\ over over xor -if SAME drop over jump T SAME: drop over over - T:
\ the code in (C)+5, if any
\ -if EXIT drop push push jump BODY EXIT: drop drop drop
\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST:
\ It is one word, jumped to by LOOP and +LOOP, so that laying a loop's end
\ takes as few return entries as laying anything else.
: (LOOPS)
&(?do) (INLINE,) 7 (BRANCH>) >CF
&(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! !
CF> (HERE!) &(same) (INLINE,)
(C)+6 a! @ (HERE!)
(C)+5 a! @ if NOMORE (INLINE,) jump TESTED
NOMORE: drop
TESTED:
CF> (C)+7 a! ! \ the tag
7 (BRANCH>) (C)+6 a! !
&(again) (INLINE,) CF> (JUMP,)
(C)+6 a! @ (HERE!) &(3drop) (INLINE,)
(C)+7 a! @ -5 + if PLAIN
drop (C)+7 a! @ 6 (PAIR)
2 (BRANCH>) (C)+6 a! !
CF> (HERE!) &(3drop) (INLINE,)
(C)+6 a! @ jump (HERE!)
PLAIN: drop ;
set HDR-NFA here ", DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF
set HDR-NFA here ", ?DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
set HDR-NFA here ", LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
set HDR-NFA here ", +LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
capsules/v4/sys/core.f18
+480
View File
@@ -0,0 +1,480 @@
set HDR-LINK 0 \ the newest dictionary entry: none yet
\ 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 ------------------------------------------------
set HDR-NFA here ", UM* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ------------------------------------------------
set HDR-NFA here ", D+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 + ;
set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ------------------------------------------------
set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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).
set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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! ;
set HDR-NFA here ", KEY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
set HDR-NFA here ", CR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CR ( -- ) 10 jump EMIT
set HDR-NFA here ", SPACE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACE ( -- ) 32 jump EMIT
set HDR-NFA here ", COUNT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
set HDR-NFA here ", TYPE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
capsules/v4/sys/dict.f18
+233
View File
@@ -0,0 +1,233 @@
\ 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 ;
set HDR-NFA here ", HERE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
set HDR-NFA here ", ALIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
set HDR-NFA here ", ALLOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
set HDR-NFA here ", , #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: , ( 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 ;
set HDR-NFA here ", C, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C, ( c -- )
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
set HDR-NFA here ", 2, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
set HDR-NFA here ", LATEST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
set HDR-NFA here ", >LINK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >LINK ( xt -- addr ) -1 + ;
set HDR-NFA here ", LFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LFA ( xt -- addr ) jump >LINK
set HDR-NFA here ", LINK> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LINK> ( addr -- xt ) a! @ ;
set HDR-NFA here ", >NAME #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
set HDR-NFA here ", NFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NFA ( xt -- baddr ) jump >NAME
set HDR-NFA here ", NAME> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
set HDR-NFA here ", CFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CFA ( xt -- xt ) ;
set HDR-NFA here ", PFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
set HDR-NFA here ", >BODY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >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.
set HDR-NFA here ", TRAVERSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
set HDR-NFA here ", SMUDGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", FIND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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)
capsules/v4/sys/end.f18
+35
View File
@@ -0,0 +1,35 @@
\ end.f18 -- the end of the system's source: the state it is switched on in.
\
\ What v4/tools/mkimage.c set in C when it built the nucleus, said with the
\ ROM's directives (MACHINE.md, the ROM's language). RAM is all zeroes
\ when the machine starts, so only what is not zero is stored. Then the
\ image record (map: (IMG)), the addresses a host needs (v4/image.h), and
\ start: the ROM clears what it used and the node waits for a message.
\ the dictionary: empty, at DBASE; the newest entry, the nucleus's last
store DP DBASE
store (LATEST) HDR-LINK
\ the control-flow stack, the number base, the log level
store (CFP) CFBASE
store BASE 10
store (LOG-LEVEL) 2
\ one vocabulary, FORTH, whose head cell is LATEST; new words go into it
store CONTEXT (LATEST)
store CURRENT (LATEST)
\ the text interpreted is the terminal's
store (SRC) TIB
\ what COLD comes back to, and the lowest FORGET goes: the nucleus as it is
store (BOOT) DBASE
store (BOOT)+1 HDR-LINK
store FENCE DICT-W
\ nothing has ended badly; nothing has been printed
store (LINE-STATUS) 1
store (OUT^) (OUT)
\ the image record: where the node waits, its fault table, KEY's code
store (IMG) &(IDLE)
store (IMG)+1 &(FAULTS)
store (IMG)+2 &KEY
store (IMG)+3 &CR
start (IDLE)
capsules/v4/sys/forth.f18
+229
View File
@@ -0,0 +1,229 @@
\ 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 ----
set HDR-NFA here ", DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
set HDR-NFA here ", DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DROP drop ;
set HDR-NFA here ", OVER #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OVER over ;
set HDR-NFA here ", SWAP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SWAP' SWAP ;
set HDR-NFA here ", ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ROT' ROT ;
set HDR-NFA here ", -ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : -ROT SWAP push SWAP pop ;
set HDR-NFA here ", ?DUP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ?DUP if Z dup ; Z: ;
set HDR-NFA here ", 2DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DUP over over ;
set HDR-NFA here ", 2DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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
set HDR-NFA here ", DEPTH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", PICK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ROLL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ----
set HDR-NFA here ", >R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >R push ;
set HDR-NFA here ", R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R> pop ;
set HDR-NFA here ", R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R@ pop dup push ;
set HDR-NFA here ", I #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : I pop dup push ;
set HDR-NFA here ", J #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : J pop pop pop dup push a! push push a ;
set HDR-NFA here ", LEAVE #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
set HDR-NFA here ", UNLOOP #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
\ ---- memory ----
set HDR-NFA here ", @ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FETCH a! @ ;
set HDR-NFA here ", ! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STORE a! ! ;
set HDR-NFA here ", +! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
set HDR-NFA here ", CELLS #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
\ ---- arithmetic ----
set HDR-NFA here ", + #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
set HDR-NFA here ", - #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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.
set HDR-NFA here ", * #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", NEGATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
set HDR-NFA here ", 1+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1+ 1 + ;
set HDR-NFA here ", 1- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1- -1 + ;
set HDR-NFA here ", 2+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2+ 2 + ;
set HDR-NFA here ", 2- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2- -2 + ;
set HDR-NFA here ", 2* #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO* 2* ;
set HDR-NFA here ", 2/ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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 ;
set HDR-NFA here ", S>D #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", M* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", /MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: drop drop 0 $444F4D2F jump (DIV0)
set HDR-NFA here ", / #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: drop drop 0 $2F jump (DIV0)
set HDR-NFA here ", MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: drop drop 0 $444F4D jump (DIV0)
set HDR-NFA here ", */MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
set HDR-NFA here ", */ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: drop drop drop 0 $2F2A jump (DIV0)
set HDR-NFA here ", M/MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
\ ---- logic and comparison ----
set HDR-NFA here ", AND #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
set HDR-NFA here ", XOR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : XOR xor ;
set HDR-NFA here ", OR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OR' OR ;
set HDR-NFA here ", 0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0= if L1 drop 0 ; L1: drop -1 ;
set HDR-NFA here ", 0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0< -if L1 drop -1 ; L1: drop 0 ;
set HDR-NFA here ", NOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOT jump 0=
set HDR-NFA here ", = #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : EQUALS xor jump 0=
set HDR-NFA here ", < #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
over over xor -if SAME drop drop jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", > #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : GREATER SWAP jump LESS
\ ---- in-line addresses and constants ----
set HDR-NFA here ", BL #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL' BL ;
set HDR-NFA here ", TIB #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TIB' TIB ;
set HDR-NFA here ", >IN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >IN' >IN ;
set HDR-NFA here ", SPAN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SPAN' SPAN ;
set HDR-NFA here ", BASE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BASE' BASE ;
set HDR-NFA here ", PAD #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PAD' PAD ;
set HDR-NFA here ", STATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
capsules/v4/sys/input.f18
+217
View File
@@ -0,0 +1,217 @@
\ 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
set HDR-NFA here ", SOURCE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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).
set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", QUERY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ENCLOSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", CONVERT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", NUMBER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ( #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PAREN 41 WORD drop ;
set HDR-NFA here ", \ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BACKSLASH
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
TERM: drop SPAN a! @ >IN a! ! ;
capsules/v4/sys/log.f18
+72
View File
@@ -0,0 +1,72 @@
\ 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
set HDR-NFA here ", LOG-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR 0 ;
set HDR-NFA here ", LOG-WARN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN 1 ;
set HDR-NFA here ", LOG-INFO #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO 2 ;
set HDR-NFA here ", LOG-TEST #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST 3 ;
set HDR-NFA here ", LOG-DEBUG #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG 4 ;
set HDR-NFA here ", LOG-LEVEL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
set HDR-NFA here ", LOG-LEVEL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", LOG-ERROR-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
set HDR-NFA here ", LOG-WARN-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
set HDR-NFA here ", LOG-INFO-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
set HDR-NFA here ", LOG-TEST-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
set HDR-NFA here ", LOG-DEBUG-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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.
set HDR-NFA here ", (LOG") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (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)
set HDR-NFA here ", LOG-ERROR" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-WARN" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-INFO" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-TEST" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-DEBUG" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
capsules/v4/sys/map-32.f18
+118
View File
@@ -0,0 +1,118 @@
\ map-32.f18 -- the memory map the system's source is assembled with, 32-bit cells.
\ Generated by v4/tools/mkmap.c (mkmap sys) from v4/tests/host_map.h -- do not edit.
constant N-1 31
constant NODE-ERROR 16382
constant CONSOLE-TX 16380
constant CONSOLE-RX 16378
constant CONSOLE-STATUS 16377
constant BASE 16376
constant TIB 63776
constant >IN 16375
constant SPAN 16374
constant WBUF 64856
constant (P) 16360
constant DP 16373
constant (LATEST) 16372
constant DBASE 32768
constant DLIMIT 55296
constant PAD 63656
constant (D) 16352
constant (CG) 16336
constant CG-BSLOTS 3
constant STATE 16371
constant (C) 16322
constant (CFP) 16370
constant (Q) 14708
constant (F) 16279
constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
constant BLK 15743
constant (SRC) 15744
constant (SRC-HOOK) 15745
constant (LINE-STATUS) 14703
constant (PORT) 14572
constant (ME) 14699
constant (CONSOLE) 14696
constant (ROUTE#) 14695
constant (ROUTE-DEFAULT) 14694
constant (LOST) 14693
constant (PRINT-TO) 14692
constant (PRINT-PORT) 14679
constant (DONE-PORT) 14678
constant (ROUTES) 14616
constant -PORTS -8
constant (NEAR) 14648
constant (AWAIT-FROM) 14673
constant (WIRE) 14584
constant (WIRE-A) 14585
constant (WIRE-B) 14586
constant (WIRE-DO) 14587
constant (WIRE-HOW) 14588
constant (WIRE-HAVE) 14589
constant (S-HAVE) 14677
constant (S-MASK) 14676
constant (S-WIRE) 14675
constant (S-ON) 14674
constant (KEEP) 14672
constant (DEFER) 14671
constant (D-MASK) 14704
constant (IN) 14656
constant (ONE) 14663
constant (OUT-HDR) 14600
constant (W-NEED) 14607
constant (W-PORT) 14608
constant (P-WAY) 14609
constant (P-NEED) 14612
constant (H-PORT) 14613
constant (H-NEED) 14614
constant (H-MASK) 14615
constant (A-SELF) 14610
constant (SEND^) 14611
constant (OUT-TEXT) 14248
constant (SEND-TEXT) 13912
constant (QUIET) 14702
constant (REFUSED) 14705
constant (OUT^) 14698
constant (REPLY) 14697
constant (MSG) 14664
constant (OUT) 14312
constant (WORD-DEFINED) 14701
constant (WORD-FORGOTTEN) 14700
constant BLOCK# -1
constant BUFFER# -2
constant UPDATE# -3
constant SAVE-BUFFERS# -4
constant EMPTY-BUFFERS# -5
constant (Q/) 15752
constant (QE) 15757
constant (QR) 15765
constant (QL) 15770
constant (QT) 15777
constant (QP) 15783
constant (DP) 15787
constant ADDR-DIGITS 8
constant MSB -2147483648
constant MAXHI 2147483647
constant HIMASK 65535
constant 2N+15 79
constant N-18 14
constant N-17 15
constant MAX-INT 2147483647
constant HLD 16359
constant FENCE 16358
constant CONTEXT 16320
constant CURRENT 16321
constant VOC-LINK 16334
constant HEND 63248
constant -HFLOOR -63186
constant DSTACK-DEPTH 16369
constant RSTACK-DEPTH 16368
constant CFBASE 16288
constant CFEND 16320
constant DICT-W 8192
constant (IMG) 14593
capsules/v4/sys/map-64.f18
+118
View File
@@ -0,0 +1,118 @@
\ map-64.f18 -- the memory map the system's source is assembled with, 64-bit cells.
\ Generated by v4/tools/mkmap.c (mkmap sys) from v4/tests/host_map.h -- do not edit.
constant N-1 63
constant NODE-ERROR 16382
constant CONSOLE-TX 16380
constant CONSOLE-RX 16378
constant CONSOLE-STATUS 16377
constant BASE 16376
constant TIB 63776
constant >IN 16375
constant SPAN 16374
constant WBUF 64856
constant (P) 16360
constant DP 16373
constant (LATEST) 16372
constant DBASE 32768
constant DLIMIT 55296
constant PAD 63656
constant (D) 16352
constant (CG) 16336
constant CG-BSLOTS 3
constant STATE 16371
constant (C) 16322
constant (CFP) 16370
constant (Q) 14708
constant (F) 16279
constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
constant BLK 15743
constant (SRC) 15744
constant (SRC-HOOK) 15745
constant (LINE-STATUS) 14703
constant (PORT) 14572
constant (ME) 14699
constant (CONSOLE) 14696
constant (ROUTE#) 14695
constant (ROUTE-DEFAULT) 14694
constant (LOST) 14693
constant (PRINT-TO) 14692
constant (PRINT-PORT) 14679
constant (DONE-PORT) 14678
constant (ROUTES) 14616
constant -PORTS -8
constant (NEAR) 14648
constant (AWAIT-FROM) 14673
constant (WIRE) 14584
constant (WIRE-A) 14585
constant (WIRE-B) 14586
constant (WIRE-DO) 14587
constant (WIRE-HOW) 14588
constant (WIRE-HAVE) 14589
constant (S-HAVE) 14677
constant (S-MASK) 14676
constant (S-WIRE) 14675
constant (S-ON) 14674
constant (KEEP) 14672
constant (DEFER) 14671
constant (D-MASK) 14704
constant (IN) 14656
constant (ONE) 14663
constant (OUT-HDR) 14600
constant (W-NEED) 14607
constant (W-PORT) 14608
constant (P-WAY) 14609
constant (P-NEED) 14612
constant (H-PORT) 14613
constant (H-NEED) 14614
constant (H-MASK) 14615
constant (A-SELF) 14610
constant (SEND^) 14611
constant (OUT-TEXT) 14248
constant (SEND-TEXT) 13912
constant (QUIET) 14702
constant (REFUSED) 14705
constant (OUT^) 14698
constant (REPLY) 14697
constant (MSG) 14664
constant (OUT) 14312
constant (WORD-DEFINED) 14701
constant (WORD-FORGOTTEN) 14700
constant BLOCK# -1
constant BUFFER# -2
constant UPDATE# -3
constant SAVE-BUFFERS# -4
constant EMPTY-BUFFERS# -5
constant (Q/) 15752
constant (QE) 15757
constant (QR) 15765
constant (QL) 15770
constant (QT) 15777
constant (QP) 15783
constant (DP) 15787
constant ADDR-DIGITS 16
constant MSB -9223372036854775808
constant MAXHI 9223372036854775807
constant HIMASK 281474976710655
constant 2N+15 143
constant N-18 46
constant N-17 47
constant MAX-INT 9223372036854775807
constant HLD 16359
constant FENCE 16358
constant CONTEXT 16320
constant CURRENT 16321
constant VOC-LINK 16334
constant HEND 63248
constant -HFLOOR -63186
constant DSTACK-DEPTH 16369
constant RSTACK-DEPTH 16368
constant CFBASE 16288
constant CFEND 16320
constant DICT-W 8192
constant (IMG) 14593
capsules/v4/sys/numout.f18
+153
View File
@@ -0,0 +1,153 @@
\ 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 ----
set HDR-NFA here ", <# #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <# ( -- ) HEND HLD b! !b ;
set HDR-NFA here ", HOLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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!
set HDR-NFA here ", SIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
set HDR-NFA here ", # #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: # ( 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
set HDR-NFA here ", #S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
set HDR-NFA here ", #> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
set HDR-NFA here ", SPACES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
set HDR-NFA here ", DECIMAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DECIMAL 10 BASE a! ! ;
set HDR-NFA here ", HEX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HEX 16 BASE a! ! ;
set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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)
set HDR-NFA here ", .R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
set HDR-NFA here ", . #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
set HDR-NFA here ", U.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
set HDR-NFA here ", U. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
set HDR-NFA here ", D.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
set HDR-NFA here ", D. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
set HDR-NFA here ", ? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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@
set HDR-NFA here ", DUMP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
capsules/v4/sys/qmath.f18
+247
View File
@@ -0,0 +1,247 @@
\ 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 ----
set HDR-NFA here ", Q.FROM-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
set HDR-NFA here ", Q.TO-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", Q.1 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.1 65536 0 ;
set HDR-NFA here ", Q.0 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0 0 0 ;
set HDR-NFA here ", Q.SCALE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
\ ---- the double words under other names ----
set HDR-NFA here ", Q.+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.+ jump D+
set HDR-NFA here ", Q.- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.- jump D-
set HDR-NFA here ", Q.ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.ABS jump DABS
set HDR-NFA here ", Q.NEG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.NEG jump DNEGATE
set HDR-NFA here ", Q.= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.= jump D=
set HDR-NFA here ", Q.< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.< jump D<
set HDR-NFA here ", Q.> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.> 2SWAP jump D<
set HDR-NFA here ", Q.0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0= jump D0=
set HDR-NFA here ", Q.MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MAX jump DMAX
set HDR-NFA here ", Q.MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
\ ---- multiply ----
set HDR-NFA here ", Q.* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", Q./ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ----
set HDR-NFA here ", Q.EXP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ----
set HDR-NFA here ", Q.SQRT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ----
set HDR-NFA here ", Q.LOG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", Q.SIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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)
set HDR-NFA here ", Q.COS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", Q.PRINT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
capsules/v4/sys/quit.f18
+585
View File
@@ -0,0 +1,585 @@
\ 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
set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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).
set HDR-NFA here ", NEIGHBOUR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", DEFAULT-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", GONE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", AWAIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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).
set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (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.
set HDR-NFA here ", NODE-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NODE-ERROR' NODE-ERROR ;
set HDR-NFA here ", (ME) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (ME)' (ME) ;
set HDR-NFA here ", (CONSOLE) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (CONSOLE)' (CONSOLE) ;
set HDR-NFA here ", (LOST) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ;
set HDR-NFA here ", (REFUSED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ;
set HDR-NFA here ", (WORD-DEFINED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ;
set HDR-NFA here ", (WORD-FORGOTTEN) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
set HDR-NFA here ", QUIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (.")
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.
set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (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.
set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (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.
set HDR-NFA here ", S" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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@
capsules/v4/sys/system.f18
+170
View File
@@ -0,0 +1,170 @@
\ 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
set HDR-NFA here ", FENCE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 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.
set HDR-NFA here ", CONTEXT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CONTEXT' CONTEXT ;
set HDR-NFA here ", CURRENT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
set HDR-NFA here ", FORTH #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FORTH (LATEST) CONTEXT a! ! ;
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
set HDR-NFA here ", DEFINITIONS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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! ! ;
set HDR-NFA here ", VOCABULARY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", ORDER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", WORDS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", VLIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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").
set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.)
set HDR-NFA here ", 79-STANDARD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 79-STANDARD ;
\ ( -- ) which system this is, and its cell width
set HDR-NFA here ", VERSION #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", PAGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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
set HDR-NFA here ", WARM #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", DEFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
: (is!) a! ! ;
: (defer@) a! @ ;
set HDR-NFA here ", IS #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IS
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
NOW: drop jump (is!)
set HDR-NFA here ", DEFER@ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER@
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
NOW: drop jump (defer@)
capsules/v4/sys/words.f18
+201
View File
@@ -0,0 +1,201 @@
\ 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 ----
set HDR-NFA here ", 2SWAP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
set HDR-NFA here ", 2OVER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
set HDR-NFA here ", 2ROT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
set HDR-NFA here ", 2>R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2>R SWAP push push ;
set HDR-NFA here ", 2R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R> pop pop SWAP ;
set HDR-NFA here ", 2R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R@ pop pop over over push push SWAP ;
set HDR-NFA here ", NOP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOP' nop ;
set HDR-NFA here ", TRUE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TRUE -1 ;
set HDR-NFA here ", FALSE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FALSE 0 ;
set HDR-NFA here ", INVERT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
\ ---- memory ----
set HDR-NFA here ", 2@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2@ ( addr -- lo hi ) a! @+ @ ;
set HDR-NFA here ", 2! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
set HDR-NFA here ", -! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -! ( n addr -- ) a! NEGATE @ + ! ;
\ ---- comparison ----
set HDR-NFA here ", 0<> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0<> if Z drop -1 ; Z: ;
set HDR-NFA here ", 0> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
set HDR-NFA here ", <> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <> xor jump 0<>
set HDR-NFA here ", <= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <= GREATER jump 0=
set HDR-NFA here ", >= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >= LESS jump 0=
set HDR-NFA here ", U< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U< over over xor -if SAME drop NIP jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", U> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U> SWAP jump U<
set HDR-NFA here ", ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABS -if P inv 1 + P: ;
set HDR-NFA here ", MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
set HDR-NFA here ", MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
set HDR-NFA here ", WITHIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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").
set HDR-NFA here ", LSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", RSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ----
set HDR-NFA here ", D- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D- DNEGATE jump D+
set HDR-NFA here ", DABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DABS -if P jump DNEGATE P: ;
set HDR-NFA here ", D0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0= OR jump 0=
set HDR-NFA here ", D0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0< push drop pop jump 0<
set HDR-NFA here ", D= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D= D- jump D0=
set HDR-NFA here ", D2* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
set HDR-NFA here ", D2/ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2/ push a! 0 pop +* push drop a pop ;
set HDR-NFA here ", M+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M+ S>D jump D+
set HDR-NFA here ", M- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", D< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D< (D<) push drop drop drop drop pop ;
set HDR-NFA here ", DMAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
set HDR-NFA here ", DMIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
\ ---- strings and memory ----
set HDR-NFA here ", ?TERMINAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
set HDR-NFA here ", CMOVE> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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.
set HDR-NFA here ", MOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", FILL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", ERASE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ERASE ( baddr u -- ) 0 jump FILL
set HDR-NFA here ", BLANK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BLANK ( baddr u -- ) 32 jump FILL
set HDR-NFA here ", -TRAILING #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -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: ;
set HDR-NFA here ", COMPARE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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: ;
set HDR-NFA here ", SEARCH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", SCAN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
set HDR-NFA here ", SKIP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 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 ;
v4/Makefile
+11 -1
View File
@@ -114,7 +114,11 @@ ROM_DIR := $(ROOT)/capsules/v4/rom
ROM_FILES := $(wildcard $(addprefix $(ROM_DIR)/,main.f18 in.f18 num.f18 sym.f18 pack.f18 word.f18 dir.f18))
MKROM_WORDS := $(shell expr $(HOST_WORDS) + $(HOST_ROM_WORDS))
rom_src = $(if $(findstring /test_host_rom_,$(1)),$(BINDIR)/rom-$(2).c)
rom_sym = $(if $(findstring /test_host_rom_,$(1)),-DV4_ROM_SYM='"$(BINDIR)/rom-$(2).sym"')
rom_sym = $(if $(findstring /test_host_rom_,$(1)),-DV4_ROM_SYM='"$(BINDIR)/rom-$(2).sym"' -DV4_SYS_DIR='"$(SYS_DIR)"')
# THE SYSTEM'S SOURCE as the ROM reads it (MACHINE.md 3): capsules/v4/sys. Its
# map, map-<width>.f18, is written by tools/mkmap.c from tests/host_map.h
# (`make sysmap`) and kept in the tree, as capsules/BLOCK_MAP.md is.
SYS_DIR := $(ROOT)/capsules/v4/sys
define ROM_RULE
$(BINDIR)/mkmap-$(1): $(HERE)/tools/mkmap.c $$(SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/tests/host_map.h $(HERE)/Makefile
@@ -124,6 +128,9 @@ $(BINDIR)/mkmap-$(1): $(HERE)/tools/mkmap.c $$(SRCS) $$(wildcard $(HERE)/include
$(BINDIR)/rom-map-$(1).f18: $(BINDIR)/mkmap-$(1)
$(BINDIR)/mkmap-$(1) > $$@
$(SYS_DIR)/map-$(1).f18: $(BINDIR)/mkmap-$(1)
$(BINDIR)/mkmap-$(1) sys > $$@
$(BINDIR)/mkrom-$(1): $(HERE)/tools/mkrom.c $$(SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/Makefile
@mkdir -p $(BINDIR)
$$(CC) $$(CFLAGS) -I$(HERE)/include -DV4_CELL_BITS=$(1) -DV4_NODE_WORDS=$(MKROM_WORDS) -DV4_DATA_RING=$(HOST_DATA_RING) -DV4_RET_RING=$(HOST_RET_RING) \
@@ -137,6 +144,9 @@ $(foreach w,$(WIDTHS),$(eval $(call ROM_RULE,$(w))))
.PHONY: rom
rom: $(foreach w,$(WIDTHS),$(BINDIR)/rom-$(w).c)
.PHONY: sysmap
sysmap: $(foreach w,$(WIDTHS),$(SYS_DIR)/map-$(w).f18)
define IMAGE_RULE
$(BINDIR)/mkimage-$(1): $(HERE)/tools/mkimage.c $$(SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/tests/host_map.h $(HERE)/Makefile
@mkdir -p $(BINDIR)
v4/tests/host_map.h
+125 -115
View File
@@ -114,7 +114,10 @@
#define ROM_PI (BUF0_W - 122) /* working cells */
#define ROM_RS (BUF0_W - 121)
#define ROM_RN (BUF0_W - 120)
/* FREE, plain memory: BUF0_W - 22 .. - 21; - 119 .. - 113; BUF0_W - 144 .. - 141 (what a flush makes zero after
/* THE IMAGE RECORD: where the system's source says, with `store`, the addresses a host needs (v4/image.h): where the
* node waits for a message, its fault table, and KEY's code. */
#define ROM_IMG (BUF0_W - 119) /* idle, fault table, KEY, the word after KEY: 4 cells */
/* FREE, plain memory: BUF0_W - 22 .. - 21; - 115 .. - 113; BUF0_W - 144 .. - 141 (what a flush makes zero after
* a full output buffer); and OUT_W - 144 .. OUT_W - 65. They and
* the cells above held the messages waiting, the refusals owed and what went with them (MESH.md 7a, 7b), which a
* node no longer keeps. */
@@ -261,6 +264,124 @@ static unsigned host_branch_slots(void)
* assemble the `count` files named. Returns 1 if all assembled; otherwise
* prints which did not and why. The caller may assemble more text and must
* call v4_text_finish. */
/* THE CONSTANTS the system's source is assembled with: names for the addresses and numbers of this map. One
* list, read by host_load (here) and by tools/mkmap.c, which writes it as the system's map blob for the ROM. */
#define HOST_CONSTANTS(X) \
X("N-1", V4_CELL_BITS - 1) \
X("NODE-ERROR", NODE_ERROR) \
X("CONSOLE-TX", CONSOLE_TX) \
X("CONSOLE-RX", CONSOLE_RX) \
X("CONSOLE-STATUS", CONSOLE_ST) \
X("BASE", BASE) \
X("TIB", TIB) \
X(">IN", TO_IN) \
X("SPAN", SPAN) \
X("WBUF", WBUF) \
X("(P)", PVARS) \
X("DP", DP) \
X("(LATEST)", LATEST) \
X("DBASE", DICT_W * 4) \
X("DLIMIT", DICT_END_W * 4) \
X("PAD", PAD) \
X("(D)", DVARS) \
X("(CG)", CGVARS) \
X("CG-BSLOTS", (v4_cell)host_branch_slots()) \
X("STATE", STATE) \
X("(C)", CVARS) \
X("(CFP)", CFP) \
X("(Q)", QVARS) \
X("(F)", FVARS) \
X("(S)", SVARS) \
X("(W)", WVARS) \
X("(X)", XVARS) \
X("(BOOT)", BOOT_CELLS) \
X("(LOG-LEVEL)", LOG_LEVEL) \
X("(ACL-HOOK)", ACL_HOOK) \
X("SCR", SCR) \
X("BLK", BLK) \
X("(SRC)", SRC) \
X("(SRC-HOOK)", SRC_HOOK) \
X("(LINE-STATUS)", LINE_STATUS) \
X("(PORT)", PORT) \
X("(ME)", ME) \
X("(CONSOLE)", CONSOLE) \
X("(ROUTE#)", ROUTE_COUNT) \
X("(ROUTE-DEFAULT)", ROUTE_DEFAULT) \
X("(LOST)", LOST) \
X("(PRINT-TO)", PRINT_TO) \
X("(PRINT-PORT)", PRINT_PORT) \
X("(DONE-PORT)", DONE_PORT) \
X("(ROUTES)", ROUTES) \
X("-PORTS", -(v4_cell)V4_PORTS) \
X("(NEAR)", NEAR) \
X("(AWAIT-FROM)", AWAIT_FROM) \
X("(WIRE)", WIRE) \
X("(WIRE-A)", WIRE_A) \
X("(WIRE-B)", WIRE_B) \
X("(WIRE-DO)", WIRE_DO) \
X("(WIRE-HOW)", WIRE_HOW) \
X("(WIRE-HAVE)", WIRE_HAVE) \
X("(S-HAVE)", S_HAVE) \
X("(S-MASK)", S_MASK) \
X("(S-WIRE)", S_WIRE) \
X("(S-ON)", S_ON) \
X("(KEEP)", KEEP) \
X("(DEFER)", DEFER) \
X("(D-MASK)", D_MASK) \
X("(IN)", IN_HDR) \
X("(ONE)", ONE) \
X("(OUT-HDR)", OUT_HDR) \
X("(W-NEED)", W_NEED) \
X("(W-PORT)", W_PORT) \
X("(P-WAY)", P_WAY) \
X("(P-NEED)", P_NEED) \
X("(H-PORT)", H_PORT) \
X("(H-NEED)", H_NEED) \
X("(H-MASK)", H_MASK) \
X("(A-SELF)", A_SELF) \
X("(SEND^)", SEND_PTR) \
X("(OUT-TEXT)", OUT_TEXT) \
X("(SEND-TEXT)", SEND_TEXT) \
X("(QUIET)", QUIET) \
X("(REFUSED)", REFUSED) \
X("(OUT^)", OUT_PTR) \
X("(REPLY)", REPLY) \
X("(MSG)", MSG) \
X("(OUT)", OUT_W) \
X("(WORD-DEFINED)", WORD_DEFINED) \
X("(WORD-FORGOTTEN)", WORD_FORGOTTEN) \
X("BLOCK#", V4_REQ_BLOCK) /* the kernel's block requests (v4/blocks.h) */ \
X("BUFFER#", V4_REQ_BUFFER) \
X("UPDATE#", V4_REQ_UPDATE) \
X("SAVE-BUFFERS#", V4_REQ_SAVE_BUFFERS) \
X("EMPTY-BUFFERS#", V4_REQ_EMPTY_BUFFERS) \
X("(Q/)", QBASE) /* 5 cells */ \
X("(QE)", QBASE + 5) /* 8 */ \
X("(QR)", QBASE + 13) /* 5 */ \
X("(QL)", QBASE + 18) /* 7 */ \
X("(QT)", QBASE + 25) /* 6 */ \
X("(QP)", QBASE + 31) /* 4 */ \
X("(DP)", QBASE + 35) /* 4 */ \
X("ADDR-DIGITS", V4_CELL_BITS / 4) \
X("MSB", (v4_cell)V4_MSB) \
X("MAXHI", (v4_cell)(V4_MSB - 1u)) \
X("HIMASK", (v4_cell)(((v4_ucell)1 << (V4_CELL_BITS - 16)) - 1u)) \
X("2N+15", 2 * V4_CELL_BITS + 15) \
X("N-18", V4_CELL_BITS - 18) \
X("N-17", V4_CELL_BITS - 17) \
X("MAX-INT", (v4_cell)(V4_MSB - 1u)) \
X("HLD", HLD) \
X("FENCE", FENCE) \
X("CONTEXT", CONTEXT) \
X("CURRENT", CURRENT) \
X("VOC-LINK", VOC_LINK) \
X("HEND", HEND) \
X("-HFLOOR", -(HEND - 62)) \
X("DSTACK-DEPTH", DSTACK_REG) \
X("RSTACK-DEPTH", RSTACK_REG) \
X("CFBASE", CFS_W) \
X("CFEND", CFS_W + CFS_CELLS)
static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned count)
{
char path[512];
@@ -269,121 +390,10 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
v4_node_reset(n);
HOST_MESSAGES_EMPTY(n); /* nothing has been printed and no message waits (core.v4) */
v4_text_begin(tx, n, 16);
v4_text_constant(tx, "N-1", V4_CELL_BITS - 1);
v4_text_constant(tx, "NODE-ERROR", NODE_ERROR);
v4_text_constant(tx, "CONSOLE-TX", CONSOLE_TX);
v4_text_constant(tx, "CONSOLE-RX", CONSOLE_RX);
v4_text_constant(tx, "CONSOLE-STATUS", CONSOLE_ST);
v4_text_constant(tx, "BASE", BASE);
v4_text_constant(tx, "TIB", TIB);
v4_text_constant(tx, ">IN", TO_IN);
v4_text_constant(tx, "SPAN", SPAN);
v4_text_constant(tx, "WBUF", WBUF);
v4_text_constant(tx, "(P)", PVARS);
v4_text_constant(tx, "DP", DP);
v4_text_constant(tx, "(LATEST)", LATEST);
v4_text_constant(tx, "DBASE", DICT_W * 4);
v4_text_constant(tx, "DLIMIT", DICT_END_W * 4);
v4_text_constant(tx, "PAD", PAD);
v4_text_constant(tx, "(D)", DVARS);
v4_text_constant(tx, "(CG)", CGVARS);
v4_text_constant(tx, "CG-BSLOTS", (v4_cell)host_branch_slots());
v4_text_constant(tx, "STATE", STATE);
v4_text_constant(tx, "(C)", CVARS);
v4_text_constant(tx, "(CFP)", CFP);
v4_text_constant(tx, "(Q)", QVARS);
v4_text_constant(tx, "(F)", FVARS);
v4_text_constant(tx, "(S)", SVARS);
v4_text_constant(tx, "(W)", WVARS);
v4_text_constant(tx, "(X)", XVARS);
v4_text_constant(tx, "(BOOT)", BOOT_CELLS);
v4_text_constant(tx, "(LOG-LEVEL)", LOG_LEVEL);
v4_text_constant(tx, "(ACL-HOOK)", ACL_HOOK);
v4_text_constant(tx, "SCR", SCR);
v4_text_constant(tx, "BLK", BLK);
v4_text_constant(tx, "(SRC)", SRC);
v4_text_constant(tx, "(SRC-HOOK)", SRC_HOOK);
v4_text_constant(tx, "(LINE-STATUS)", LINE_STATUS);
v4_text_constant(tx, "(PORT)", PORT);
v4_text_constant(tx, "(ME)", ME);
v4_text_constant(tx, "(CONSOLE)", CONSOLE);
v4_text_constant(tx, "(ROUTE#)", ROUTE_COUNT);
v4_text_constant(tx, "(ROUTE-DEFAULT)", ROUTE_DEFAULT);
v4_text_constant(tx, "(LOST)", LOST);
v4_text_constant(tx, "(PRINT-TO)", PRINT_TO);
v4_text_constant(tx, "(PRINT-PORT)", PRINT_PORT);
v4_text_constant(tx, "(DONE-PORT)", DONE_PORT);
v4_text_constant(tx, "(ROUTES)", ROUTES);
v4_text_constant(tx, "-PORTS", -(v4_cell)V4_PORTS);
v4_text_constant(tx, "(NEAR)", NEAR);
v4_text_constant(tx, "(AWAIT-FROM)", AWAIT_FROM);
v4_text_constant(tx, "(WIRE)", WIRE);
v4_text_constant(tx, "(WIRE-A)", WIRE_A);
v4_text_constant(tx, "(WIRE-B)", WIRE_B);
v4_text_constant(tx, "(WIRE-DO)", WIRE_DO);
v4_text_constant(tx, "(WIRE-HOW)", WIRE_HOW);
v4_text_constant(tx, "(WIRE-HAVE)", WIRE_HAVE);
v4_text_constant(tx, "(S-HAVE)", S_HAVE);
v4_text_constant(tx, "(S-MASK)", S_MASK);
v4_text_constant(tx, "(S-WIRE)", S_WIRE);
v4_text_constant(tx, "(S-ON)", S_ON);
v4_text_constant(tx, "(KEEP)", KEEP);
v4_text_constant(tx, "(DEFER)", DEFER);
v4_text_constant(tx, "(D-MASK)", D_MASK);
v4_text_constant(tx, "(IN)", IN_HDR);
v4_text_constant(tx, "(ONE)", ONE);
v4_text_constant(tx, "(OUT-HDR)", OUT_HDR);
v4_text_constant(tx, "(W-NEED)", W_NEED);
v4_text_constant(tx, "(W-PORT)", W_PORT);
v4_text_constant(tx, "(P-WAY)", P_WAY);
v4_text_constant(tx, "(P-NEED)", P_NEED);
v4_text_constant(tx, "(H-PORT)", H_PORT);
v4_text_constant(tx, "(H-NEED)", H_NEED);
v4_text_constant(tx, "(H-MASK)", H_MASK);
v4_text_constant(tx, "(A-SELF)", A_SELF);
v4_text_constant(tx, "(SEND^)", SEND_PTR);
v4_text_constant(tx, "(OUT-TEXT)", OUT_TEXT);
v4_text_constant(tx, "(SEND-TEXT)", SEND_TEXT);
v4_text_constant(tx, "(QUIET)", QUIET);
v4_text_constant(tx, "(REFUSED)", REFUSED);
v4_text_constant(tx, "(OUT^)", OUT_PTR);
v4_text_constant(tx, "(REPLY)", REPLY);
v4_text_constant(tx, "(MSG)", MSG);
v4_text_constant(tx, "(OUT)", OUT_W);
v4_text_constant(tx, "(WORD-DEFINED)", WORD_DEFINED);
v4_text_constant(tx, "(WORD-FORGOTTEN)", WORD_FORGOTTEN);
v4_text_constant(tx, "BLOCK#", V4_REQ_BLOCK); /* the kernel's block requests (v4/blocks.h) */
v4_text_constant(tx, "BUFFER#", V4_REQ_BUFFER);
v4_text_constant(tx, "UPDATE#", V4_REQ_UPDATE);
v4_text_constant(tx, "SAVE-BUFFERS#", V4_REQ_SAVE_BUFFERS);
v4_text_constant(tx, "EMPTY-BUFFERS#", V4_REQ_EMPTY_BUFFERS);
v4_text_constant(tx, "(Q/)", QBASE); /* 5 cells */
v4_text_constant(tx, "(QE)", QBASE + 5); /* 8 */
v4_text_constant(tx, "(QR)", QBASE + 13); /* 5 */
v4_text_constant(tx, "(QL)", QBASE + 18); /* 7 */
v4_text_constant(tx, "(QT)", QBASE + 25); /* 6 */
v4_text_constant(tx, "(QP)", QBASE + 31); /* 4 */
v4_text_constant(tx, "(DP)", QBASE + 35); /* 4 */
v4_text_constant(tx, "ADDR-DIGITS", V4_CELL_BITS / 4);
v4_text_constant(tx, "MSB", (v4_cell)V4_MSB);
v4_text_constant(tx, "MAXHI", (v4_cell)(V4_MSB - 1u));
v4_text_constant(tx, "HIMASK", (v4_cell)(((v4_ucell)1 << (V4_CELL_BITS - 16)) - 1u));
v4_text_constant(tx, "2N+15", 2 * V4_CELL_BITS + 15);
v4_text_constant(tx, "N-18", V4_CELL_BITS - 18);
v4_text_constant(tx, "N-17", V4_CELL_BITS - 17);
v4_text_constant(tx, "MAX-INT", (v4_cell)(V4_MSB - 1u));
v4_text_constant(tx, "HLD", HLD);
v4_text_constant(tx, "FENCE", FENCE);
v4_text_constant(tx, "CONTEXT", CONTEXT);
v4_text_constant(tx, "CURRENT", CURRENT);
v4_text_constant(tx, "VOC-LINK", VOC_LINK);
v4_text_constant(tx, "HEND", HEND);
v4_text_constant(tx, "-HFLOOR", -(HEND - 62));
v4_text_constant(tx, "DSTACK-DEPTH", DSTACK_REG);
v4_text_constant(tx, "RSTACK-DEPTH", RSTACK_REG);
#define HOST_CONSTANT(name, value) v4_text_constant(tx, name, (v4_cell)(value));
HOST_CONSTANTS(HOST_CONSTANT)
#undef HOST_CONSTANT
v4_node_stack_regs_attach(n, DSTACK_REG, RSTACK_REG);
v4_text_constant(tx, "CFBASE", CFS_W);
v4_text_constant(tx, "CFEND", CFS_W + CFS_CELLS);
for (i = 0; i < count; i++) {
snprintf(path, sizeof path, "%s/%s", V4_CAPSULE_DIR, files[i]);
if (!v4_text_assemble_file(tx, path)) {
v4/tests/test_host_rom_nucleus.c
+141
View File
@@ -0,0 +1,141 @@
/* test_host_rom_nucleus.c -- the proof: the ROM rebuilds today's nucleus, word for word.
*
* Plan Task 8; MACHINE.md section 6, step 1. Node A is built as
* v4/tools/mkimage.c builds the nucleus: text.c assembles v4/capsule/ *.v4,
* then the switch-on state is set in C. Node B is the machine with its ROM,
* fed the system's blobs -- capsules/v4/sys/map-<width>.f18, the fourteen
* .f18 files made from the .v4 ones, and end.f18 -- through the console.
* When the ROM starts the system, every word of B's RAM must be A's, except
* the ROM's own state area and the image record (which A does not have, and
* which must hold A's addresses). It also reports what the assembly cost:
* instructions retired and seconds (Captain Bob: watch the startup cost).
*/
#include "rom_harness.h"
#include "v4/text.h"
#include <stdlib.h>
#include <time.h>
static int failures = 0, checks = 0;
#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0)
static v4_node a, b;
static v4_text tx;
static const char *const files[] = { "core", "input", "dict", "codegen", "compile", "quit", "forth",
"numout", "words", "system", "qmath", "blocks", "log", "acl" };
/* node A: mkimage.c's main, as it is */
static int build_a(void)
{
static const char *const v4files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4",
"numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4", "log.v4", "acl.v4" };
v4_cell k;
if (!host_load(&tx, &a, v4files, 14) || !v4_text_finish(&tx)) return 0;
a.mem[DP] = DICT_W * 4;
a.mem[LATEST] = v4_text_latest(&tx);
a.mem[STATE] = 0;
a.mem[CFP] = CFS_W;
a.mem[BASE] = 10;
a.mem[FENCE] = DICT_W;
a.mem[LOG_LEVEL] = 2;
a.mem[CONTEXT] = LATEST;
a.mem[CURRENT] = LATEST;
a.mem[SRC] = TIB;
a.mem[BOOT_CELLS] = a.mem[DP];
a.mem[BOOT_CELLS + 1] = a.mem[LATEST];
a.mem[FENCE] = (a.mem[DP] + 3) / 4;
a.mem[NODE_ERROR] = 0;
a.mem[BLK] = 0; a.mem[SCR] = 0; a.mem[SRC] = TIB; a.mem[SRC_HOOK] = 0;
for (k = BVARS; k < BVARS + 6; k++) a.mem[k] = 0;
for (k = BUF0_W; k < BUF0_W + (v4_cell)(V4_BLOCK_SLOTS * V4_BLOCK_CELLS); k++) a.mem[k] = 0;
for (k = TIB_W; k < TIB_W + 260; k++) a.mem[k] = 0;
for (k = WBUF_W; k < WBUF_W + WBUF_CELLS; k++) a.mem[k] = 0;
for (k = PAD_W; k < PAD_W + 21; k++) a.mem[k] = 0;
a.mem[TO_IN] = 0; a.mem[SPAN] = 0;
a.mem[LINE_STATUS] = 1;
HOST_MESSAGES_EMPTY(&a);
return 1;
}
/* the ROM's own cells, and the image record: not compared */
static int excluded(v4_cell w)
{
return (w >= OUT_W - 144 && w < OUT_W - 64)
|| (w >= BUF0_W - 32 && w < BUF0_W - 22)
|| (w >= BUF0_W - 122 && w < BUF0_W - 119)
|| (w >= ROM_IMG && w < ROM_IMG + 4);
}
static char *slurp(const char *name, size_t *len)
{
char path[512];
FILE *f;
char *t;
long n;
snprintf(path, sizeof path, "%s/%s", V4_SYS_DIR, name);
f = fopen(path, "rb");
if (!f) { printf(" cannot read %s\n", path); return NULL; }
fseek(f, 0, SEEK_END); n = ftell(f); fseek(f, 0, SEEK_SET);
t = malloc((size_t)n + 2);
if (fread(t, 1, (size_t)n, f) != (size_t)n) { fclose(f); free(t); return NULL; }
fclose(f);
t[n] = '\n'; t[n + 1] = 0; /* a blob that does not end with a new line still ends a token */
*len = (size_t)n + 1;
return t;
}
int main(void)
{
static char *text;
size_t total = 0, cap = 1u << 20, len, fed = 0;
char name[32];
unsigned i;
long words = 0;
clock_t t0, t1;
v4_cell w, idle_a;
CHECK(build_a(), "node A builds as mkimage.c builds it: %s", v4_text_error(&tx));
idle_a = v4_text_word(&tx, "(IDLE)");
/* the system's source, as the loader will feed it: map, the fourteen, end, EOT */
text = malloc(cap);
snprintf(name, sizeof name, "map-%d.f18", V4_CELL_BITS);
for (i = 0; i < 16; i++) {
char *t;
if (i == 0) t = slurp(name, &len);
else if (i <= 14) { char f18[32]; snprintf(f18, sizeof f18, "%s.f18", files[i - 1]); t = slurp(f18, &len); }
else t = slurp("end.f18", &len);
if (!t) { CHECK(0, "a blob is missing"); return 1; }
memcpy(text + total, t, len); total += len; free(t);
}
text[total++] = 4;
rom_boot(&b);
v4_node_stack_regs_attach(&b, DSTACK_REG, RSTACK_REG);
b.p = V4_ROM_BASE + 12;
t0 = clock();
while (b.p >= V4_ROM_BASE && words < 400000000L && !b.stopped) {
if (fed < total) fed += v4_node_console_feed(&b, text + fed, (unsigned)(total - fed));
(void)v4_exec_step_word(&b, &rom_es, &rom_h);
words++;
if (words % 1000 == 0 && rom_in(&b, "(ROM-FAILED)")) break;
}
t1 = clock();
CHECK(b.p < V4_ROM_BASE, "the ROM started the system: P %ld, failed %ld at line %ld", (long)b.p,
(long)b.mem[ROM_FAILED], (long)b.mem[ROM_ERRLINE] + 1);
printf(" the ROM assembled the system: %lu instructions, %lu instruction words, %.2f s (%d-bit cells)\n",
(unsigned long)rom_es.anticlock, (unsigned long)words, (double)(t1 - t0) / CLOCKS_PER_SEC, V4_CELL_BITS);
CHECK(b.p == idle_a, "it starts at (IDLE): %ld, mkimage's %ld", (long)b.p, (long)idle_a);
CHECK(b.mem[ROM_IMG] == idle_a && b.mem[ROM_IMG + 1] == v4_text_word(&tx, "(FAULTS)")
&& b.mem[ROM_IMG + 2] == v4_text_word(&tx, "KEY") && b.mem[ROM_IMG + 3] == v4_text_word(&tx, "CR"),
"the image record holds mkimage's addresses");
for (w = 0; w < (v4_cell)V4_NODE_WORDS; w++) {
if (excluded(w) || a.mem[w] == b.mem[w]) continue;
CHECK(0, "RAM word %ld: mkimage %lx, ROM %lx", (long)w, (unsigned long)a.mem[w], (unsigned long)b.mem[w]);
break;
}
CHECK(w == (v4_cell)V4_NODE_WORDS, "every word of RAM is the same");
printf("test_host_rom_nucleus: %d checks, %d failures\n", checks, failures);
return failures != 0;
}
v4/tools/mkmap.c
+18 -1
View File
@@ -1,6 +1,7 @@
/* mkmap.c -- the memory map, as constants the ROM is assembled with.
*
* mkmap > rom-map-<width>.f18
* mkmap sys > capsules/v4/sys/map-<width>.f18
*
* Runs on the build machine, built for the host node (HOST_WORDS and the
* host stack sizes) at one cell width. It writes, as `constant` lines in
@@ -17,10 +18,26 @@ static void constant(const char *name, long value)
printf("constant %s %ld\n", name, value);
}
int main(void)
/* `mkmap sys`: the system's map, the blob the ROM reads before the system's
* source (capsules/v4/sys/map-<width>.f18): every constant host_load gives
* the nucleus, and the two its end (capsules/v4/sys/end.f18) needs besides. */
static int system_map(void)
{
printf("\\ map-%d.f18 -- the memory map the system's source is assembled with, %d-bit cells.\n", V4_CELL_BITS, V4_CELL_BITS);
printf("\\ Generated by v4/tools/mkmap.c (mkmap sys) from v4/tests/host_map.h -- do not edit.\n");
#define SYS_CONSTANT(name, value) constant(name, (long)(v4_cell)(value));
HOST_CONSTANTS(SYS_CONSTANT)
#undef SYS_CONSTANT
constant("DICT-W", (long)DICT_W);
constant("(IMG)", (long)ROM_IMG);
return 0;
}
int main(int argc, char **argv)
{
(void)host_load; /* host_map.h's loader is not this tool's */
(void)host_branch_slots;
if (argc == 2 && argv[1][0] == 's') return system_map();
printf("\\ Generated by v4/tools/mkmap.c from v4/tests/host_map.h -- do not edit.\n");
constant("CONSOLE-RX", (long)CONSOLE_RX);
constant("CONSOLE-STATUS", (long)CONSOLE_ST);
v4/tools/v4tof18.py
+110
View File
@@ -0,0 +1,110 @@
#!/usr/bin/env python3
"""v4tof18.py -- turn the nucleus's .v4 sources into the system's .f18 blobs.
v4/tools/v4tof18.py
Run once (MACHINE.md step 2; plan Task 8): reads v4/capsule/*.v4 and writes
capsules/v4/sys/*.f18. Everything is kept token for token and line for
line except `header NAME flags :`, which text.c lays down itself and the
ROM's language says with its directives:
set HDR-NFA here ", NAME #, F #, HDR-NFA #, HDR-LINK set HDR-LINK here :
-- the name as a counted string, the flags (immediate 1, data 4, inline 8,
compile-only 16), the name's address and the link to the header before;
HDR-LINK is then the new entry's code address, as text.c's latest is. The
first file begins `set HDR-LINK 0`. The tokens are found as text.c's
next_token finds them: `\\` and `(` as whole tokens begin comments; a
header's name is the next run of characters, whatever they are.
"""
import os
import sys
ROOT = os.path.abspath(os.path.join(os.path.dirname(__file__), "..", ".."))
SRC = os.path.join(ROOT, "v4", "capsule")
OUT = os.path.join(ROOT, "capsules", "v4", "sys")
FILES = ["core", "input", "dict", "codegen", "compile", "quit", "forth", "numout",
"words", "system", "qmath", "blocks", "log", "acl"]
FLAGS = {"immediate": 1, "data": 4, "inline": 8, "compile-only": 16}
BLANK = " \t\r\n"
def tokens(text):
"""(token, start, end) for each token text.c's next_token would return,
and for each header its raw name."""
i, n = 0, len(text)
raw_next = False
while True:
while i < n and text[i] in BLANK:
i += 1
if i >= n:
return
j = i
while j < n and text[j] not in BLANK:
j += 1
tok = text[i:j]
if raw_next:
raw_next = False
yield tok, i, j
i = j
continue
if tok == "\\":
while j < n and text[j] != "\n":
j += 1
i = j
continue
if tok == "(":
k = text.find(")", j)
if k < 0:
sys.exit("comment not closed")
i = k + 1
continue
yield tok, i, j
if tok == "header":
raw_next = True
i = j
def convert(text, first):
out, last = [], 0
toks = list(tokens(text))
k = 0
while k < len(toks):
tok, s, e = toks[k]
if tok != "header":
k += 1
continue
name = toks[k + 1][0]
flags, m = 0, k + 2
while toks[m][0] != ":":
if toks[m][0] not in FLAGS:
sys.exit("header %s: %s is not a flag" % (name, toks[m][0]))
flags |= FLAGS[toks[m][0]]
m += 1
colon = toks[m][1]
span = text[s:colon]
directive = ('set HDR-NFA here ", %s #, %d #, HDR-NFA #, HDR-LINK set HDR-LINK here '
% (name, flags))
out.append(text[last:s])
out.append(directive + "\n" * span.count("\n"))
last = colon
k = m
out.append(text[last:])
body = "".join(out)
if first:
body = "set HDR-LINK 0 \\ the newest dictionary entry: none yet\n" + body
return body
def main():
os.makedirs(OUT, exist_ok=True)
for i, f in enumerate(FILES):
with open(os.path.join(SRC, f + ".v4")) as h:
text = h.read()
with open(os.path.join(OUT, f + ".f18"), "w") as h:
h.write(convert(text, i == 0))
print("v4tof18: %d files -> %s" % (len(FILES), OUT))
if __name__ == "__main__":
main()