rajames/LithosAnanke
1
1
Fork 0
Code Issues 62 Pull Requests 1 Actions 2 Packages Projects Releases 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
File diff suppressed because it is too large Load Diff
capsules/v4/sys/core.f18
+480
View File
File diff suppressed because it is too large Load Diff
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
File diff suppressed because it is too large Load Diff
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()