diff --git a/capsules/v4/sys/acl.f18 b/capsules/v4/sys/acl.f18 new file mode 100644 index 00000000..7c09c2d5 --- /dev/null +++ b/capsules/v4/sys/acl.f18 @@ -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) ; diff --git a/capsules/v4/sys/blocks.f18 b/capsules/v4/sys/blocks.f18 new file mode 100644 index 00000000..656f72b6 --- /dev/null +++ b/capsules/v4/sys/blocks.f18 @@ -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 diff --git a/capsules/v4/sys/codegen.f18 b/capsules/v4/sys/codegen.f18 new file mode 100644 index 00000000..de601a0c --- /dev/null +++ b/capsules/v4/sys/codegen.f18 @@ -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,) diff --git a/capsules/v4/sys/compile.f18 b/capsules/v4/sys/compile.f18 new file mode 100644 index 00000000..066439a0 --- /dev/null +++ b/capsules/v4/sys/compile.f18 @@ -0,0 +1,466 @@ +\ compile.v4 -- the interpreter's inner loop, and the defining and compiling +\ words. +\ +\ DECOMPOSITION.md 5.17 and 5.18: STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE +\ [COMPILE] ' EXECUTE CREATE VARIABLE CONSTANT DOES>, the control structures +\ IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP, and INTERPRET, +\ which they cannot be run without. Part of the compiler capsule. Rests on +\ core.v4, input.v4, dict.v4 and codegen.v4. +\ +\ HOW A WORD IS COMPILED. v4 code is native: a colon definition is +\ instruction words, and compiling a word into one lays down a call to it. +\ Two flags on an entry (dict.v4) change that: +\ inline its code is a straight run of opcodes and literals ending +\ in ; -- that run is copied in place of a call. Everything +\ that touches the return stack must be, since a call would +\ bury what it works on (DECOMPOSITION.md 0, fate IN). +\ compile-only it may not be executed by the interpreter. +\ An immediate word is executed even when compiling. +\ +\ THE STACKS ARE SHORT: written for ten cells of data and nine return entries +\ (D-2; the host node now has 32 of each, D-17), and one more of either is a +\ fault (D-16). The interpreter and compiler run on the same +\ stacks as the user's words, with the user's values beneath them, so: +\ - every word here keeps what it works on in (C), and has at most three +\ cells of its own on the data stack at any moment; +\ - what an IF or a DO leaves for its THEN or LOOP goes on a control-flow +\ stack in memory, not on the data stack, so structures may nest as +\ deep as that stack (32 cells) allows whatever the user has stacked. +\ +\ Constants the loader supplies: +\ STATE word address of the variable: non-zero while compiling +\ (C) word address of ten cells of scratch for this file: +\ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot +\ (C)+2 LATEST before a header is made (C)+3 a data word's routine +\ (C)+5 what a loop's end lays after its test +\ (C)+6 (C)+7 a branch and a tag a control word is holding +\ (C)+8 whether a data word's entry was made +\ (C)+9 the error code a line is being abandoned with +\ (CFP) word address of the control-flow stack's pointer +\ CFBASE CFEND word addresses of its first cell and of the cell past its last + +macro ROT push SWAP pop SWAP endmacro + +\ ---- errors ------------------------------------------------------------------ + +\ ( -- ) give up the line: stop compiling, forget the word being built and +\ whatever control structures were open, skip the rest of the input, and set +\ NODE-ERROR. A definition that was under way stays hidden. It returns to +\ whatever called INTERPRET, which is QUIT (quit.v4): QUIT sees NODE-ERROR +\ and prints ERROR. +\ (ABANDON-AS) is the same with an error code (core.v4) for the prompt to +\ print the message of. +: (ABANDON-AS) ( code -- ) + (C)+9 a! ! + 0 STATE a! ! (CG-RESET) + CFBASE (CFP) a! ! + SPAN a! @ >IN a! ! + (C)+9 a! @ NODE-ERROR b! !b ; +: (ABANDON) -1 jump (ABANDON-AS) + +\ ---- the control-flow stack ---------------------------------------------------- + +\ ( x -- ) push; a full stack abandons the line +: >CF + (CFP) a! @ CFEND xor if FULL + drop (CFP) a! @ dup 1 + ! a! ! ; + FULL: drop drop 8 jump (ABANDON-AS) \ control structures too deep + +\ ( -- x ) pop; 0 from an empty stack, which no opening word leaves +: CF> + (CFP) a! @ CFBASE xor if EMPTY + drop (CFP) a! @ -1 + dup ! a! @ ; + EMPTY: ; + +\ ---- compiling one word ------------------------------------------------------ + +\ ( w -- op ) the opcode in slot 0 of the instruction word w +: (TOP5) 8/ 8/ 8/ 2/ 2/ 2/ 31 and ; + +\ ( xt -- ) copy the in-line word at xt into the definition being built. +\ Each slot is read from the top of the word in (C)+0, which is then moved +\ up five bits for the next. +: (INLINE,) + W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it + 0 (C)+4 a! ! \ slot + S: (C) a! @ dup 2* 2* 2* 2* 2* ! (TOP5) \ op + if END \ ; ends the copy + dup -8 + if LIT + drop dup -28 + if NOP \ nop is padding + drop (OP,) + NXT: (C)+4 a! @ 1 + dup ! -6 + if NEXTW drop jump S + NEXTW: drop (C)+1 a! @ jump W \ the next instruction word follows the literals + LIT: drop drop (C)+1 a! @ dup 1 + ! a! @ (LIT,) jump NXT + NOP: drop drop jump NXT + END: drop ; + +\ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call +: (COMPILE,) + dup -3 + a! @ 8 and if CALL drop jump (INLINE,) + CALL: drop jump (CALL,) + +\ ---- access control (5.20) ------------------------------------------------------- +\ Each entry's flags cell also holds its access control fields: +\ bit 5 (32) denied: the word may not be used +\ bit 6 (64) pinned: the fields cannot be changed +\ bits 8 .. 15 the mode: 0 TTL, 1 STRICT +\ bits 16 .. 31 the TTL, a count of uses left before the next recheck +\ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0. +\ +\ (ACL?) is run by INTERPRET for every word it is about to execute or +\ compile. As v3: if the TTL is 0 the word is rechecked, otherwise the TTL +\ is counted down; then a denied word is refused. The recheck is the word +\ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded -- +\ and with none there the word is allowed and given the longest TTL. +\ +\ v3 checks every execution, inside definitions too. v4 code is native: a +\ compiled call goes straight to its word. So v4 checks a word when it is +\ compiled as well as when it is interpreted -- a denied word cannot be +\ built into anything new -- but a call compiled while the word was allowed +\ is not checked again. + +\ ( xt -- ) recheck +: (ACL-RECHECK) + (ACL-HOOK) a! @ if NONE push ex \ call it with the xt + ; + NONE: drop -3 + a! @ 65535 and -33 and $FFFF0000 + ! ; + +\ ( xt -- xt ) as above; a denied word ends the line +: (ACL?) + dup -3 + a! @ \ xt flags + dup $FFFF0000 and if ZERO + drop -65536 + ! jump TEST \ one use fewer + ZERO: drop drop dup (ACL-RECHECK) + TEST: dup -3 + a! @ 32 and if OK + drop drop + $33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) \ v3's line: WARN: in yellow + $3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4) + (.WORD) 39 EMIT CR + DSTACK-DEPTH b! a !b \ as v3, the stack is emptied + pop drop jump (ABANDON) + OK: drop ; + +\ ( -- ) print the word WORD has just left +: (.WORD) WBUF COUNT jump TYPE + +set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: EXECUTE ( xt -- ) push ; + +\ ---- the interpreter's inner loop --------------------------------------------- + +\ ( -- n flag ) the word WORD has just left, as a single-cell number in the +\ current BASE, and -1; or 0 0 if it is not one. A leading minus sign is +\ allowed. This is what the interpreter uses: NUMBER (input.v4) makes a +\ double and needs more of the stack than can be spared here. +\ (P)+2 the number so far, (P)+3 where it is in the word, (P)+4 the word's +\ length, (P)+5 the sign, (P)+6 the base. +: (NUM?) + WBUF C@ if EMPTY + (P)+4 a! ! 0 (P)+2 a! ! 1 (P)+3 a! ! 0 (P)+5 a! ! + (BASE) (P)+6 a! ! + WBUF+1 C@ -45 + if NEG drop jump DIGITS + NEG: drop -1 (P)+5 a! ! 2 (P)+3 a! ! + (P)+4 a! @ -1 + if EMPTY drop \ a sign alone + DIGITS: + L: (P)+4 a! @ (P)+3 a! @ - -if MORE + drop (P)+2 a! @ (P)+5 a! @ if POS drop NEGATE -1 ; + POS: drop -1 ; + MORE: drop + (P)+3 a! @ dup 1 + ! WBUF + C@ (DIGIT) \ d + -if DIGIT jump BAD1 + DIGIT: dup (P)+6 a! @ - -if BAD2 drop + (P)+2 a! @ (P)+6 a! @ STAR + (P)+2 a! ! + jump L + BAD2: drop + BAD1: drop 0 0 ; + EMPTY: drop 0 0 ; + +\ ( -- ) FORTH-79: take words from the input stream until it is exhausted. +\ A word in the dictionary is executed, or, when compiling and not immediate, +\ compiled. Anything else must be a number in the current BASE: it is left +\ on the stack, or compiled as a literal. What is neither, or a compile-only +\ word met while interpreting, abandons the line, with v3's message: +\ UNKNOWN WORD: 'xxx' xxx: compile-only +set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: INTERPRET + L: 32 WORD dup C@ if EOL + drop (LOOKUP) if NUM + dup -3 + a! @ \ xt flags + STATE a! @ if INTERP + drop 1 and if COMP \ compiling: immediate words still run + drop (ACL?) EXECUTE jump L + COMP: drop (ACL?) (COMPILE,) jump L + INTERP: drop 16 and if RUN + drop drop (.WORD) \ ": compile-only" + $6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR + jump (ABANDON) + RUN: drop (ACL?) EXECUTE jump L + NUM: drop (NUM?) if BAD + drop + STATE a! @ if KEEP drop (LIT,) jump L + KEEP: drop jump L + BAD: drop drop (UNKNOWN) drop jump (ABANDON) + EOL: drop drop ; + +\ ---- state --------------------------------------------------------------------- + +set HDR-NFA here ", [ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: LEFT-BRACKET 0 STATE a! ! ; +set HDR-NFA here ", ] #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: RIGHT-BRACKET -1 STATE a! ! ; + +\ ( x -- ) FORTH-79: if compiling, compile x as a literal +set HDR-NFA here ", LITERAL #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ; + +\ ( -- addr ) FORTH-79: the next word's parameter field address; if +\ compiling, compiled as a literal +set HDR-NFA here ", ' #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: TICK (') jump LITERAL + +\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL], +\ which v3 has as another name for LITERAL. +set HDR-NFA here ", ['] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: BRACKET-TICK (') jump (LIT,) +set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: BRACKET-LITERAL jump LITERAL + +\ ---- colon definitions ----------------------------------------------------------- + +\ FORTH-79: start a definition; it cannot be found until ; ends it. The +\ CONTEXT vocabulary is set to the CURRENT one. +\ (C)+2 holds LATEST while the entry is made, to tell whether one was. +set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: COLON + CURRENT a! @ CONTEXT a! ! + LATEST (C)+2 a! ! + 32 WORD (HEADER) + LATEST (C)+2 a! @ xor if NONE drop + HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET + NONE: drop jump (ABANDON) \ no entry: the rest of the line is not a definition + +\ FORTH-79: compile the return, let the word be found, stop compiling +set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: SEMICOLON + 0 (OP,) + LATEST (FLAGS) a! @ -3 and ! + jump LEFT-BRACKET + +\ ( n -- ) KERNEL-WORD xxx A WORD THAT ASKS THE KERNEL (docs/v4.0.0/ +\ ENGINE.md 3.3). xxx is made a word whose whole body is "write n to the +\ port": n is the number of a request, the port is the node's way to its +\ kernel, and the write blocks the node until the kernel has served it +\ (DECOMPOSITION.md section 6). xxx's arguments are whatever it finds on +\ the data stack and its results are what the kernel leaves there. This is +\ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a +\ node. Not FORTH-79 and not in v3, where such a word is registered from C. +\ The constant (PORT) is the port's word address. +set HDR-NFA here ", KERNEL-WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: KERNEL-WORD + COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b + jump SEMICOLON + +\ FORTH-79: return from the definition at this point +set HDR-NFA here ", EXIT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: EXIT 0 jump (OP,) + +set HDR-NFA here ", IMMEDIATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ; + +\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled +set HDR-NFA here ", COMPILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: COMPILE + 32 WORD (LOOKUP) if MISSING + (LIT,) &(COMPILE,) jump (CALL,) + MISSING: drop (UNKNOWN) drop jump (ABANDON) + +\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate +set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: BRACKET-COMPILE + 32 WORD (LOOKUP) if MISSING jump (COMPILE,) + MISSING: drop (UNKNOWN) drop jump (ABANDON) + +\ ---- data words --------------------------------------------------------------------- +\ A data word's code is one call to its run-time routine; the call leaves the +\ address of the cell after it -- the parameter field -- on the return stack. + +: (DOVAR) pop ; \ leave the parameter field address +: (DOCON) pop a! @ ; \ leave what it holds + +\ ( -- ) an entry for the next word, flagged data, its code a call to the +\ routine whose address is in (C)+3. (C)+8 is left -1 if one was made, else +\ 0. It ends by jumping, and CREATE jumps to it, so that a defining word +\ has as few return entries under it as can be. +: (DATA) + 0 (C)+8 a! ! + LATEST (C)+2 a! ! + 32 WORD (HEADER) + LATEST (C)+2 a! @ xor if NONE drop + (CG-RESET) + LATEST (FLAGS) a! @ 4 OR ! + -1 (C)+8 a! ! + (C)+3 a! @ jump (CALL,) + NONE: drop ; + +\ FORTH-79: an entry whose word leaves the address of its parameter field +set HDR-NFA here ", CREATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: CREATE &(DOVAR) (C)+3 a! ! jump (DATA) + +\ FORTH-79: CREATE and one cell. The standard leaves its first value to the +\ programme; here it is 0. +set HDR-NFA here ", VARIABLE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ; + +\ ( n -- ) FORTH-79: an entry whose word leaves n +set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ; + +\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become +\ what each word DEFINER makes does, starting with its parameter field address +\ on the stack. (DOES), run by DEFINER, turns the newest entry's code into a +\ call to the code after it and leaves DEFINER; that code starts with pop, +\ which fetches the parameter field address the call left. +: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0 +set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: DOES> &(DOES) (CALL,) 25 jump (OP,) + +\ ---- control structures (5.18, section 2) --------------------------------------------- +\ All immediate and compile-only. Each puts what the word that closes it +\ needs on the control-flow stack, with a number on top saying which word put +\ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO, 7 CASE, 8 OF. A closing word that +\ finds the wrong number abandons the line. + +\ ( tag wanted -- ) if they differ, abandon the line and leave the control +\ word that called this as well: its return address is dropped, so the +\ abandoning returns to the interpreter and nothing more is laid down. +: (PAIR) xor if OK drop pop drop 7 jump (ABANDON-AS) OK: drop ; + +\ ( ref -- ) the branch at ref lands here +: (HERE!) (FLUSH) HERE SWAP jump (RESOLVE) + +\ Native if leaves the flag, so both ways out of it drop it (section 2): +\ IF a THEN if L1 drop a jump L2 L1: drop L2: +\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2: +set HDR-NFA here ", IF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF +set HDR-NFA here ", ELSE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ELSE + CF> 1 (PAIR) CF> (C)+6 a! ! \ the if + 2 (BRANCH>) >CF \ the jump over the else part + (C)+6 a! @ (HERE!) 23 (OP,) + 2 jump >CF +set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: THEN + CF> dup -1 + if PLAIN + drop 2 (PAIR) CF> jump (HERE!) + PLAIN: drop drop + CF> (C)+6 a! ! \ the if + 2 (BRANCH>) >CF + (C)+6 a! @ (HERE!) 23 (OP,) + CF> jump (HERE!) + +\ A loop that tests at its end jumps back with the flag still there, so it +\ jumps back to a drop laid just ahead of the body: +\ BEGIN a UNTIL jump L0 Ld: drop L0: a if Ld drop +\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop +\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0 +\ The control-flow stack holds Ld, L0 and 3. +set HDR-NFA here ", BEGIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: BEGIN + 2 (BRANCH>) (C)+6 a! ! + (LABEL) >CF 23 (OP,) + (LABEL) dup >CF (C)+6 a! @ (RESOLVE) + 3 jump >CF +set HDR-NFA here ", UNTIL #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,) +set HDR-NFA here ", AGAIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ; +set HDR-NFA here ", WHILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF +set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: REPEAT + CF> 4 (PAIR) CF> (C)+6 a! ! \ the while + CF> 3 (PAIR) CF> (JUMP,) CF> drop + (C)+6 a! @ (HERE!) 23 jump (OP,) + +\ CASE: the value being chosen on stays on the stack through the clauses. +\ CASE x1 OF a ENDOF x2 OF b ENDOF c ENDCASE +\ lays, for each clause, +\ over xor if M drop jump N M: drop drop a jump END N: +\ and ENDCASE lays the drop that the part after the last ENDOF leaves the +\ value for, with END after it. The control-flow stack holds the jumps to +\ END, how many there are, and 7; inside a clause, the jump to N and 8. +: (of) over xor ; +set HDR-NFA here ", CASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: CASE 0 >CF 7 jump >CF +set HDR-NFA here ", OF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: OF + CF> 7 (PAIR) + &(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M + 23 (OP,) 2 (BRANCH>) >CF \ drop, jump N + (C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop + 8 jump >CF +set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ENDOF + CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N + CF> (C)+7 a! ! \ how many jumps to END so far + 2 (BRANCH>) >CF \ one more + (C)+7 a! @ 1 + >CF + (C)+6 a! @ (HERE!) \ N: + 7 jump >CF +set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ENDCASE + CF> 7 (PAIR) CF> (C)+7 a! ! + 23 (OP,) + L: (C)+7 a! @ if DONE -1 + ! + CF> (HERE!) jump L + DONE: drop ; + +\ DO loops: the limit and index are on the return stack, limit below (5.18). +: (do) over push push drop ; +: (?do) over over xor ; +: (inc) pop 1 + pop ; \ index' limit +: (+inc) dup a! pop + pop ; \ index' limit A: the step +: (differ) drop over ; +: (same) drop over over - ; +: (a-xor) a xor ; +: (again) drop push push ; +: (3drop) drop drop drop ; + +\ The end of a loop. The control-flow stack holds the body's address and 5, +\ or for ?DO its skip, the body and 6; (C)+5 holds the xt of in-line code to +\ lay after the test, or 0. Laid down, in order: +\ ( i' lim -- i' lim s ), the top bit of s set when i' < lim: +\ over over xor -if SAME drop over jump T SAME: drop over over - T: +\ the code in (C)+5, if any +\ -if EXIT drop push push jump BODY EXIT: drop drop drop +\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST: +\ It is one word, jumped to by LOOP and +LOOP, so that laying a loop's end +\ takes as few return entries as laying anything else. +: (LOOPS) + &(?do) (INLINE,) 7 (BRANCH>) >CF + &(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! ! + CF> (HERE!) &(same) (INLINE,) + (C)+6 a! @ (HERE!) + (C)+5 a! @ if NOMORE (INLINE,) jump TESTED + NOMORE: drop + TESTED: + CF> (C)+7 a! ! \ the tag + 7 (BRANCH>) (C)+6 a! ! + &(again) (INLINE,) CF> (JUMP,) + (C)+6 a! @ (HERE!) &(3drop) (INLINE,) + (C)+7 a! @ -5 + if PLAIN + drop (C)+7 a! @ 6 (PAIR) + 2 (BRANCH>) (C)+6 a! ! + CF> (HERE!) &(3drop) (INLINE,) + (C)+6 a! @ jump (HERE!) + PLAIN: drop ; + +set HDR-NFA here ", DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF +set HDR-NFA here ", ?DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF +set HDR-NFA here ", LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS) +set HDR-NFA here ", +LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS) diff --git a/capsules/v4/sys/core.f18 b/capsules/v4/sys/core.f18 new file mode 100644 index 00000000..4e04d5f5 --- /dev/null +++ b/capsules/v4/sys/core.f18 @@ -0,0 +1,480 @@ +set HDR-LINK 0 \ the newest dictionary entry: none yet +\ core.v4 -- the core words the host-node capsules rest on. +\ +\ Each is the definition DECOMPOSITION.md gives and the golden-model tests +\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c), +\ written here as text for the text assembler (v4/include/v4/text.h). +\ +\ Constants the loader supplies: N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX, +\ CONSOLE-RX, CONSOLE-STATUS, BASE, (MSG), (REPLY), (ME), (OUT), +\ (OUT^), (CONSOLE), (ROUTES), (ROUTE#), (ROUTE-DEFAULT), (PRINT-TO), +\ (PRINT-PORT). +\ +\ ERRORS (D-18). A word that finds an error takes its arguments off the stack +\ and stores a code in NODE-ERROR. On a node with a prompt that store is a +\ trap: the word goes no further, and the prompt prints the message for the +\ code and ERROR (quit.v4, (RAISED)). The codes: +\ 1 Negative count 2 Not a number 3 Number too long +\ 4 Not a character 5 Dictionary full 6 Name missing +\ 7 Control structure mismatch 8 Control structures too deep +\ 9 Shift count out of range 10 Protected word +\ 11 Division by zero (Q./) 12 Argument out of range +\ 13 Block out of range 14 No block is being loaded +\ 15 Deferred word not set 16 Not a word +\ 17 Storage refused 18 No one on that port +\ 19 Message refused 20 Node gone +\ 21 Interrupted +\ -1 the word has printed its own message + +macro SWAP over push push drop pop pop endmacro +macro - push inv pop + inv endmacro \ x y -- x-y +macro NEGATE inv 1 + endmacro +macro NIP push drop pop endmacro + +\ ---- section 4: multiply ------------------------------------------------ +set HDR-NFA here ", UM* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: UM* ( u1 u2 -- ulo uhi ) + over 1 and inv 1 + over 2/ and \ u1 u2 t0 t0 = u2 2/ if u1 odd + over a! N-1 push \ A: u2 R: loop count + push over 2/ pop \ u1 u2 s t0 s = u1 2/ + L: +* unext \ u1 u2 s hi A: lo + push drop pop \ u1 u2 hi + 2* a -if L0 drop 1 + jump L1 L0: drop L1: push + over -if L2 drop dup jump L3 L2: drop 0 L3: push + dup -if L4 drop over 1 and jump L5 L4: drop 0 L5: + pop + pop + push + and 1 and a 2* + pop ; + +\ ---- section 5.7: doubles ------------------------------------------------ +set HDR-NFA here ", D+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: D+ ( d1 d2 -- d3 ) + push over push push drop pop \ al bl R: bh ah + over over xor -if L1 + drop + -if C1 jump C0 + L1: drop over -if L2 + drop + jump C1 + L2: drop + + C0: pop pop + ; + C1: pop pop + 1 + ; + +set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: DNEGATE ( d -- -d ) + inv over if L1 drop push inv 1 + pop ; + L1: drop 1 + ; + +\ ---- section 5.3: bytes -------------------------------------------------- +\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has +\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and +\ C! are at the bottom of every chain of calls in the compiler capsule, where +\ there is not an entry to spare (D-2). The result is the same. +macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro +macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro + +set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: C@ ( baddr -- c ) + dup 2/ 2/ a! 3 and + if K0 -1 + if K1 -1 + if K2 + drop @ 8/ 8/ 8/ 255 and ; + K2: drop @ 8/ 8/ 255 and ; + K1: drop @ 8/ 255 and ; + K0: drop @ 255 and ; + +set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: C! ( c baddr -- ) + dup 2/ 2/ a! 3 and + if K0 -1 + if K1 -1 + if K2 + drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ; + K2: drop 8* 8* 16711680 and @ -16711681 and + ! ; + K1: drop 8* 65280 and @ -65281 and + ! ; + K0: drop 255 and @ -256 and + ! ; + +\ ---- section 5.9: strings ------------------------------------------------ +set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: CMOVE ( src dst u -- ) + -if OK drop drop drop NODE-ERROR b! 1 !b ; + OK: if DONE push + over C@ over C! 1 + push 1 + pop pop -1 + jump OK + DONE: drop drop drop ; + +\ ---- section 5.10: the console ------------------------------------------- +\ ---- what a node prints (docs/v4.0.0/MESH.md section 6) ------------------------ +\ A node has no console of its own. It does what a message asks, and what +\ it prints while doing it is sent as a message: to the node in (CONSOLE), or +\ if that is 0 to whoever sent the text; by the port that leads there, or if +\ this node knows of none, by the port the text came on. A message is seven words and then its text, four +\ characters to a word: +\ to, from, type, heat and TTL, ACL tag, sequence, length in characters +\ The types: 1 text to be interpreted 2 what a node printed 3 how the +\ text ended (one word of text: 0 QUIT, 1 completed, 2 an error). +\ The header of the text being served is in the seven cells (MSG); (REPLY) +\ is the port it came on, by its number; (ME) is this node's number. +\ +\ Characters are kept in (OUT), 256 of them, a character to a cell, and sent +\ when it is full and when the text has been done with (quit.v4). (OUT^) +\ is where the next goes. +\ +\ THE STACK. What prints may be run with the data stack all but full: EMIT +\ has always needed one free cell and no more, and still does -- it keeps +\ the character and A on the return stack while it works. Sending needs +\ three. + +\ FINDING THE WAY (MESH.md section 7). A node knows its ports and nothing of +\ the shape they are wired in. Whoever wires it tells it, for a node, which +\ port leads toward that node: the table (ROUTES), (ROUTE#) entries of a +\ node's number and a port's address; and (ROUTE-DEFAULT), the port for any +\ node that is not in the table, or 0. + +\ ( node -- port | -1 ) the port, by its number, that leads toward the node +: (WAY) + (ROUTE#) a! @ if NONE -1 + (ROUTES) a! + FOR dup @+ xor if HIT drop @+ drop NEXT + 0 + NONE: drop drop (ROUTE-DEFAULT) a! @ if NOWAY (PORT) - ; + NOWAY: drop -1 ; + HIT: drop drop @+ pop drop (PORT) - ; + +\ WHOLE MESSAGES (MESH.md section 7d). A message waits on a wire, in the +\ fabric, and not in a node: each wire has a queue of whole messages each +\ way. A node asks the fabric to look at one, take it, move it to another +\ wire, drop it, or put one on, by the six addresses after its ports: +\ (WIRE) the port, by its number, that what follows is about +\ (WIRE-A) (WIRE-B) what the operation needs +\ (WIRE-DO) the operation: a store here is the asking +\ (WIRE-HOW) how it went: 0 done, 1 no room, 2 no one on that port, +\ 3 no such message, 4 not a message +\ (WIRE-HAVE) which wires have a message waiting, a bit to a port +\ The operations: 1 look 2 take 3 move 4 drop 5 put 6 first 7 next +\ 8 sleep 9 sleep for room 10 room. Each is whole: all of a message +\ moves or none of it. So a fault or an error in the middle of anything +\ here leaves no message half moved; and nothing here keeps, from one +\ operation to the next, anything a later pass does not set again for +\ itself: every pass over a wire begins by naming the wire and putting its +\ mark at its first message. +\ This replaced a ring of messages waiting in the node's own memory, a +\ list of refusals owed, and messages written and read a word at a time +\ (MESH.md 7a, 7b, 7c.6). The ports themselves are still written a word at +\ a time for the two things that are not messages: a newborn node's +\ nucleus (PORT!, quit.v4) and a node's requests to its kernel. +\ +\ THE STACKS. All of this runs on the stacks the node's text is using. +\ (SERVE) and what it calls keep to four cells of the data stack and four +\ entries of the return stack, its own call among them; what they need +\ from one operation to the next is in cells. (ROOM-SERVE) tries that much. + +\ ( op -- how ) ask the fabric for the operation, and say how it went +: (DO) (WIRE-DO) b! !b (WIRE-HOW) b! @b ; + +\ ( port -- ) what is asked next is about that port's wire, by its number. +\ A number that is no port's is no wire: every operation then answers 2. +: (WIRE!) (WIRE) b! !b ; + +\ ( cells port -- how ) has the port's wire that many cells free? 0: it +\ has; 1: it has not; 2: no one is on that port. Only this node puts +\ messages on the wires that lead from it, so room found stays until it +\ uses it. +: (ROOM?) (WIRE!) (WIRE-A) b! !b 10 jump (DO) + +\ ( -- ) ROOM FOR WHAT A WAIT DOES. A node that waits within text -- for +\ an answer, or for room to print -- passes on meanwhile what comes for +\ other nodes, on the stacks the text has left it: four cells of the data +\ stack and four entries of the return stack, (SERVE)'s. They are tried +\ before anything is taken off a wire or put on one: if they are not there +\ the fault comes here, and the text ends "Stack overflow" with nothing +\ half done (MESH.md 7c.7, 7d.4). +\ (ROOM-SERVE) tries just those, and is what a wait for room does each time +\ a message wakes it. (ROOM), which AWAIT does once before it waits, tries +\ six cells, as it did when a message was read a word at a time: the wait +\ ends in an error that leaves the stack as it is, and the line from the +\ console that broke it is then done on that stack, where printing needs +\ six (MESH.md 7c.7). +: (ROOM-SERVE) + 0 0 0 0 drop drop drop drop + 0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ; +: (ROOM) + 0 0 0 0 0 0 drop drop drop drop drop drop + 0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ; + +\ ( to type -- ) the first six words of a message this node puts, in +\ (OUT-HDR): to, from, type, and the three that are carried: how many nodes +\ may pass it on, sixteen (the TTL: MESH.md 7b.3); ACL tag; sequence. +: (HDR) + push (OUT-HDR) a! !+ (ME) b! @b !+ pop !+ 16 !+ 0 !+ 0 !+ ; + +\ ( text port -- how ) put the message whose seven words are in (OUT-HDR) +\ and whose text is at the word address given on the wire of the port, by +\ its number. How it went is the fabric's answer: 0 it is on the wire. +\ THE ROOM KEPT FOR AN ANSWER. While this node does text, (KEEP) is the +\ port its word of how the text ended will go by, and nothing else it puts +\ on that wire may take the last 8 cells: a message that would is refused +\ here, 1, as if the wire were full. With no text being done (KEEP) is -1. +: (PUT-ON) + push (WIRE-B) b! !b pop + dup (WIRE!) + (KEEP) a! @ xor if KEPT + GO: drop (OUT-HDR) (WIRE-A) b! !b 5 jump (DO) + KEPT: drop (OUT-HDR)+6 a! @ 3 + 2/ 2/ 15 + (WIRE-A) b! !b 10 (DO) if GO ; + +\ REFUSALS (MESH.md 7b, 7d.4). A message this node cannot pass on is +\ dropped and counted in (LOST), and whoever waits on it is told, by a +\ message of type 4, a NACK, whose one word is the node the refused message +\ was for: its sender; or, for a node's answer (type 3), the node the +\ answer was for, which is the one that waits, about the node that +\ answered. The NACK is put at once. If it cannot go -- no way, no one on +\ the port, no room -- it is counted in (LOST) too, and that is the end of +\ it. Nothing is told for a NACK or for a GONE, type 5: there is no NACK +\ for a NACK. + +\ ( -- ) the message the mark of the wire in (WIRE) is at, whose seven +\ words are in (IN), is refused. A refusal for this node itself -- its own +\ message came back to it -- is counted in (REFUSED) as one that came by a +\ wire would be; or, if it is about the node this one is waiting on, +\ (A-SELF) is set for AWAIT to find (quit.v4). +\ (WIRE) is not what it was afterwards: the NACK went by another. +\ If the drop does not drop -- the wire was cut after the message was looked +\ at, which let it go already -- nothing is counted and no one is told. +: (REFUSE) + 4 (DO) if DROPPED drop ; \ it was not there to drop -- its wire has been cut: nothing is counted or told + DROPPED: drop + (LOST) a! @ 1 + ! + (IN)+2 a! @ -4 + if NOT -1 + if NOT 2 + if ANSWER + drop (IN) a! @ (ONE) a! ! (IN)+1 a! @ jump TELL \ about whom it was for; to its sender + ANSWER: drop (IN)+1 a! @ (ONE) a! ! (IN) a! @ \ about the node that answered; to whom the answer was for + TELL: dup (ME) a! @ xor if SELF drop + dup 4 (HDR) 4 (OUT-HDR)+6 a! ! + (WAY) (ONE) SWAP (PUT-ON) if SENT + drop (LOST) a! @ 1 + ! ; + SENT: drop ; + SELF: drop drop + (AWAIT-FROM) a! @ if COUNT (ONE) a! @ xor if MINE + COUNT: drop (REFUSED) a! @ 1 + ! ; + MINE: drop 1 (A-SELF) a! ! ; + NOT: drop ; + +\ ( port -- bit ) the bit for a port, by its number, in a word of a bit to a port +: (WBIT) + push 1 pop if Z -1 + FOR 2* NEXT ; + Z: drop ; + +\ ( -- ) A MESSAGE FOR ANOTHER NODE is passed on (MESH.md section 7): the +\ one the mark of the wire in (WIRE) is at, whose seven words are in (IN), +\ is moved, whole, to the wire that leads toward that node. It is refused +\ instead if it has been passed on as often as a message may be; or if +\ there is no way, or no one on the port. +\ WITH NO ROOM on that wire -- or none but the room kept on it, (KEEP) -- +\ text, a NACK and a GONE are refused, at once. But what a node printed +\ (type 2) and its word of how text ended (type 3) are NOT let go for want +\ of room: the message is left where it is, on the wire it came by, and +\ gone past; what is behind it is served; and it is moved on a later pass, +\ when there is room. Printing waits; it is not lost (MESH.md 7d.1, +\ ruling 3). (H-PORT) and (H-NEED) are the port of the first message left +\ so on this pass and the cells it needs there: a node that then sleeps, +\ sleeps for that room, (SLEEP), and is woken by room on any wire. +\ (H-MASK) has a bit for each port something was left for: what is behind +\ it for the same port is left too, though it be shorter and would fit, so +\ that what a node printed goes on in the order it came. +\ HOW OFTEN. A message's fourth word is how many more nodes may pass it +\ on; a node sends it with 16, and a move takes one off. The node that +\ finds 1 there refuses it. A device sends it with 0, which is taken for +\ 16: so 0 down to -14 are passed on and -15 is refused. Anything else is +\ nothing a node or a device sent, and is refused. +: (PASS) + (IN)+3 a! @ -if POS + 14 + -if OK jump SPENT + POS: if OK -1 + if SPENT -16 + -if SPENT + OK: drop + (IN) a! @ (WAY) (P-WAY) a! ! + (IN)+6 a! @ 3 + 2/ 2/ 7 + \ the cells it takes, + (P-WAY) a! @ (KEEP) a! @ xor if KEPT drop jump NEED + KEPT: drop 8 + \ and the room kept, if it is that wire + NEED: (P-NEED) a! ! + (P-WAY) a! @ -if WAY \ no way: refused + SPENT: drop jump (REFUSE) + WAY: (WBIT) (H-MASK) a! @ and if CLEAR \ something is left for that port already? + FULL: drop (IN)+2 a! @ -2 + if HOLD -1 + if HOLD jump SPENT \ no room: only output and answers wait + CLEAR: drop + (P-NEED) a! @ (P-WAY) a! @ (ROOM?) (S-WIRE) a! @ (WIRE!) + if GO -1 + if FULL jump SPENT \ no one on that port: refused + GO: drop (P-WAY) a! @ (WIRE-A) b! !b 3 (DO) if MOVED jump SPENT + MOVED: drop ; + HOLD: drop + (P-WAY) a! @ (WBIT) dup inv (H-MASK) a! @ and + ! + (H-PORT) a! @ -if HELD drop (P-WAY) a! @ (H-PORT) a! ! (P-NEED) a! @ (H-NEED) a! ! 7 (DO) drop ; + HELD: drop 7 (DO) drop ; + +\ ( -- ) SLEEP until a message comes -- or, if (SERVE) left a message +\ on a wire for want of room, until there is that room or a message comes +\ or any wire of this node's gains room (operation 9, MESH.md 7d.3). +: (SLEEP) + (H-PORT) a! @ -if ROOM drop 8 (DO) drop ; + ROOM: (WIRE!) (H-NEED) a! @ (WIRE-A) b! !b 9 (DO) drop ; + +\ ( -- ) ONE PASS OVER EVERY WIRE THAT HAS A MESSAGE. What is for another +\ node is passed on, or refused; what is for this node is left where it +\ is. Fetching (WIRE-HAVE) is what tells the fabric this node has seen +\ what had come: a sleep after this is woken only by what comes later +\ (MESH.md 7d.3). (S-HAVE) keeps which wires they were, for whoever then +\ looks for what is this node's own, (MINE). +: (SERVE) + (WIRE-HAVE) b! @b dup (S-HAVE) a! ! (S-MASK) a! ! + 0 (S-WIRE) a! ! -1 (H-PORT) a! ! 0 (H-MASK) a! ! + W: (S-MASK) a! @ if END + dup 2/ ! 1 and if NEXTW + drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop + M: (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED jump NEXTW + LOOKED: drop + (IN) a! @ (ME) a! @ xor if MINE drop (PASS) jump M + MINE: drop 7 (DO) drop jump M + NEXTW: drop (S-WIRE) a! @ 1 + ! jump W + END: drop ; + +\ WHAT IS FOR THIS NODE is gone through after (SERVE), a message at a time: +\ (MINE0) begins, and each (MINE) puts the mark of a wire at the next +\ message for this node and its seven words in (IN). Whoever asked then +\ takes or drops that message -- the mark is then at the one that followed +\ -- or leaves it and goes past it, (SKIP). The wire is (S-WIRE). + +\ ( -- ) begin with the wires (SERVE) found a message on +: (MINE0) (S-HAVE) a! @ (S-MASK) a! ! -1 (S-WIRE) a! ! 0 (S-ON) a! ! ; + +\ ( -- flag ) the next message for this node; 0: there are no more +: (MINE) + L: (S-ON) a! @ if WIRE + drop (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED + drop 0 (S-ON) a! ! jump L \ this wire has no more + LOOKED: drop (IN) a! @ (ME) a! @ xor if HIT + drop 7 (DO) drop jump L + HIT: drop -1 ; + WIRE: drop (S-WIRE) a! @ 1 + ! \ the next wire that had one + (S-MASK) a! @ if NONE + dup 2/ ! 1 and if NOT + drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop 1 (S-ON) a! ! jump L + NOT: drop jump L + NONE: ; + +\ ( -- ) go past the message (MINE) found: it stays on its wire +: (SKIP) (S-WIRE) a! @ (WIRE!) 7 (DO) drop ; + +\ ( -- ) A TAKE DID NOT TAKE the message (MINE) found. The fabric takes +\ only the message last looked at (MESH.md 7d.3), so either the wire has +\ been cut -- and there is nothing there, or another message that has not +\ been looked at -- or the message cannot be taken at all. It is dropped, +\ and counted in (LOST); if it cannot be dropped either it is gone past. +\ Either way whoever goes through the messages next is at another one: +\ nothing goes round on one that will not be taken. +: (UNTAKEN) + (S-WIRE) a! @ (WIRE!) 4 (DO) if GONE drop jump (SKIP) + GONE: drop (LOST) a! @ 1 + ! ; + +\ ( -- how ) take the message (MINE) found, which has one word of text: +\ its seven words stay in (IN), and its word goes to (ONE). 0: it is +\ taken. Anything else: it is not -- the wire was cut after the message +\ was looked at -- and (ONE) is not its word: nothing is to be done for it. +: (TAKE1) (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b (ONE) (WIRE-B) b! !b 2 jump (DO) + +\ ( -- how ) WAIT UNTIL THE WIRE of the port (W-PORT) has (W-NEED) cells +\ free. 0: it has. 2: no one is on that port. The node sleeps until +\ there is room, or a message comes, or another wire of its own gains +\ room; woken with no room yet, it passes on what is for other nodes, +\ (SERVE), and sleeps again. It is the one thing a node waits to put: +\ what a text prints (MESH.md 7d.1, ruling 3). +\ NOTHING BREAKS THIS WAIT but the room coming or the wire being cut +\ (ruled 2026-10-08): text for this node that comes meanwhile, from its +\ console or anyone, stays on its wire and is done when this text has been +\ finished with. A text whose printing can never go, because a stuck node +\ is on the way, waits until that node is killed (MESH.md 7d.6). +: (WAIT-ROOM) + L: (W-PORT) a! @ (WIRE!) (W-NEED) a! @ (WIRE-A) b! !b 9 (DO) + if DONE -1 + if WOKEN drop 2 ; + WOKEN: drop (WIRE-HAVE) b! @b if QUIET \ no wire has a message: there is nothing to pass on, + drop (ROOM-SERVE) (SERVE) jump L \ and no more of the stacks is asked for than a wait needs + QUIET: drop jump L + DONE: ; + +\ ( -- ) send what has been printed, to where (PRINT-TO) says, by the port +\ (PRINT-PORT): a message of type 2, its characters four to a word, the +\ first lowest. quit.v4 sets those two when text for this node arrives. +\ It waits for room on the wire, and for the 8 cells kept as well when the +\ wire is the one the answer goes by. The characters are made ready in +\ (OUT-TEXT), not where they are: until the message is on the wire the +\ buffer is as it was, and a fault on the way leaves it to be sent again. +\ The three cells after the last character are made zero first, so that +\ nothing printed earlier goes on the wire in the last word (they are in +\ the buffer, or the four free cells after it). +\ The three cells and two return entries this needs are tried first. +\ WITH NO ONE ON THE PORT -- when it waits for room, or when it comes to +\ put -- what was printed cannot be sent. While the text is being done +\ that is its error, 18; and the data stack is emptied first, as a fault +\ empties it. A word that raises an error has taken its own arguments +\ off; this one comes from under whatever word was printing, in the +\ middle of its work, and what that word had on the stack is nothing its +\ caller can use (as first built those values were left there). Once it has been finished with, what it printed +\ is let go and counted in (LOST), and the text is said to have ended in +\ an error: (LINE-STATUS), which is the word then sent of how it ended. +: (FLUSH-OUT) + (OUT^) a! @ (OUT) xor if NONE drop + 0 0 0 drop drop drop 0 push 0 push pop drop pop drop + (OUT^) a! @ (OUT) - 3 + 2/ 2/ 7 + + (PRINT-PORT) a! @ (KEEP) a! @ xor if SAME drop jump NEED + SAME: drop 8 + + NEED: (W-NEED) a! ! (PRINT-PORT) a! @ (W-PORT) a! ! + (WAIT-ROOM) if ROOM + NOONE: drop (QUIET) a! @ if TELL + drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! 2 (LINE-STATUS) a! ! ; + TELL: drop DSTACK-DEPTH b! a !b NODE-ERROR b! 18 !b ; \ the data stack is emptied, as by a fault: see below + ROOM: drop + (PRINT-TO) a! @ 2 (HDR) + (OUT^) a! @ a! 0 !+ 0 !+ 0 ! + (OUT^) a! @ (OUT) - dup (OUT-HDR)+6 a! ! + 3 + 2/ 2/ -1 + push (OUT-TEXT) pop (OUT) a! + FOR @+ @+ 8* + @+ 8* 8* + @+ 8* 8* 8* + over b! !b 1 + NEXT + drop + (OUT-TEXT) (PRINT-PORT) a! @ (PUT-ON) if SENT jump NOONE + SENT: drop (OUT) (OUT^) a! ! ; + NONE: drop ; + +\ EMIT puts the character with what has been printed. Everything the node +\ prints goes through EMIT. A is kept: the words that print have always +\ been free to use it across an EMIT. As v3, only the low 8 bits of the +\ character are printed. +\ A BUFFER FOUND FULL is sent first. It is full when a flush of it ended +\ in a fault -- the stack too deep to begin a message -- and what is printed +\ next is that fault's own message: put where (OUT^) points, it would go +\ past the buffer's end, and (OUT^) would never again be at the end to be +\ flushed (MESH.md 7c.6). +set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: EMIT ( c -- ) + 255 and a push push \ A, and then the character, to the return stack + (OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT + STALE: drop (FLUSH-OUT) + PUT: + (OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on + a (OUT)+256 xor if FULL drop pop a! ; + FULL: drop (FLUSH-OUT) pop a! ; +set HDR-NFA here ", KEY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: KEY ( -- c ) + L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ; + WAIT: drop jump L + +set HDR-NFA here ", CR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: CR ( -- ) 10 jump EMIT +set HDR-NFA here ", SPACE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: SPACE ( -- ) 32 jump EMIT +set HDR-NFA here ", COUNT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ; +set HDR-NFA here ", TYPE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: TYPE ( baddr u -- ) + -if OK drop drop NODE-ERROR b! 1 !b ; + OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK + DONE: drop drop ; + +\ ( x -- ) up to four characters packed in one cell, the first in the low +\ byte: how the capsule prints its own short messages, a literal at a time. +: (EMIT4) + L: if DONE dup EMIT 8/ jump L + DONE: drop ; + +\ ---- section 5.8: the number base ---------------------------------------- +: (BASE) ( -- b ) \ BASE, or 10 when it is outside 2 .. 36 + BASE b! @b dup -2 + -if L1 drop drop 10 ; + L1: drop dup -37 + -if L2 drop ; + L2: drop drop 10 ; diff --git a/capsules/v4/sys/dict.f18 b/capsules/v4/sys/dict.f18 new file mode 100644 index 00000000..e4bcde13 --- /dev/null +++ b/capsules/v4/sys/dict.f18 @@ -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) diff --git a/capsules/v4/sys/end.f18 b/capsules/v4/sys/end.f18 new file mode 100644 index 00000000..f573dd8c --- /dev/null +++ b/capsules/v4/sys/end.f18 @@ -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) diff --git a/capsules/v4/sys/forth.f18 b/capsules/v4/sys/forth.f18 new file mode 100644 index 00000000..90b7f3b0 --- /dev/null +++ b/capsules/v4/sys/forth.f18 @@ -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 ; diff --git a/capsules/v4/sys/input.f18 b/capsules/v4/sys/input.f18 new file mode 100644 index 00000000..be674ce6 --- /dev/null +++ b/capsules/v4/sys/input.f18 @@ -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! ! ; diff --git a/capsules/v4/sys/log.f18 b/capsules/v4/sys/log.f18 new file mode 100644 index 00000000..3aebffec --- /dev/null +++ b/capsules/v4/sys/log.f18 @@ -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) diff --git a/capsules/v4/sys/map-32.f18 b/capsules/v4/sys/map-32.f18 new file mode 100644 index 00000000..87468ecf --- /dev/null +++ b/capsules/v4/sys/map-32.f18 @@ -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 diff --git a/capsules/v4/sys/map-64.f18 b/capsules/v4/sys/map-64.f18 new file mode 100644 index 00000000..a8403aa5 --- /dev/null +++ b/capsules/v4/sys/map-64.f18 @@ -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 diff --git a/capsules/v4/sys/numout.f18 b/capsules/v4/sys/numout.f18 new file mode 100644 index 00000000..57fb23f4 --- /dev/null +++ b/capsules/v4/sys/numout.f18 @@ -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 ; diff --git a/capsules/v4/sys/qmath.f18 b/capsules/v4/sys/qmath.f18 new file mode 100644 index 00000000..9bc02251 --- /dev/null +++ b/capsules/v4/sys/qmath.f18 @@ -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 diff --git a/capsules/v4/sys/quit.f18 b/capsules/v4/sys/quit.f18 new file mode 100644 index 00000000..161d2c01 --- /dev/null +++ b/capsules/v4/sys/quit.f18 @@ -0,0 +1,585 @@ +\ quit.v4 -- a line of text, interpreted; how it ends; and the words that +\ print text written in the source. +\ +\ DECOMPOSITION.md 5.15 and 5.10: QUIT ABORT ABORT" (ABORT") ." (."). Part of +\ the compiler capsule. Rests on all the files before it. +\ +\ A NODE IS SENT TEXT (docs/v4.0.0/MESH.md section 6). It does not read its +\ own command line and prints no prompt. A node with nothing to do sleeps; +\ a message comes to one of its wires; if that is text for this node it is +\ taken and interpreted; what it printed goes back as a message, and then +\ a message saying how the text ended: +\ 1 it completed a console says " ok" +\ 2 it ended in an error the message is already printed; " ERROR" +\ 0 QUIT nothing is said +\ What a console then shows is v3's: +\ ok> 65 EMIT the console's prompt, and the line +\ A ok what the line printed, then " ok" +\ ok> NOSUCH +\ UNKNOWN WORD: 'NOSUCH' +\ ERROR +\ ok> -1 @ +\ Address out of range an address fault (D-14), from any depth +\ ERROR +\ KEY, EXPECT and QUERY are FORTH-79 words that read characters, as before; +\ they are not how text reaches the node. They still read the console's +\ registers, CONSOLE-RX and CONSOLE-STATUS, and not a message. +\ +\ THE STACKS are guarded (D-16): each counts what it holds, and a push onto +\ a full one or a pop from an empty one is a fault. So QUIT and ABORT, which +\ never return to whatever ran them, must empty the return stack, and ABORT +\ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that. +\ +\ Constants the loader supplies: +\ (LINE-STATUS) word address of the variable: how the last text ended +\ (MSG) (REPLY) (ME) (OUT) (OUT^) see core.v4, "what a node prints" +\ (PORT) word address of the node's port 0 +\ (Q) word address of four cells of scratch, which system.v4 and +\ blocks.v4 use too +\ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers + +\ ( -- ) empty the return stack. `a` is only something to store: any +\ store to the register empties the stack, and `a` needs nothing to be on +\ the data stack. One cell of the data stack is used for a moment. +macro R-CLEAR RSTACK-DEPTH b! a !b endmacro + +\ ( -- ) stop compiling; forget the word being built and any open control +\ structures. A definition that was under way stays hidden. +: (RESET) 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! ; + +\ ( s -- ) the text is done with. What it printed is sent, then a message +\ saying how it ended -- 0 QUIT, 1 completed, 2 an error -- and the node waits +\ for the next. (DONE) is entered with the same number and, for an error, +\ stops compiling first; it is always jumped to, never called, by +\ something that has emptied the return stack (or by a fault, which empties +\ it). (LINE-STATUS) keeps how the last text ended, and is the one word of +\ the message's text. +\ THE ANSWER IS NOT REFUSED HERE: the text was not begun until the wire it +\ goes by had room for it, and that room has been kept, (KEEP), which is +\ let go only now (MESH.md 7d.4). If no one is on that port any more it +\ is counted in (LOST). +\ FOUR CELLS OF THE DATA STACK are tried first: what a node does between +\ texts -- this, passing messages on, taking the next text in -- and the +\ interpreter need that many, so text may leave 28 values on a stack of 32 +\ and no more. Text that leaves more ends here, "Stack overflow", with +\ the stack emptied, and not later, in the middle of the text after it. +: (FINISH) ( s -- ) + 1 (QUIET) a! ! \ from here nothing is this text's doing + (LINE-STATUS) b! !b + 0 0 0 0 drop drop drop drop + (FLUSH-OUT) + -1 (KEEP) a! ! + (MSG)+1 a! @ 3 (HDR) 4 (OUT-HDR)+6 a! ! \ to whoever sent the text: type 3, four characters + (LINE-STATUS) (DONE-PORT) a! @ (PUT-ON) if SENT + drop (LOST) a! @ 1 + ! jump (IDLE) + SENT: drop jump (IDLE) + +: (DONE) + if GO -1 + if OK + drop (RESET) 2 jump (FINISH) + OK: drop 1 jump (FINISH) + GO: drop 0 jump (FINISH) + +\ ( -- flag ) A GONE has been taken: its seven words are in (IN), the +\ node it is about in (ONE), and (S-WIRE) is the wire it came by. It is +\ believed only if it came by the port that leads to this node's centre +\ and says it is from the centre (MESH.md 7b.4): the way to the node is +\ then forgotten, and the flag is -1. Otherwise nothing is done, and 0. +\ (As first built only what it said it was from was looked at, and one +\ that came by another port was believed.) +: (GONE?) + (CENTRE) if NOT (IN)+1 a! @ xor if FROM drop 0 ; + NOT: ; + FROM: drop (ROUTE-DEFAULT) a! @ (PORT) - (S-WIRE) a! @ xor if YES drop 0 ; + YES: drop (ONE) a! @ NO-ROUTE -1 ; + +\ ( -- ) WAITING (MESH.md 7d.4). A node with nothing to do passes on +\ what has come for other nodes, (SERVE), and then goes through what has +\ come for itself, the lowest port first and each wire from its front: +\ text is taken, into TIB, and done: (LINE), and then (FINISH) says +\ how it ended. But not unless the wire its answer goes by -- +\ the way to whoever sent it; with none known, or no one on +\ that port, the wire it came on -- has room for the answer, +\ 8 cells. If it has not, the text stays on its wire and the +\ node looks further: there may be several such, on wires +\ whose answers go different ways, and each is begun when +\ its own has the room. That room is kept from then until +\ the answer has gone. +\ TEXTS WHOSE ANSWERS GO THE SAME WAY ARE BEGUN IN THE ORDER +\ THEY CAME. Once one has been left for want of room, every +\ text behind it on this pass whose answer goes by that port +\ is left too, though the room has come since: (D-MASK) has +\ a bit for each such port. (As first built only the room +\ was asked, each time; room that came between the look at +\ one text and at the next began the second first. Found +\ by the final review of step 6e.) +\ a NACK is taken and counted in (REFUSED) +\ a GONE is taken, and believed if this node's centre sent it +\ an answer no one is waiting for is dropped: a SEND that is not waited +\ on is ordinary use, and its answer is not a loss. +\ any other is dropped, and counted in (LOST): what a node printed +\ that came here, a type there is none of, or a NACK or GONE +\ that is not as long as one is. (LOST) counts what should +\ have been delivered or acted on and was not. +\ A TAKE THAT DOES NOT TAKE -- the wire was cut after the message was +\ looked at -- leaves nothing to act on: no text is done and nothing is +\ believed for it, (UNTAKEN). The same for a drop that does not drop. +\ With nothing to begin it sleeps, executing nothing, until a message +\ comes; or, if text is waiting for room for its answer, or (SERVE) left a +\ message for want of room, until there is room on any wire that leads +\ from it or a message comes. Then it does all of this again. +\ It has fetched which wires have a message before it looks at any, and +\ sleeps after: a message that comes while it looks wakes it at once, and +\ one it left on a wire does not keep it awake (MESH.md 7d.3). +\ (KEEP) and (AWAIT-FROM) are put back here every time: whatever was +\ abandoned on the way, a node with nothing to do keeps no room and waits +\ for no one. +: (IDLE) + L: 1 (QUIET) a! ! \ nothing here is any text's doing: see (RAISED) + -1 (KEEP) a! ! 0 (AWAIT-FROM) a! ! -1 (DEFER) a! ! 0 (D-MASK) a! ! + (SERVE) (MINE0) + M: (MINE) if REST + drop (IN)+2 a! @ -1 + if TEXT -3 + if NACK -1 + if GONE + OTHER: drop 4 (DO) if LETGO drop (SKIP) jump M \ it was not there to drop: nothing is counted + LETGO: drop (IN)+2 a! @ -3 + if ANSWER \ let go. An answer no one waits for is ordinary: + drop (LOST) a! @ 1 + ! jump M \ anything else should not have come here, and is counted + ANSWER: drop jump M + NACK: drop (IN)+6 a! @ -4 + if N1 jump OTHER + N1: drop (TAKE1) if N2 drop (UNTAKEN) jump M \ not taken: nothing is done for it + N2: drop (REFUSED) a! @ 1 + ! jump M \ a message of this node's was refused: counted + GONE: drop (IN)+6 a! @ -4 + if G1 jump OTHER + G1: drop (TAKE1) if G2 drop (UNTAKEN) jump M + G2: drop (GONE?) drop jump M + TEXT: drop + (IN)+1 a! @ (WAY) -if T1 drop (S-WIRE) a! @ \ the way back; with none known, the wire it came on + T1: (DONE-PORT) a! ! + (DONE-PORT) a! @ (WBIT) (D-MASK) a! @ and if FREE1 jump FULL \ text ahead of it waits for room on that wire + FREE1: drop + 8 (DONE-PORT) a! @ (ROOM?) if START -1 + if FULL + drop (S-WIRE) a! @ (DONE-PORT) a! ! \ no one is on that port: back by the wire it came on, + (S-WIRE) a! @ (WBIT) (D-MASK) a! @ and if FREE2 jump FULL + FREE2: drop + 8 (S-WIRE) a! @ (ROOM?) -1 + if FULL jump START \ if that has the room -- or has no one on it either + FULL: drop (DONE-PORT) a! @ (WBIT) dup inv (D-MASK) a! @ and + ! + (DEFER) a! @ -if LATER drop (DONE-PORT) a! @ (DEFER) a! ! (SKIP) jump M + LATER: drop (SKIP) jump M + REST: drop + (DEFER) a! @ -if ROOM drop (SLEEP) jump L + ROOM: (WIRE!) 8 (WIRE-A) b! !b 9 (DO) drop jump L + START: drop + (S-WIRE) a! @ dup (REPLY) a! ! (WIRE!) + (MSG) (WIRE-A) b! !b TIB 2/ 2/ (WIRE-B) b! !b 2 (DO) \ its seven words, and its text + if TAKEN drop (UNTAKEN) jump M \ not taken: the wire was cut since it was looked at + TAKEN: drop + 0 (MSG)+6 a! @ TIB + C! \ a zero after the text + (MSG)+6 a! @ SPAN a! ! + (DONE-PORT) a! @ (KEEP) a! ! \ the room for its answer is kept from here + (CONSOLE) a! @ if P0 jump P1 \ where what it prints goes: the console, + P0: drop (MSG)+1 a! @ \ or whoever sent it; + P1: dup (PRINT-TO) a! ! + (WAY) -if Q1 drop (REPLY) a! @ \ by the way there, or the wire the text came on + Q1: (PRINT-PORT) a! ! + jump (LINE) + +\ ( -- ) THE TEXT, INTERPRETED. It is in TIB with a zero after it and its +\ length in SPAN, and the return stack is empty. It is interpreted with one +\ return entry under it, this word's call of INTERPRET; whatever is on the +\ data stack stays there. +: (LINE) + 0 (QUIET) a! ! \ an error from here on is this text's + 0 BLK a! ! \ the terminal, whatever was being loaded + TIB (SRC) a! ! 0 >IN a! ! + 0 NODE-ERROR b! !b + INTERPRET + NODE-ERROR b! @b if GOOD + drop 2 jump (DONE) + GOOD: drop 1 jump (DONE) + +\ ---- the node among others (MESH.md sections 6 and 7) --------------------------- +\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel. + +\ ( node port -- ) the port, by its number, leads toward that node +set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ROUTE + (ROUTE#) a! @ -16 + if FULL drop + (PORT) + (ROUTE#) a! @ 2* (ROUTES) + a! + push !+ pop !+ + (ROUTE#) a! @ 1 + ! ; + FULL: drop drop drop NODE-ERROR b! 12 !b ; + +\ ( node port -- ) the node on the other end of the port, by its number; +\ 0: none, or a device. Whoever wires the node tells it, and tells it again +\ when the wiring changes. It is how a node knows who its centre is, the +\ one node whose GONE it believes: (CENTRE). +set HDR-NFA here ", NEIGHBOUR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: NEIGHBOUR + dup -if POS jump BAD + POS: -PORTS + -if BAD drop (NEAR) + a! ! ; + BAD: drop drop drop NODE-ERROR b! 12 !b ; + +\ ( port -- ) the port, by its number, leads toward every node not told of +set HDR-NFA here ", DEFAULT-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ; + +\ ( node -- ) forget the way to that node, if one is known: what is for it +\ then goes by the way for every node not told of, if there is one. The +\ last way in the table takes its place. +set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: NO-ROUTE + (ROUTE#) a! @ if NONE -1 + (ROUTES) a! + FOR dup @+ xor if HIT drop @+ drop NEXT + drop ; + NONE: drop drop ; + HIT: drop drop pop drop + a -1 + push \ where its entry is + (ROUTE#) a! @ -1 + dup ! \ one way fewer + 2* (ROUTES) + a! @+ @ \ the last entry: node port + pop a! SWAP !+ ! ; + +\ ( about node type -- ) send the node a message of one word, `about`: +\ a GONE is type 5 (MESH.md 7b). With no way to the node it is error 12. +\ It goes or is refused at once; refused -- no one on the port, or no room +\ on the wire -- it is counted in (LOST) (MESH.md 7d.4). +: (SEND1) + push dup (WAY) -if GO + drop drop drop pop drop NODE-ERROR b! 12 !b ; + GO: (W-PORT) a! ! SWAP (ONE) a! ! + pop (HDR) 4 (OUT-HDR)+6 a! ! + (ONE) (W-PORT) a! @ (PUT-ON) if SENT + drop (LOST) a! @ 1 + ! ; + SENT: drop ; + +\ ( n node -- ) tell the node that node n is gone. It acts on that only +\ if this node is its centre: it forgets the way to n, and if it is waiting +\ for n's answer the wait ends. +set HDR-NFA here ", GONE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: GONE 5 jump (SEND1) + +\ ( -- ) forget every way: for when the wiring has changed +set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ; + +\ ( baddr u node port -- ) send the node u characters of text to +\ interpret, by the port given, by its number. The text is made ready in +\ (SEND-TEXT), four characters to a word, the message is put on the wire +\ whole, and it is on its way when this returns. IT GOES OR IS REFUSED AT +\ ONCE (MESH.md 7d.1, ruling 3): with no room on the wire it is counted in +\ (REFUSED), as a refusal that came back would be, and is error 19, Message +\ refused; with no one on the port, error 18. Nothing is on a +\ wire until the put, the last thing done. More characters than a message +\ carries, or fewer than none, is error 12. What lies after the text in +\ this node's memory does not go with it: the last word is made zero past +\ the last character. +: (SEND-ON) + push 1 (HDR) + -if POS + BAD: drop drop pop drop NODE-ERROR b! 12 !b ; + LONG: drop jump BAD + POS: dup -1025 + -if LONG + drop dup (OUT-HDR)+6 a! ! + (SEND-TEXT) (SEND^) a! ! + 3 + 2/ 2/ if NONE -1 + + FOR dup C@ over 1 + C@ 8* + over 2 + C@ 8* 8* + over 3 + C@ 8* 8* 8* + + (SEND^) b! @b a! !+ a !b 4 + NEXT + drop + (OUT-HDR)+6 a! @ 3 and if PUT \ the last word: nothing in it past the last character + (SEND^) b! @b -1 + a! + -1 + if M1 -1 + if M2 + drop @ 16777215 and ! jump PUT0 + M2: drop @ 65535 and ! jump PUT0 + M1: drop @ 255 and ! jump PUT0 + NONE: drop + PUT: drop + PUT0: (SEND-TEXT) pop (PUT-ON) + if SENT -1 + if FULL drop NODE-ERROR b! 18 !b ; + FULL: drop (REFUSED) a! @ 1 + ! NODE-ERROR b! 19 !b ; + SENT: drop ; + +\ ( baddr u node -- ) send the node u characters of text to interpret, +\ by the way this node knows to it. What it prints there goes to that +\ node's console. With no way to the node it is error 12. +set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: SEND + dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ; + GO: jump (SEND-ON) + +\ ( baddr u node port -- ) the same by a port this node names, by its +\ number, whatever ways it knows: for a neighbour that has no number of +\ its own yet, to which text is sent as to node 0. +set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: SEND-ON + dup -if POS jump BAD + POS: -PORTS + -if BAD drop jump (SEND-ON) + BAD: drop drop drop drop drop NODE-ERROR b! 12 !b ; + +\ ( -- n ) the number of this node's centre: the node on the port that +\ leads to everything it has no other way to. 0: it has none, or has not +\ been told who is there (NEIGHBOUR). +: (CENTRE) + (ROUTE-DEFAULT) a! @ if NONE (PORT) - (NEAR) + a! @ ; + NONE: ; + +\ ( -- n ) the number of this node's console: the one it was told of, or +\ with none told of, whoever sent the text it is doing +: (A-CONSOLE) + (CONSOLE) a! @ if C0 ; + C0: drop (MSG)+1 a! @ ; + +\ ( what -- how | ) the wait is over: 1 the answer has come, and its +\ word, in (ONE), is left; 2 refused, error 19; 3 the node is gone, error +\ 20; 4 a line from the console, error 21 +: (A-END) + 0 (AWAIT-FROM) a! ! + -1 + if ANS -1 + if REF -1 + if LEFT drop NODE-ERROR b! 21 !b ; + ANS: drop (ONE) a! @ ; + REF: drop NODE-ERROR b! 19 !b ; + LEFT: drop NODE-ERROR b! 20 !b ; + +\ ( node -- how ) WAIT FOR THE NODE'S WORD OF HOW TEXT ENDED: 0 QUIT, +\ 1 completed, 2 an error. (AWAIT-FROM) holds the node while this node +\ waits, and 0 otherwise. It sleeps, executing nothing, until a message +\ comes; then it passes on what is for other nodes, (SERVE), and goes +\ through what is for itself (MESH.md 7d.4): +\ the answer -- a message of type 3 from that node -- is taken, and the +\ wait is over; +\ a NACK is taken: about that node, the wait ends in error 19, Message +\ refused; about another it is counted, as at any time; +\ a GONE is taken: believed (its centre sent it: (GONE?)) and about that +\ node, the wait ends in error 20, Node gone; +\ text from its console ends the wait in error 21, Interrupted (7b.6). +\ The text is not taken: it stays on its wire and is done when this +\ text has been finished with. It is the one way to end a wait on +\ a node that is alive and never answers, short of Hera's killing +\ that node; +\ anything else stays on its wire, in its order, for when this node has +\ nothing to do. +\ WHAT HAS COME ALREADY is on the wires and is found the first time +\ through: the node looks before it sleeps. A message it left on a wire +\ does not keep it awake. +\ The stack what it does needs is tried first, (ROOM), core.v4: text that +\ has left too little ends "Stack overflow" with nothing taken off a wire. +set HDR-NFA here ", AWAIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: AWAIT + (ONE) a! ! (ROOM) \ if this faults, no one is waited for: + (ONE) a! @ (AWAIT-FROM) a! ! 0 (A-SELF) a! ! \ (AWAIT-FROM) is set only when the stack has been tried + L: (SERVE) + (A-SELF) a! @ if SCAN drop 2 jump (A-END) \ this node's own message for that node came back to it + SCAN: drop (MINE0) + M: (MINE) if SLEEP + drop (IN)+2 a! @ -1 + if TEXT -2 + if ANSWER -1 + if NACK -1 + if GONE + KEEP: drop (SKIP) jump M + TEXT: drop (A-CONSOLE) (IN)+1 a! @ xor if BREAK jump KEEP \ text: from the console? + BREAK: drop 4 jump (A-END) + ANSWER: drop (IN)+1 a! @ (AWAIT-FROM) a! @ xor if A1 jump KEEP + A1: drop (IN)+6 a! @ -4 + if A2 jump KEEP + A2: drop (TAKE1) if A3 drop (UNTAKEN) jump M \ not taken: nothing is done for it + A3: drop 1 jump (A-END) + NACK: drop (IN)+6 a! @ -4 + if N1 jump KEEP + N1: drop (TAKE1) if N0 drop (UNTAKEN) jump M + N0: drop (ONE) a! @ (AWAIT-FROM) a! @ xor if N2 \ about the node waited for? + drop (REFUSED) a! @ 1 + ! jump M \ another: counted + N2: drop 2 jump (A-END) + GONE: drop (IN)+6 a! @ -4 + if G1 jump KEEP + G1: drop (TAKE1) if G0 drop (UNTAKEN) jump M + G0: drop (GONE?) if M0 \ only its centre is believed + drop (ONE) a! @ (AWAIT-FROM) a! @ xor if G2 drop jump M + G2: drop 3 jump (A-END) + M0: drop jump M + SLEEP: drop (SLEEP) jump L + +\ ( w port -- ) write a cell to the port, by its number. It waits until +\ the neighbour has taken it. This is how a node is sent a capsule of F18 +\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a +\ message, to a node that is executing from its ports. +set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: PORT! + dup -if POS jump BAD + POS: -PORTS + -if BAD drop (PORT) + b! !b ; + BAD: drop drop drop NODE-ERROR b! 12 !b ; + +\ ( -- ) WHAT IS IN THE DICTIONARY NOW IS THE SYSTEM: COLD comes back to +\ it and FORGET will not go below it. Whoever has loaded a node's capsules +\ has it do this (system.v4, (BOOT) and FENCE). +set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: (SEAL) + DP a! @ (BOOT) a! ! + (LATEST) a! @ (BOOT)+1 a! ! + DP a! @ 3 + 2/ 2/ FENCE a! ! ; + +\ FORTH-79: clear the return stack, set execution mode, return control to +\ the terminal; no message is given. The data stack is left as it is. +\ NODE-ERROR, by name: how a definition written in FORTH raises an error. +\ A store of a code that is not zero is the trap of D-18 -- the word goes no +\ further, the message for the code is printed (-1: the word has printed +\ its own) and the line ends with ERROR. The codes are listed in core.v4. +set HDR-NFA here ", NODE-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NODE-ERROR' NODE-ERROR ; +set HDR-NFA here ", (ME) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (ME)' (ME) ; +set HDR-NFA here ", (CONSOLE) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (CONSOLE)' (CONSOLE) ; +set HDR-NFA here ", (LOST) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ; +set HDR-NFA here ", (REFUSED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ; +set HDR-NFA here ", (WORD-DEFINED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ; +set HDR-NFA here ", (WORD-FORGOTTEN) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ; + +set HDR-NFA here ", QUIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: QUIT R-CLEAR (RESET) CR 0 jump (DONE) + +\ FORTH-79: clear the data and return stacks, set execution mode, return +\ control to the terminal. As v3, the line it stops ends with " ok". +\ Both are emptied before anything is called: ABORT may be run with the +\ return stack full. +set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE) + +\ ---- faults (D-14, D-16) ------------------------------------------------------- +\ Where the node goes when a programme uses an address outside its memory, +\ pushes onto a full stack or pops an empty one. The opcode that faulted did +\ nothing, and both stacks have been emptied. Each handler says what happened; +\ whatever was running is abandoned, as by ABORT, and the line ends with +\ ERROR. +: (FAULT) \ "Address out of range" + $72646441 (EMIT4) $20737365 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR + 2 jump (DONE) +: (D-OVER) \ "Stack overflow" + $63617453 (EMIT4) $766F206B (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR + 2 jump (DONE) +: (D-UNDER) \ "Stack underflow" + $63617453 (EMIT4) $6E75206B (EMIT4) $66726564 (EMIT4) $776F6C (EMIT4) CR + 2 jump (DONE) +: (R-OVER) \ "Return stack overflow" + $75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $65766F20 (EMIT4) $6F6C6672 (EMIT4) $77 (EMIT4) CR + 2 jump (DONE) +: (R-UNDER) \ "Return stack underflow" + $75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $646E7520 (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR + 2 jump (DONE) + +\ A word has stored an error code in NODE-ERROR (D-18; the codes are listed +\ in core.v4). Print its message -- a negative code means the word printed +\ its own -- and end the line with ERROR. The return stack has been +\ emptied; the data stack is as the word left it. +\ (QUIET) is 1 while the node is doing something that is no text's doing: +\ passing a message on, or sending what a text printed and word of how it +\ ended. An error then has nobody to be told to, and telling it would +\ begin another message for a text that is over. Nothing the nucleus does +\ there raises one as it stands -- with no one on a port it counts what it +\ could not send, and goes on -- so this is a guard: if one is raised, what +\ was being sent is let go and counted, and the node goes back to waiting. +: (RAISED) + (QUIET) a! @ if SPEAK + drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! jump (IDLE) + SPEAK: drop + NODE-ERROR b! @b + -if POS drop 2 jump (DONE) + POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4 + -1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9 + -1 + if M10 -1 + if M11 -1 + if M12 -1 + if M13 -1 + if M14 + -1 + if M15 -1 + if M16 -1 + if M17 -1 + if M18 + -1 + if M19 -1 + if M20 -1 + if M21 + drop 2 jump (DONE) + M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (DONE) + M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (DONE) + M3: drop $626D754E (EMIT4) $74207265 (EMIT4) $6C206F6F (EMIT4) $676E6F (EMIT4) CR 2 jump (DONE) + M4: drop $20746F4E (EMIT4) $68632061 (EMIT4) $63617261 (EMIT4) $726574 (EMIT4) CR 2 jump (DONE) + M5: drop $74636944 (EMIT4) $616E6F69 (EMIT4) $66207972 (EMIT4) $6C6C75 (EMIT4) CR 2 jump (DONE) + M6: drop $656D614E (EMIT4) $73696D20 (EMIT4) $676E6973 (EMIT4) CR 2 jump (DONE) + M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (DONE) + M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (DONE) + M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (DONE) + M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE) + M11: drop $69766944 (EMIT4) $6E6F6973 (EMIT4) $20796220 (EMIT4) $6F72657A (EMIT4) CR 2 jump (DONE) + M12: drop $75677241 (EMIT4) $746E656D (EMIT4) $74756F20 (EMIT4) $20666F20 (EMIT4) $676E6172 (EMIT4) $65 (EMIT4) CR 2 jump (DONE) + M13: drop $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR 2 jump (DONE) + M14: drop $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR 2 jump (DONE) + M15: drop $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR 2 jump (DONE) + M16: drop $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE) + M17: drop $726F7453 (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE) + M18: drop (OUT) (OUT^) a! ! \ what was printed and not sent cannot be sent: it is let go + $6F206F4E (EMIT4) $6F20656E (EMIT4) $6874206E (EMIT4) $70207461 (EMIT4) $74726F (EMIT4) CR 2 jump (DONE) + M19: drop $7373654D (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE) + M20: drop $65646F4E (EMIT4) $6E6F6720 (EMIT4) $65 (EMIT4) CR 2 jump (DONE) + M21: drop $65746E49 (EMIT4) $70757272 (EMIT4) $646574 (EMIT4) CR 2 jump (DONE) + +\ The table the loader gives the node: six words, one for each kind of +\ fault in the node's order, each a jump. A jump fills its word, so they +\ are one after another. +: (FAULTS) + jump (FAULT) jump (D-OVER) jump (D-UNDER) jump (R-OVER) jump (R-UNDER) jump (RAISED) + +\ ---- text in the source --------------------------------------------------------- +\ The three run-time words have names, as v3's have, so that SEE can tell a +\ string in a definition from code; they cannot be used from the prompt. +\ ." and ABORT" take the text up to the next " , which may be none at all +\ (input.v4's (PARSE)); with no closing " it is the rest of the line. Inside a definition they lay +\ down a call to their run-time word and, after it, the text as a counted +\ string: the count byte and the characters, four to a cell, the last cell +\ filled with zeros. The run-time word finds the string by the return +\ address the call left, and returns to the cell after the string. + +\ ( -- ) lay the counted string in WBUF into the dictionary, as above. +\ (Q)+0 how many bytes are still to go, (Q)+1 which is next. +: (STRING,) + (FLUSH) + WBUF C@ 1 + (Q) a! ! 0 (Q)+1 a! ! + L: (Q) a! @ if DONE -1 + ! + (Q)+1 a! @ dup 1 + ! WBUF + C@ C, + jump L + DONE: drop + P: DP b! @b 3 and if ALIGNED drop 0 C, jump P + ALIGNED: drop ; + +\ The run time of ." : print the string after the call, go on after it. +\ It takes the return address off before it calls anything and keeps the +\ count there instead, so a word that prints text goes no deeper than one +\ that calls any other word. +set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: (.") + pop 4* dup C@ \ baddr n + L: if DONE + push 1 + dup C@ EMIT pop -1 + jump L + DONE: drop 4/ 1 + push ; \ the cell after the last character + +\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word +\ it is compiled into runs, if compiling. +set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: DOT-QUOTE + 34 (PARSE) drop + STATE a! @ if NOW + drop &(.") (CALL,) jump (STRING,) + NOW: drop WBUF COUNT jump TYPE + +\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the +\ string after the call, start a new line and ABORT; otherwise go on after +\ the string. +set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: (ABORT") + if NO + drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT + NO: drop pop 4* dup C@ + 4/ 1 + push ; + +\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if +\ the flag is not zero, print the text and ABORT. +set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: ABORT-QUOTE + 34 (PARSE) drop + STATE a! @ if NOW + drop &(ABORT") (CALL,) jump (STRING,) + NOW: drop if NO + drop WBUF COUNT TYPE CR jump ABORT + NO: drop ; + +\ The run time of S" : leave the address and length of the string after the +\ call, and go on after it. +set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: (S") + pop 4* dup C@ \ baddr n + over over + 4/ 1 + push \ the cell after the last character + push 1 + pop ; \ baddr+1 n + +\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled +\ into it. At the prompt it is copied to PAD, where it stays until PAD is +\ used again: WORD's buffer is overwritten by the very next word of the line. +set HDR-NFA here ", S" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here +: S-QUOTE + 34 (PARSE) drop + STATE a! @ if NOW + drop &(S") (CALL,) jump (STRING,) + NOW: drop WBUF+1 PAD WBUF C@ CMOVE PAD WBUF jump C@ diff --git a/capsules/v4/sys/system.f18 b/capsules/v4/sys/system.f18 new file mode 100644 index 00000000..14f698a4 --- /dev/null +++ b/capsules/v4/sys/system.f18 @@ -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@) + diff --git a/capsules/v4/sys/words.f18 b/capsules/v4/sys/words.f18 new file mode 100644 index 00000000..78330e72 --- /dev/null +++ b/capsules/v4/sys/words.f18 @@ -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 ; diff --git a/v4/Makefile b/v4/Makefile index d3b4a662..81bcdaae 100644 --- a/v4/Makefile +++ b/v4/Makefile @@ -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-.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) diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index 49886da5..0315323d 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -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)) { diff --git a/v4/tests/test_host_rom_nucleus.c b/v4/tests/test_host_rom_nucleus.c new file mode 100644 index 00000000..d1107793 --- /dev/null +++ b/v4/tests/test_host_rom_nucleus.c @@ -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-.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 +#include + +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; +} diff --git a/v4/tools/mkmap.c b/v4/tools/mkmap.c index 86db4d97..e2701793 100644 --- a/v4/tools/mkmap.c +++ b/v4/tools/mkmap.c @@ -1,6 +1,7 @@ /* mkmap.c -- the memory map, as constants the ROM is assembled with. * * mkmap > rom-map-.f18 + * mkmap sys > capsules/v4/sys/map-.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-.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); diff --git a/v4/tools/v4tof18.py b/v4/tools/v4tof18.py new file mode 100644 index 00000000..ff9029a6 --- /dev/null +++ b/v4/tools/v4tof18.py @@ -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()