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

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

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

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

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

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

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

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-15 14:26:02 -04:00
co-authored by Claude Opus 5.5
parent 1bf19d6224
commit a73580e949
69 changed files with 1164 additions and 4025 deletions
Download Patch File Download Diff File Expand all files Collapse all files
capsules/v4/nucleus-64.f18
BIN
View File
Binary file not shown.
capsules/v4/rom/dir.f18
+2 -1
View File
@@ -1,6 +1,7 @@
\ dir.f18 -- the ROM's directives, and the end of the system's source.
\
\ What mkimage.c and text.c's header did in C is said in the source with
\ What the prebuilt nucleus's mkimage.c (gone) and text.c's header did in C
\ is said in the source with
\ these (MACHINE.md, the ROM's language). Each is a machine notion -- an
\ address, a cell, a value -- and none is FORTH.
\ constant NAME VALUE NAME is the number VALUE
capsules/v4/sys/acl.f18
+2 -2
View File
@@ -1,11 +1,11 @@
\ acl.v4 -- word-level access control: the fields of an entry.
\ acl.f18 -- 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.
\ compile.f18. Rests on compile.f18, quit.f18 and system.f18.
\
\ 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.
capsules/v4/sys/blocks.f18
+2 -2
View File
@@ -1,4 +1,4 @@
\ blocks.v4 -- mass storage: blocks of 1024 characters, and text loaded from them.
\ blocks.f18 -- 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
@@ -23,7 +23,7 @@
\ 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
\ BLK (SRC) (SRC-HOOK) see input.f18
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 ;
capsules/v4/sys/codegen.f18
+2 -2
View File
@@ -1,4 +1,4 @@
\ codegen.v4 -- the code generator: opcodes, literals and branches packed into
\ codegen.f18 -- 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.
@@ -18,7 +18,7 @@
\ 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:
\ Rests on core.f18 and dict.f18. 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
capsules/v4/sys/compile.f18
+6 -6
View File
@@ -1,15 +1,15 @@
\ compile.v4 -- the interpreter's inner loop, and the defining and compiling
\ compile.f18 -- 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.
\ core.f18, input.f18, dict.f18 and codegen.f18.
\
\ 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:
\ Two flags on an entry (dict.f18) 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
@@ -46,9 +46,9 @@ macro ROT push SWAP pop SWAP endmacro
\ ( -- ) 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
\ whatever called INTERPRET, which is QUIT (quit.f18): QUIT sees NODE-ERROR
\ and prints ERROR.
\ (ABANDON-AS) is the same with an error code (core.v4) for the prompt to
\ (ABANDON-AS) is the same with an error code (core.f18) for the prompt to
\ print the message of.
: (ABANDON-AS) ( code -- )
(C)+9 a! !
@@ -150,7 +150,7 @@ set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- 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
\ allowed. This is what the interpreter uses: NUMBER (input.f18) 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.
capsules/v4/sys/core.f18
+6 -6
View File
@@ -1,5 +1,5 @@
set HDR-LINK 0 \ the newest dictionary entry: none yet
\ core.v4 -- the core words the host-node capsules rest on.
\ core.f18 -- 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),
@@ -13,7 +13,7 @@ set HDR-LINK 0 \ the newest dictionary entry: none yet
\ 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:
\ code and ERROR (quit.f18, (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
@@ -110,7 +110,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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^)
\ when it is full and when the text has been done with (quit.f18). (OUT^)
\ is where the next goes.
\
\ THE STACK. What prints may be run with the data stack all but full: EMIT
@@ -154,7 +154,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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.
\ nucleus (PORT!, quit.f18) 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
@@ -228,7 +228,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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).
\ (A-SELF) is set for AWAIT to find (quit.f18).
\ (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.
@@ -392,7 +392,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) 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.
\ first lowest. quit.f18 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
capsules/v4/sys/dict.f18
+4 -4
View File
@@ -1,9 +1,9 @@
\ dict.v4 -- the dictionary: its space, its entries, and looking a name up.
\ dict.f18 -- 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.
\ node. Rests on core.f18 and input.f18.
\
\ AN ENTRY. A word's execution address (xt) is the address of its code, and
\ everything else is found from it:
@@ -129,7 +129,7 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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
\ in two, FORGET and COLD (system.f18). 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
@@ -221,7 +221,7 @@ set HDR-NFA here ", FIND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- 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.
\ when interpreting; compile.f18 adds what ' does when compiling.
\ ( -- 0 ) say that the word WORD has just left is not known, as v3 does:
\ UNKNOWN WORD: 'xxx'
: (UNKNOWN)
capsules/v4/sys/end.f18
+2 -1
View File
@@ -1,6 +1,7 @@
\ 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
\ What was set in C when the nucleus was prebuilt (v4/tools/mkimage.c, gone
\ since the machine's ROM assembles the system), 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
capsules/v4/sys/forth.f18
+3 -3
View File
@@ -1,10 +1,10 @@
\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are
\ forth.f18 -- 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
\ ones that touch the return stack are compile-only as well. Rests on core.f18,
\ compile.f18's loader constants, and quit.f18, which the division words leave
\ through when the divisor is zero. (F) is seven cells of scratch for
\ this file.
capsules/v4/sys/input.f18
+3 -3
View File
@@ -1,10 +1,10 @@
\ input.v4 -- reading a line and splitting it into words and numbers.
\ input.f18 -- 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.
\ capsule: it runs on the host node. Rests on core.f18.
\
\ Constants the loader supplies:
\ TIB byte address of the text input buffer; QUERY fills at most 81 bytes
@@ -14,7 +14,7 @@
\ 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
\ interpreted. QUERY makes it TIB; LOAD (blocks.f18) 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)
capsules/v4/sys/log.f18
+2 -2
View File
@@ -1,10 +1,10 @@
\ log.v4 -- logging, as v3: a message has a level, and is printed if the
\ log.f18 -- 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.
\ on core.f18, codegen.f18 and quit.f18.
\
\ 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,
capsules/v4/sys/numout.f18
+3 -3
View File
@@ -1,10 +1,10 @@
\ numout.v4 -- printing numbers: pictured output, the . words, and .S
\ numout.f18 -- 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.
\ D-16 makes possible again. Part of the compiler capsule. Rests on core.f18
\ and forth.f18.
\
\ Constants the loader supplies:
\ HEND byte address just past the hold buffer, which is 64 bytes
capsules/v4/sys/qmath.f18
+3 -3
View File
@@ -1,10 +1,10 @@
\ qmath.v4 -- Q48.16 fixed point: a signed double with sixteen bits of
\ qmath.f18 -- 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.
\ the host node's vocabulary. Rests on core.f18, forth.f18, numout.f18 and
\ words.f18.
\
\ 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,
capsules/v4/sys/quit.f18
+9 -9
View File
@@ -1,4 +1,4 @@
\ quit.v4 -- a line of text, interpreted; how it ends; and the words that
\ quit.f18 -- 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
@@ -32,10 +32,10 @@
\
\ 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"
\ (MSG) (REPLY) (ME) (OUT) (OUT^) see core.f18, "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
\ (Q) word address of four cells of scratch, which system.f18 and
\ blocks.f18 use too
\ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers
\ ( -- ) empty the return stack. `a` is only something to store: any
@@ -356,7 +356,7 @@ set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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
\ The stack what it does needs is tried first, (ROOM), core.f18: 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
@@ -399,7 +399,7 @@ set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) 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).
\ has it do this (system.f18, (BOOT) and FENCE).
set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (SEAL)
DP a! @ (BOOT) a! !
@@ -411,7 +411,7 @@ set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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.
\ its own) and the line ends with ERROR. The codes are listed in core.f18.
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) ;
@@ -453,7 +453,7 @@ set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
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
\ in core.f18). 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:
@@ -508,7 +508,7 @@ set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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
\ (input.f18'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
capsules/v4/sys/system.f18
+4 -4
View File
@@ -1,7 +1,7 @@
\ system.v4 -- words about the dictionary as a whole: WORDS, FORGET, FENCE.
\ system.f18 -- 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.
\ dict.f18, quit.f18 and forth.f18.
\
\ Constants the loader supplies:
\ FENCE word address of the variable: FORGET will not remove an entry
@@ -104,7 +104,7 @@ set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
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)
TOLD: (Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.f18)
MISSING: drop (UNKNOWN) drop ;
\ ---- the system as a whole -------------------------------------------------------
@@ -143,7 +143,7 @@ set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(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)
(BOOT) a! @ 2/ 2/ (FORGOTTEN) \ the kernel's records of what has gone go too (dict.f18)
$54524F46 (EMIT4) $39372D48 (EMIT4) $6C6F4320 (EMIT4) $74532064 (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $69206D65 (EMIT4) $6974696E (EMIT4) $7A696C61 (EMIT4) $2E6465 (EMIT4) CR
jump ABORT
capsules/v4/sys/words.f18
+2 -2
View File
@@ -1,10 +1,10 @@
\ words.v4 -- more of the FORTH vocabulary: the stack, comparison, double,
\ words.f18 -- 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.
\ core.f18, forth.f18 and numout.f18.
\
\ Constants the loader supplies:
\ MAX-INT the largest positive number: every bit but the top one
docs/v4.0.0/DATASHEET-F18.md
+7 -2
View File
@@ -96,7 +96,9 @@ registers (§10.3).
- **I/O addresses** (§10) sit inside the address space. A fetch from or store to one goes to
the device, not to RAM. The exceptions are NODE-ERROR, which writes RAM and then traps, and
the console receive addresses, where a store goes to RAM.
- **ROM.** Designed, not built: `MACHINE.md` §2, and plan Task 1. It is a read-only range at
- **ROM.** Built (2026-10-15; `MACHINE.md` §2): 2049 words of F18 code, `capsules/v4/rom`,
assembled by `v4/tools/mkrom.c`. The machine starts at its entry 12 and assembles the
system's source (`capsules/v4/sys`) from the console. It is a read-only range at
`V4_NODE_WORDS` and above. It can be fetched and executed. A store there is an address fault.
In the model it is attached by the owner, as every device is, and a reset detaches it.
- Its routines are shared code, GA144-style (`MACHINE.md` 2.1). Payloads call them through
@@ -307,7 +309,10 @@ These are reported, not hidden:
and it is not to be extended.
2. **Device addresses are attached by the owner, not fixed.** D-4 (the memory map) is deferred.
The FPGA needs fixed addresses.
3. **The ROM range** is designed (`MACHINE.md`) and not built.
3. **The ROM** is built and the host node boots from it (2026-10-15). The ROM is the full
assembler, about 2000 words, so it is the host node's. A mesh node's small loader ROM
(the agreed correction, `JUSTIFICATION.md` §9) is not built yet. Until it is, a node that
is born is sent the host's assembled system through its port.
4. **`stack.h`'s opening comment** still says there is no overflow detection "and there never
will be". D-16 revised that, and the header carries a revision note above it. The code
counts and guards (§4). The comment's first paragraph is out of date.
experiments/bare_metal/runs/doe-aarch64-20261015-141938.csv
View File
experiments/bare_metal/runs/doe-amd64-20261015-141648.csv
View File
experiments/bare_metal/runs/doe-riscv64-20261015-142350.csv
View File
kernel/Makefile
+31 -21
View File
@@ -617,10 +617,12 @@ endif
# ------------------------------------------------------------------------------
# StarForth v4 (STARFORTH_V4=1): the golden model of the F18-derived engine,
# v4/src, and the nucleus image v4's own Makefile builds on this machine from
# v4/capsule (docs/v4.0.0/NUCLEUS.md). The node is the host node's size, with 64-bit cells, as every
# ISA this kernel boots on has (DECOMPOSITION.md D-5), so the image is the
# same file for all three.
# v4/src, with its ROM and the memory map's description of the system, which
# v4's own Makefile builds on this machine (docs/v4.0.0/MACHINE.md). The ROM
# assembles the system's source, capsules/v4/sys, from this kernel's capsule
# directory when the machine starts. The node is the host node's size, with
# 64-bit cells, as every ISA this kernel boots on has (DECOMPOSITION.md D-5),
# so the ROM and the map are the same files for all three.
# ------------------------------------------------------------------------------
# V4_DEFAULT: with v4 built in, whether it runs when the boot arguments
# name no system (A6, 2026-10-14). 1 -- v4 -- for every build: QEMU and the
@@ -630,19 +632,21 @@ endif
V4_DEFAULT ?= 1
ifeq ($(STARFORTH_V4),1)
V4_DEFS := -DSTARFORTH_V4=1 -DSK_V4_DEFAULT=$(V4_DEFAULT) -Iv4/include \
-DV4_CELL_BITS=64 -DV4_NODE_WORDS=16384 -DV4_DATA_RING=30 -DV4_RET_RING=31
-DV4_CELL_BITS=64 -DV4_NODE_WORDS=16384 -DV4_DATA_RING=30 -DV4_RET_RING=31 -DV4_ROM_WORDS=4096
KERNEL_CFLAGS += $(V4_DEFS)
LOADER_CFLAGS += $(V4_DEFS)
V4_ENGINE_SRCS := $(addprefix v4/src/,node.c exec.c stack.c iword.c heat.c guard.c image.c fabric.c capsule.c message.c wire.c)
V4_IMAGE_C := $(BUILD_DIR)/v4_image_64.c
V4_ROM_C := $(BUILD_DIR)/v4_rom_64.c
V4_MAP_C := $(BUILD_DIR)/v4_map_64.c
LOADER_EXTRA_SRCS += $(KERNEL_SRC)/v4/sk_v4.c
KERNEL_EXTRA_SRCS += $(KERNEL_SRC)/v4/sk_v4.c
# v4/system/boot.c is the boot the hosted v4 system runs too: nucleus, then
# the capsules from this kernel's own capsule directory, then the prompt.
LOADER_V4_OBJS := $(patsubst v4/src/%.c,$(LOADER_OBJ_DIR)/v4engine/%.o,$(V4_ENGINE_SRCS)) $(LOADER_OBJ_DIR)/v4engine/v4_image.o $(LOADER_OBJ_DIR)/v4system/boot.o $(LOADER_OBJ_DIR)/v4system/blocks.o $(LOADER_OBJ_DIR)/v4system/post.o $(LOADER_OBJ_DIR)/v4system/post_cases.o
KERNEL_V4_OBJS := $(patsubst v4/src/%.c,$(KERNEL_OBJ_DIR)/v4engine/%.o,$(V4_ENGINE_SRCS)) $(KERNEL_OBJ_DIR)/v4engine/v4_image.o $(KERNEL_OBJ_DIR)/v4system/boot.o $(KERNEL_OBJ_DIR)/v4system/blocks.o $(KERNEL_OBJ_DIR)/v4system/post.o $(KERNEL_OBJ_DIR)/v4system/post_cases.o
# v4/system/boot.c is the boot the hosted v4 system runs too: the ROM
# assembles the system, then the capsules from this kernel's own capsule
# directory, then the prompt.
LOADER_V4_OBJS := $(patsubst v4/src/%.c,$(LOADER_OBJ_DIR)/v4engine/%.o,$(V4_ENGINE_SRCS)) $(LOADER_OBJ_DIR)/v4engine/v4_rom.o $(LOADER_OBJ_DIR)/v4engine/v4_map.o $(LOADER_OBJ_DIR)/v4system/boot.o $(LOADER_OBJ_DIR)/v4system/blocks.o $(LOADER_OBJ_DIR)/v4system/post.o $(LOADER_OBJ_DIR)/v4system/post_cases.o
KERNEL_V4_OBJS := $(patsubst v4/src/%.c,$(KERNEL_OBJ_DIR)/v4engine/%.o,$(V4_ENGINE_SRCS)) $(KERNEL_OBJ_DIR)/v4engine/v4_rom.o $(KERNEL_OBJ_DIR)/v4engine/v4_map.o $(KERNEL_OBJ_DIR)/v4system/boot.o $(KERNEL_OBJ_DIR)/v4system/blocks.o $(KERNEL_OBJ_DIR)/v4system/post.o $(KERNEL_OBJ_DIR)/v4system/post_cases.o
endif
LOADER_SRCS := $(LOADER_SRCS_BASE) $(LOADER_EXTRA_SRCS)
@@ -783,23 +787,29 @@ else
@$(LOADER_CC) $(VMCORE_CFLAGS_COMMON) $(filter-out -I$(KERNEL_INC),$(LOADER_CFLAGS)) -c $< -o $@
endif
# StarForth v4: the capsule image, built on this machine by v4's Makefile, and
# the engine, compiled like any other kernel source.
# StarForth v4: the ROM and the map, built on this machine by v4's Makefile,
# and the engine, compiled like any other kernel source.
ifeq ($(STARFORTH_V4),1)
# The nucleus is a capsule (capsules/v4/nucleus-64.f18), written by the same
# step that writes its description, so the capsule directory waits for it.
$(CAPSULE_GENERATED): $(V4_IMAGE_C)
$(V4_IMAGE_C): FORCE
$(V4_ROM_C) $(V4_MAP_C): FORCE
@mkdir -p $(dir $@)
@echo " V4IMG v4/capsule -> $@"
@$(MAKE) --no-print-directory -C v4 CC=cc build/v4_image_64.c
@cmp -s v4/build/v4_image_64.c $@ || cp v4/build/v4_image_64.c $@
@echo " V4ROM capsules/v4/rom -> $@"
@$(MAKE) --no-print-directory -C v4 CC=cc $(CURDIR)/v4/build/rom-64.c $(CURDIR)/v4/build/v4_map_64.c
@cmp -s v4/build/rom-64.c $(V4_ROM_C) || cp v4/build/rom-64.c $(V4_ROM_C)
@cmp -s v4/build/v4_map_64.c $(V4_MAP_C) || cp v4/build/v4_map_64.c $(V4_MAP_C)
$(LOADER_OBJ_DIR)/v4engine/v4_image.o: $(V4_IMAGE_C) | $(LOADER_OBJ_DIR)
$(LOADER_OBJ_DIR)/v4engine/v4_rom.o: $(V4_ROM_C) | $(LOADER_OBJ_DIR)
@mkdir -p $(dir $@)
@echo "CC (loader) $<"
@$(LOADER_CC) $(LOADER_CFLAGS) -c $< -o $@
$(KERNEL_OBJ_DIR)/v4engine/v4_image.o: $(V4_IMAGE_C) | $(KERNEL_OBJ_DIR)
$(KERNEL_OBJ_DIR)/v4engine/v4_rom.o: $(V4_ROM_C) | $(KERNEL_OBJ_DIR)
@mkdir -p $(dir $@)
@echo "CC (kernel) $<"
@$(CC) $(KERNEL_CFLAGS) -c $< -o $@
$(LOADER_OBJ_DIR)/v4engine/v4_map.o: $(V4_MAP_C) | $(LOADER_OBJ_DIR)
@mkdir -p $(dir $@)
@echo "CC (loader) $<"
@$(LOADER_CC) $(LOADER_CFLAGS) -c $< -o $@
$(KERNEL_OBJ_DIR)/v4engine/v4_map.o: $(V4_MAP_C) | $(KERNEL_OBJ_DIR)
@mkdir -p $(dir $@)
@echo "CC (kernel) $<"
@$(CC) $(KERNEL_CFLAGS) -c $< -o $@
kernel/src/v4/sk_v4.c
+6 -3
View File
@@ -2,8 +2,9 @@
*
* The node is the golden model of the F18-derived engine (v4/src). It comes
* up as the hosted v4 system does, by v4_boot_run (v4/include/v4/boot.h):
* the nucleus image, then the capsules from the directory baked into this
* kernel, each checked and its parity line printed, then the prompt.
* the machine's ROM assembles the system from its source, then the capsules
* from the directory baked into this kernel are loaded, each checked and its
* parity line printed, then the prompt.
* docs/v4.0.0/NUCLEUS.md. This file is all the kernel adds:
*
* - what the node prints goes to the kernel's console;
@@ -27,6 +28,7 @@
static v4_node sk_v4_node;
static v4_exec_state sk_v4_es;
static v4_heat sk_v4_heat;
static v4_image sk_v4_image;
static char sk_v4_text[SK_V4_LINE + 1u];
@@ -87,7 +89,8 @@ void sk_v4_run(void (*chain)(void))
v4_boot boot;
console_println("StarForth v4: one host node, the F18-derived engine");
boot.n = &sk_v4_node; boot.es = &sk_v4_es; boot.h = &sk_v4_heat; boot.im = &v4_capsule_image;
sk_v4_image = v4_map_image;
boot.n = &sk_v4_node; boot.es = &sk_v4_es; boot.h = &sk_v4_heat; boot.im = &sk_v4_image;
boot.out = sk_v4_out; boot.key = sk_v4_key;
boot.words = sk_v4_words; boot.word_count = sizeof sk_v4_words / sizeof sk_v4_words[0]; boot.serve = sk_v4_serve;
blk_subsys_init(sk_v4_post_blk_ram, sizeof(sk_v4_post_blk_ram));
logs/20261015-141648/amd64/qemu-amd64-20261015-141648.log
+153
View File
@@ -0,0 +1,153 @@
[=3hBdsDxe: loading Boot0002 "UEFI QEMU DVD-ROM QM00005 " from PciRoot(0x0)/Pci(0x1F,0x2)/Sata(0x2,0xFFFF,0x0)
BdsDxe: starting Boot0002 "UEFI QEMU DVD-ROM QM00005 " from PciRoot(0x0)/Pci(0x1F,0x2)/Sata(0x2,0xFFFF,0x0)
[=3hStarKernel UEFI Loader
Loading kernel from ESP...
[CKPT 001] Entered efi_main - ConOut live
RAW SERIAL UP
[CKPT 002] Serial (COM1) initialized
Monolithic build - kernel linked directly
Collecting boot information...
CmdLine: parsed OK
[CKPT 004] Command line parsed
[CKPT 005] Kernel stack allocation decided
[CKPT 006] Boot info collected (ACPI table located)
GOP: linear framebuffer found
[CKPT 007] GOP: linear framebuffer found
[CKPT 008] About to enter ExitBootServices retry loop
EBS...
EBS OK
Calling kernel_main (monolithic)...
_____ _ _ __ _
/ ____| | | |/ / | |
| (___ | |_ __ _ _ __| ' / ___ _ __ _ __ ___| |
\___ \| __/ _` | '__| < / _ \ '__| '_ \ / _ \ |
____) | || (_| | | | . \ __/ | | | | | __/ |
|_____/ \__\__,_|_| |_|\_\___|_| |_| |_|\___|_|
LithosAnanke v2.1.0 amd64
Architecture: amd64
Build: Oct 15 2026 14:16:21
UEFI BootServices: EXITED
Console: serial line is a 16550 at port 0x00000000000003f8 (COM1, probed)
=== StarKernel Boot Information ===
Memory map entries: 131
Total memory: 1023 MB
Usable memory: 966 MB
===================================
PMM initialized.
PMM statistics:
Total pages: 248682
Free pages : 247159
Used pages : 1523
Total MB : 971
Free MB : 965
Used MB : 5
VMM initialized (mapped RAM, CR3 switched)
VMM initialized (mapped RAM, CR3 switched)
VMM self-test: mapped OK at 0xffff800000000000
VMM self-test complete.
IDT installed.
APIC: init...
APIC: IA32_APIC_BASE MSR=0x00000000fee00900
APIC: stale-ISR drain: 0 EOI(s) issued
APIC: initialized (xAPIC MMIO, TPR=0, SIVR=0x1FF, EOI-clear)
APIC: init done
I/O APIC: init...
I/O APIC: base=0xfec00000, gsi_base=0, overrides=5
override: source=00 gsi=2 flags=0x0000
override: source=05 gsi=5 flags=0x000d
override: source=09 gsi=9 flags=0x000d
override: source=0a gsi=10 flags=0x000d
override: source=0b gsi=11 flags=0x000d
i8042: keyboard ACKed enable-scanning
i8042: IRQ1 enabled in controller config byte
I/O APIC: keyboard IRQ1 routed (masked)
Timer: init...
Timer: init start
Timer: PM_TMR_BLK discovered from FADT at port 1544
Timer: VM mode detected (hypervisor present).
Timer: HPET calibration disabled (VM-exit MMIO would poison timing).
Timer: WARNING: invariant TSC not present under hypervisor.
Timer: continuing in RELATIVE mode (no determinism guarantees).
Timer: RDTSCP not present; using RDTSC (less serialized).
Timer: CPUID frequency unavailable; trying PM Timer...
Timer: trust=1 (0=NONE,1=REL,2=ABS), TSC=2104923666 Hz
Timer: init done
Kernel heap initialized.
Heap statistics:
Total bytes: 536870872
Free bytes: 536870872
Used bytes: 0
Peak bytes: 0
Heap base addr: 24641536
Heap end addr: 561512448
Heartbeat: init...
APIC Timer: calibrating...
APIC Timer: apic_hz=1009697831, tick_hz=100, initial_count=10096978
APIC Timer: configured (masked, ready to start)
Heartbeat: init done
Kernel initialization complete.
Boot successful!
System: StarForth v4 (this build's default)
StarForth v4: one host node, the F18-derived engine
V4: capsule v4:sys:map-64.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:map-64.f18 capsule_hash=0xaa70e1dee90f9000
V4: capsule v4:sys:core.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:core.f18 capsule_hash=0x5282537f9cc6d053
V4: capsule v4:sys:input.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:input.f18 capsule_hash=0x85d3ec486d929a79
V4: capsule v4:sys:dict.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:dict.f18 capsule_hash=0x1379bd3b5de811dc
V4: capsule v4:sys:codegen.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:codegen.f18 capsule_hash=0x36d2ae84d2911b90
V4: capsule v4:sys:compile.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:compile.f18 capsule_hash=0x11145c4c2ab819d8
V4: capsule v4:sys:quit.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:quit.f18 capsule_hash=0x0278d4bcbd206dba
V4: capsule v4:sys:forth.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:forth.f18 capsule_hash=0x16cab4a1268b85da
V4: capsule v4:sys:numout.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:numout.f18 capsule_hash=0x01297cd8e8018acd
V4: capsule v4:sys:words.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:words.f18 capsule_hash=0xb1d381f927d9f14e
V4: capsule v4:sys:system.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:system.f18 capsule_hash=0xd92203664c2915bd
V4: capsule v4:sys:qmath.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:qmath.f18 capsule_hash=0x7117595eb17ace99
V4: capsule v4:sys:blocks.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:blocks.f18 capsule_hash=0x76307ef48678dc2a
V4: capsule v4:sys:log.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:log.f18 capsule_hash=0xfc6540e6b824a52b
V4: capsule v4:sys:acl.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:acl.f18 capsule_hash=0x6845aa048db7eb22
V4: capsule v4:sys:end.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:end.f18 capsule_hash=0x5ef01312c07b79cc
PARITY:V4_ROM words=2049 rom_hash=0xa6c792b5821010b7 instructions=60725216
V4: capsule v4:forth79.4th signature: missing (unsigned)
PARITY:V4_CAPSULE name=v4:forth79.4th capsule_id=0x4055641ee17d176b capsule_hash=0x4055641ee17d176b dict_hash=0x6b56e15226ee3719
PARITY:V4_POST tests=538 pass=538 fail=0
PARITY:V4_SYSTEM word_count=317 dict_hash=0xe5a57f3eb72ff94a
PARITY:OK
POST: PASSED
[HADES][INFO ] [KRELTSC: 0] blk: raw device LBN 2048..3071 (1024 blocks)
PCI: init...
PCI: ECAM mapped (amd64)
virtio-blk: found device
[HADES][INFO ] [KRELTSC: 77147238] blk: disk 'StarForth Volume' v2 LBN 3072..789009 (785938 user b
Artemis: virtio-blk attached
ok> 1 2 + .
3 ok
ok>
logs/20261015-141938/aarch64/qemu-aarch64-20261015-141938.log
+126
View File
@@ -0,0 +1,126 @@
UEFI firmware (version 2025.11-3ubuntu7.3 built at 15:40:26 on Sep 23 2026)
[=3hBdsDxe: failed to load Boot0002 "UEFI Misc Device" from PciRoot(0x0)/Pci(0x2,0x0): Not Found
BdsDxe: failed to load Boot0003 "UEFI QEMU QEMU USB HARDDRIVE 1-0000:00:04.0-1" from PciRoot(0x0)/Pci(0x4,0x0)/USB(0x0,0x0): Not Found
BdsDxe: loading Boot0004 "UEFI Misc Device 2" from PciRoot(0x0)/Pci(0x6,0x0)
BdsDxe: starting Boot0004 "UEFI Misc Device 2" from PciRoot(0x0)/Pci(0x6,0x0)
[=3hStarKernel UEFI Loader
Loading kernel from ESP...
[CKPT 001] Entered efi_main - ConOut live
Collecting boot information...
[CKPT 004] Command line parsed
[CKPT 005] Kernel stack allocation decided
[CKPT 006] Boot info collected (ACPI table located)
[CKPT 007] GOP: linear framebuffer found
[CKPT 008] About to enter ExitBootServices retry loop
_____ _ _ __ _
/ ____| | | |/ / | |
| (___ | |_ __ _ _ __| ' / ___ _ __ _ __ ___| |
\___ \| __/ _` | '__| < / _ \ '__| '_ \ / _ \ |
____) | || (_| | | | . \ __/ | | | | | __/ |
|_____/ \__\__,_|_| |_|\_\___|_| |_| |_|\___|_|
LithosAnanke v2.1.0 aarch64
Architecture: aarch64
Build: Oct 15 2026 14:19:12
UEFI BootServices: EXITED
Console: serial line is a PL011 at 0x0000000009000000 (no devicetree: QEMU's)
=== StarKernel Boot Information ===
Memory map entries: 108
Total memory: 4093 MB
Usable memory: 4054 MB
===================================
PMM initialized.
PMM statistics:
Total pages: 1039293
Free pages : 1037882
Used pages : 1411
Total MB : 4059
Free MB : 4054
Used MB : 5
VMM initialized (mapped RAM, CR3 switched)
VMM initialized (mapped RAM, CR3 switched)
VMM self-test: mapped OK at 0xffff800000000000
VMM self-test complete.
AArch64: running at EL1
IDT installed.
APIC: init...
PSCI: no DTB -- using HVC (QEMU virt-machine default)
GICv2: no DTB GIC node -- using QEMU virt-machine defaults
GICv2: distributor+CPU interface enabled, PPI 30
APIC: init done
Timer: init...
Timer: AArch64 generic timer initialised.
Timer: init done
Kernel heap initialized.
Heap statistics:
Total bytes: 2147483608
Free bytes: 2147483608
Used bytes: 0
Peak bytes: 0
Heap base addr: 1207959552
Heap end addr: 3355443200
Heartbeat: init...
Heartbeat: init done
Kernel initialization complete.
Boot successful!
System: StarForth v4 (this build's default)
StarForth v4: one host node, the F18-derived engine
V4: capsule v4:sys:map-64.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:map-64.f18 capsule_hash=0xaa70e1dee90f9000
V4: capsule v4:sys:core.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:core.f18 capsule_hash=0x5282537f9cc6d053
V4: capsule v4:sys:input.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:input.f18 capsule_hash=0x85d3ec486d929a79
V4: capsule v4:sys:dict.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:dict.f18 capsule_hash=0x1379bd3b5de811dc
V4: capsule v4:sys:codegen.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:codegen.f18 capsule_hash=0x36d2ae84d2911b90
V4: capsule v4:sys:compile.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:compile.f18 capsule_hash=0x11145c4c2ab819d8
V4: capsule v4:sys:quit.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:quit.f18 capsule_hash=0x0278d4bcbd206dba
V4: capsule v4:sys:forth.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:forth.f18 capsule_hash=0x16cab4a1268b85da
V4: capsule v4:sys:numout.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:numout.f18 capsule_hash=0x01297cd8e8018acd
V4: capsule v4:sys:words.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:words.f18 capsule_hash=0xb1d381f927d9f14e
V4: capsule v4:sys:system.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:system.f18 capsule_hash=0xd92203664c2915bd
V4: capsule v4:sys:qmath.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:qmath.f18 capsule_hash=0x7117595eb17ace99
V4: capsule v4:sys:blocks.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:blocks.f18 capsule_hash=0x76307ef48678dc2a
V4: capsule v4:sys:log.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:log.f18 capsule_hash=0xfc6540e6b824a52b
V4: capsule v4:sys:acl.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:acl.f18 capsule_hash=0x6845aa048db7eb22
V4: capsule v4:sys:end.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:end.f18 capsule_hash=0x5ef01312c07b79cc
PARITY:V4_ROM words=2049 rom_hash=0xa6c792b5821010b7 instructions=60725216
V4: capsule v4:forth79.4th signature: missing (unsigned)
PARITY:V4_CAPSULE name=v4:forth79.4th capsule_id=0x4055641ee17d176b capsule_hash=0x4055641ee17d176b dict_hash=0x6b56e15226ee3719
PARITY:V4_POST tests=538 pass=538 fail=0
PARITY:V4_SYSTEM word_count=317 dict_hash=0xe5a57f3eb72ff94a
PARITY:OK
POST: PASSED
[HADES][INFO ] [KRELTSC: 0] blk: raw device LBN 2048..3071 (1024 blocks)
PCI: init...
virtio-blk: found device
[HADES][INFO ] [KRELTSC: 1198604] blk: disk 'StarForth Volume' v2 LBN 3072..789009 (785938 user b
Artemis: virtio-blk attached
ok> 1 2 + .
3 ok
ok>
logs/20261015-142350/riscv64/qemu-riscv64-20261015-142350.log
+196
View File
@@ -0,0 +1,196 @@
OpenSBI v1.8
____ _____ ____ _____
/ __ \ / ____| _ \_ _|
| | | |_ __ ___ _ __ | (___ | |_) || |
| | | | '_ \ / _ \ '_ \ \___ \| _ < | |
| |__| | |_) | __/ | | |____) | |_) || |_
\____/| .__/ \___|_| |_|_____/|____/_____|
| |
|_|
Platform Name : riscv-virtio,qemu
Platform Features : medeleg
Platform HART Count : 1
Platform HART Protection : pmp
Platform IPI Device : aclint-mswi
Platform Timer Device : aclint-mtimer @ 10000000Hz
Platform Console Device : uart8250
Platform HSM Device : ---
Platform PMU Device : ---
Platform Reboot Device : syscon-reboot
Platform Shutdown Device : syscon-poweroff
Platform Suspend Device : ---
Platform CPPC Device : ---
Firmware Base : 0x80000000
Firmware Size : 321 KB
Firmware RW Offset : 0x40000
Firmware RW Size : 65 KB
Firmware Heap Offset : 0x47000
Firmware Heap Size : 37 KB (total), 0 KB (reserved), 12 KB (used), 23 KB (free)
Firmware Scratch Size : 4096 B (total), 1464 B (used), 2632 B (free)
Runtime SBI Version : 3.0
Standard SBI Extensions : ipi,pmu,srst,sse,hsm,rfnc,fwft,time,base,legacy,dbcn,dbtr
Experimental SBI Extensions : none
Domain0 Name : root
Domain0 Boot HART : 0
Domain0 HARTs : 0*
Domain0 Region00 : 0x0000000080040000-0x000000008005ffff M: (F,R,W) S/U: ()
Domain0 Region01 : 0x0000000080000000-0x000000008003ffff M: (F,R,X) S/U: ()
Domain0 Region02 : 0x0000000000100000-0x0000000000100fff M: (I,R,W) S/U: (R,W)
Domain0 Region03 : 0x0000000010000000-0x0000000010000fff M: (I,R,W) S/U: (R,W)
Domain0 Region04 : 0x0000000002000000-0x000000000200ffff M: (I,R,W) S/U: ()
Domain0 Region05 : 0x000000000c400000-0x000000000c5fffff M: (I,R,W) S/U: (R,W)
Domain0 Region06 : 0x000000000c000000-0x000000000c3fffff M: (I,R,W) S/U: (R,W)
Domain0 Region07 : 0x0000000000000000-0xffffffffffffffff M: () S/U: (R,W,X)
Domain0 Next Address : 0x0000000020000000
Domain0 Next Arg1 : 0x00000000bfe00000
Domain0 Next Mode : S-mode
Domain0 SysReset : yes
Domain0 SysSuspend : yes
Boot HART ID : 0
Boot HART Domain : root
Boot HART Priv Version : v1.12
Boot HART Base ISA : rv64imafdch
Boot HART ISA Extensions : sstc,zicntr,zihpm,zicboz,zicbom,sdtrig,svadu
Boot HART PMP Count : 16
Boot HART PMP Granularity : 2 bits
Boot HART PMP Address Bits : 54
Boot HART MHPM Info : 16 (0x0007fff8)
Boot HART Debug Triggers : 2 triggers
Boot HART MIDELEG : 0x0000000000001666
Boot HART MEDELEG : 0x0000000000f4b509
[=3hRISC-V EDK2 firmware version 2025.11-3ubuntu7.3
Press ESCAPE within 5 seconds for boot options ERROR: C40000002:V03051002 I0 6D33944A-EC75-4855-A54D-809C75241F6C 83FFF850
BdsDxe: failed to load Boot0001 "UEFI Misc Device" fr
om PciRoot(0x0)/Pci(0x1,0x0): Not Found
[=3hStarKernel UEFI Loader
Loading kernel from ESP...
[CKPT 001] Entered efi_main - ConOut live
Monolithic build - kernel linked directly
Collecting boot information...
CmdLine: parsed OK
[CKPT 004] Command line parsed
[CKPT 005] Kernel stack allocation decided
[CKPT 006] Boot info collected (ACPI table located)
GOP: linear framebuffer found
[CKPT 007] GOP: linear framebuffer found
[CKPT 008] About to enter ExitBootServices retry loop
Calling kernel_main (monolithic)...
riscv64 item 4.3.5a: satp state at kernel entry (before switch)
satp.MODE = 0x000000000000000a
satp.PPN = 0x00000000000bf868
__kernel_start = 0x00000000bdc340aa
riscv64: satp cleared -- Bare mode, explicit (item 4.3.5a)
_____ _ _ __ _
/ ____| | | |/ / | |
| (___ | |_ __ _ _ __| ' / ___ _ __ _ __ ___| |
\___ \| __/ _` | '__| < / _ \ '__| '_ \ / _ \ |
____) | || (_| | | | . \ __/ | | | | | __/ |
|_____/ \__\__,_|_| |_|\_\___|_| |_| |_|\___|_|
LithosAnanke v2.1.0 riscv64
Architecture: riscv64
Build: Oct 15 2026 14:23:10
UEFI BootServices: EXITED
Console: serial line is a 16550 at 0x0000000010000000 (no devicetree: QEMU's)
=== StarKernel Boot Information ===
Memory map entries: 100
Total memory: 1020 MB
Usable memory: 974 MB
===================================
PMM initialized.
PMM statistics:
Total pages: 250212
Free pages : 249560
Used pages : 652
Total MB : 977
Free MB : 974
Used MB : 2
VMM initialized (mapped RAM, CR3 switched)
VMM initialized (mapped RAM, CR3 switched)
VMM self-test: mapped OK at 0xffff800000000000
VMM self-test complete.
IDT installed.
APIC: init...
PLIC: no DTB PLIC node -- using QEMU virt-machine default (base=0x0c000000)
PLIC: init (S-mode context 1, threshold=0)
APIC: init done
Timer: init...
Timer: RISC-V time CSR @ 10000000 Hz (FALLBACK, no devicetree)
Timer: init done
Kernel heap initialized.
Heap statistics:
Total bytes: 536870872
Free bytes: 536870872
Used bytes: 0
Peak bytes: 0
Heap base addr: 2214588416
Heap end addr: 2751459328
Heartbeat: init...
Heartbeat: init done
Kernel initialization complete.
Boot successful!
System: StarForth v4 (this build's default)
StarForth v4: one host node, the F18-derived engine
V4: capsule v4:sys:map-64.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:map-64.f18 capsule_hash=0xaa70e1dee90f9000
V4: capsule v4:sys:core.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:core.f18 capsule_hash=0x5282537f9cc6d053
V4: capsule v4:sys:input.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:input.f18 capsule_hash=0x85d3ec486d929a79
V4: capsule v4:sys:dict.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:dict.f18 capsule_hash=0x1379bd3b5de811dc
V4: capsule v4:sys:codegen.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:codegen.f18 capsule_hash=0x36d2ae84d2911b90
V4: capsule v4:sys:compile.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:compile.f18 capsule_hash=0x11145c4c2ab819d8
V4: capsule v4:sys:quit.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:quit.f18 capsule_hash=0x0278d4bcbd206dba
V4: capsule v4:sys:forth.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:forth.f18 capsule_hash=0x16cab4a1268b85da
V4: capsule v4:sys:numout.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:numout.f18 capsule_hash=0x01297cd8e8018acd
V4: capsule v4:sys:words.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:words.f18 capsule_hash=0xb1d381f927d9f14e
V4: capsule v4:sys:system.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:system.f18 capsule_hash=0xd92203664c2915bd
V4: capsule v4:sys:qmath.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:qmath.f18 capsule_hash=0x7117595eb17ace99
V4: capsule v4:sys:blocks.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:blocks.f18 capsule_hash=0x76307ef48678dc2a
V4: capsule v4:sys:log.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:log.f18 capsule_hash=0xfc6540e6b824a52b
V4: capsule v4:sys:acl.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:acl.f18 capsule_hash=0x6845aa048db7eb22
V4: capsule v4:sys:end.f18 signature: missing (unsigned)
PARITY:V4_F18 name=v4:sys:end.f18 capsule_hash=0x5ef01312c07b79cc
PARITY:V4_ROM words=2049 rom_hash=0xa6c792b5821010b7 instructions=60725216
V4: capsule v4:forth79.4th signature: missing (unsigned)
PARITY:V4_CAPSULE name=v4:forth79.4th capsule_id=0x4055641ee17d176b capsule_hash=0x4055641ee17d176b dict_hash=0x6b56e15226ee3719
PARITY:V4_POST tests=538 pass=538 fail=0
PARITY:V4_SYSTEM word_count=317 dict_hash=0xe5a57f3eb72ff94a
PARITY:OK
POST: PASSED
[HADES][INFO ] [KRELTSC: 0] blk: raw device LBN 2048..3071 (1024 blocks)
PCI: init...
virtio-blk: found device
[HADES][INFO ] [KRELTSC: 20295513] blk: disk 'StarForth Volume' v2 LBN 3072..789009 (785938 user b
Artemis: virtio-blk attached
ok> 1 2 + .
3 ok
ok>
v4/Makefile
+29 -39
View File
@@ -82,25 +82,16 @@ blocks_src = $(if $(call uses_blocks,$(1)),$(BLOCKS_SRC) $(HERE)/system/pos
blocks_objs = $(if $(call uses_blocks,$(1)),$(BINDIR)/v3blocks.o)
san_blocks_objs = $(if $(call uses_blocks,$(1)),$(BINDIR)/san-v3blocks.o)
# The capsule sources: definitions as text (include/v4/text.h), which tests
# assemble onto a node. The directory is passed to the tests so that they
# find the files whatever directory make was run from.
CAPSULES := $(wildcard $(HERE)/capsule/*.v4)
capsule_dir := -DV4_CAPSULE_DIR='"$(HERE)/capsule"'
# THE NUCLEUS IMAGE. tools/mkimage.c, built for the host node (HOST_WORDS
# and the host stack sizes) at one cell width, assembles the nucleus --
# capsule/*.v4 -- and writes it as a C file, $(BINDIR)/v4_image_<width>.c.
# The hosted system below and the bare-metal kernel (kernel/Makefile,
# STARFORTH_V4=1) link the 64-bit one. docs/v4.0.0/NUCLEUS.md.
# The nucleus as a capsule of F18 code (include/v4/capsule.h). The 64-bit one
# is a product's: it goes into the capsule directory, ../capsules/v4, where
# the repository's mkcapsule finds it, hashes it and signs it with every
# other capsule. It is a built file kept in the tree, as
# ../capsules/BLOCK_MAP.md is, and is to be committed when it changes.
# The system's source, capsules/v4/sys (MACHINE.md 3): F18 assembler as text
# (include/v4/text.h), which the ROM assembles when the machine starts and
# tests assemble onto a node with text.c. capsule/ holds the FORTH source
# tests compile (*.fth). Both directories are passed to the tests so that
# they find the files whatever directory make was run from.
ROOT := $(abspath $(HERE)/..)
NUCLEUS_64 := $(ROOT)/capsules/v4/nucleus-64.f18
NUCLEUS_32 := $(BINDIR)/nucleus-32.f18
SYS_DIR := $(ROOT)/capsules/v4/sys
CAPSULES := $(wildcard $(SYS_DIR)/*.f18) $(wildcard $(HERE)/capsule/*.fth)
capsule_dir := -DV4_CAPSULE_DIR='"$(HERE)/capsule"' -DV4_SYS_DIR='"$(SYS_DIR)"'
HOST_DEFS := -DV4_NODE_WORDS=$(HOST_WORDS) -DV4_DATA_RING=$(HOST_DATA_RING) -DV4_RET_RING=$(HOST_RET_RING) -DV4_ROM_WORDS=$(HOST_ROM_WORDS)
ENGINE_SRCS := $(addprefix $(HERE)/src/,node.c exec.c stack.c iword.c heat.c guard.c image.c fabric.c capsule.c message.c wire.c)
@@ -108,17 +99,18 @@ ENGINE_SRCS := $(addprefix $(HERE)/src/,node.c exec.c stack.c iword.c heat.c gua
# code in capsules/v4/rom, assembled off the node by tools/mkrom.c, as a
# bitstream is built. tools/mkmap.c writes the memory map's constants it is
# assembled with, from tests/host_map.h. main.f18 comes first: the ROM's
# entry table is at its base. Tests named test_host_rom_*.c link the ROM of
# entry table is at its base. Tests named test_host_rom_*.c, and
# test_host_unit.c, whose host builds the system with it, link the ROM of
# their width and read its symbols.
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"' -DV4_SYS_DIR='"$(SYS_DIR)"')
uses_rom = $(or $(findstring /test_host_rom_,$(1)),$(findstring /test_host_unit,$(1)))
rom_src = $(if $(call uses_rom,$(1)),$(BINDIR)/rom-$(2).c)
rom_sym = $(if $(call uses_rom,$(1)),-DV4_ROM_SYM='"$(BINDIR)/rom-$(2).sym"')
# THE SYSTEM'S SOURCE as the ROM reads it (MACHINE.md 3): capsules/v4/sys. Its
# map, map-<width>.f18, is written by tools/mkmap.c from tests/host_map.h
# (`make sysmap`) and kept in the tree, as capsules/BLOCK_MAP.md is.
SYS_DIR := $(ROOT)/capsules/v4/sys
define ROM_RULE
$(BINDIR)/mkmap-$(1): $(HERE)/tools/mkmap.c $$(SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/tests/host_map.h $(HERE)/Makefile
@@ -131,6 +123,9 @@ $(BINDIR)/rom-map-$(1).f18: $(BINDIR)/mkmap-$(1)
$(SYS_DIR)/map-$(1).f18: $(BINDIR)/mkmap-$(1)
$(BINDIR)/mkmap-$(1) sys > $$@
$(BINDIR)/v4_map_$(1).c: $(BINDIR)/mkmap-$(1)
$(BINDIR)/mkmap-$(1) image > $$@
$(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) \
@@ -147,23 +142,17 @@ 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)
$$(CC) $$(CFLAGS) -I$(HERE)/include -DV4_CELL_BITS=$(1) $(HOST_DEFS) $(capsule_dir) $(HERE)/tools/mkimage.c $$(SRCS) -o $$@
$(BINDIR)/v4_image_$(1).c: $(BINDIR)/mkimage-$(1) $$(CAPSULES)
$(BINDIR)/mkimage-$(1) $$@ $$(NUCLEUS_$(1))
endef
$(foreach w,$(WIDTHS),$(eval $(call IMAGE_RULE,$(w))))
# The machine as a host links it (the hosted system below, the bare-metal
# kernel): the ROM, and the map's description of the system (include/v4/
# image.h, v4_map_image).
.PHONY: image
image: $(foreach w,$(WIDTHS),$(BINDIR)/v4_image_$(w).c)
image: $(foreach w,$(WIDTHS),$(BINDIR)/rom-$(w).c $(BINDIR)/v4_map_$(w).c)
# THE HOSTED SYSTEM: StarForth v4 as a Linux program, a product, for amd64,
# aarch64 and riscv64 -- $(BINDIR)/starforth4-<isa>. It is the engine, the
# 64-bit nucleus image, the capsule directory and the boot (system/boot.c)
# that loads the capsules from it: the same four the kernel links. The
# 64-bit ROM and map, the capsule directory and the boot (system/boot.c)
# that has the ROM assemble the system's source from it and loads the
# capsules: the same the kernel links. The
# directory is made by the repository's own tools/mkcapsule.c from
# ../capsules, signed if the key is on this machine (kernel/Makefile,
# SIGN_KEY), and the code that reads it is the kernel's, compiled here as it
@@ -183,6 +172,7 @@ CRYPTO_SRCS := $(addprefix $(ROOT)/kernel/src/crypto/,ed25519.c fe25519.c scal
MKCAPSULE_SRCS := $(ROOT)/tools/mkcapsule.c $(ROOT)/tools/pkcs8_ed25519.c $(CRYPTO_SRCS)
CAPSULE_FILES := $(shell find $(ROOT)/capsules -type f ! -name '.*' 2>/dev/null)
CAPSULE_DIR_C := $(BINDIR)/capsule_generated.c
MACHINE_64 := $(BINDIR)/rom-64.c $(BINDIR)/v4_map_64.c
# the kernel's capsule code: find, check the hash, verify the signature,
# split a payload into blocks
@@ -197,15 +187,15 @@ $(BINDIR)/mkcapsule: $(MKCAPSULE_SRCS)
@mkdir -p $(BINDIR)
cc -std=c99 -Wall -Wextra -O2 -I$(ROOT)/v3/include -I$(ROOT)/kernel/include -I$(ROOT)/tools -o $@ $(MKCAPSULE_SRCS)
$(CAPSULE_DIR_C): $(BINDIR)/mkcapsule $(CAPSULE_FILES) $(BINDIR)/v4_image_64.c
$(CAPSULE_DIR_C): $(BINDIR)/mkcapsule $(CAPSULE_FILES)
$(BINDIR)/mkcapsule $(SIGN_KEY_ARGS) $(ROOT)/capsules $@
define HOSTED_RULE
$(BINDIR)/starforth4-$(1): $(HERE)/tools/hosted.c $(BINDIR)/v4_image_64.c $(CAPSULE_DIR_C) $$(ENGINE_SRCS) $$(SYSTEM_SRCS) $(BLOCKS_SRC) $(V3_BLOCK_SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/Makefile
$(BINDIR)/starforth4-$(1): $(HERE)/tools/hosted.c $(MACHINE_64) $(CAPSULE_DIR_C) $$(ENGINE_SRCS) $$(SYSTEM_SRCS) $(BLOCKS_SRC) $(V3_BLOCK_SRCS) $$(wildcard $(HERE)/include/v4/*.h) $(HERE)/Makefile
$$(CC_$(1)) $$(CFLAGS) -D_POSIX_C_SOURCE=200809L -I$(HERE)/include $(V3_INC) -DV4_CELL_BITS=64 $(HOST_DEFS) -c $(HERE)/tools/hosted.c -o $(BINDIR)/hosted-$(1).o
@rm -rf $(BINDIR)/v3o-$(1) && mkdir -p $(BINDIR)/v3o-$(1)
cd $(BINDIR)/v3o-$(1) && $$(CC_$(1)) $(V3_CFLAGS) -I$(HERE)/include -DV4_CELL_BITS=64 $(HOST_DEFS) -c $(V3_BLOCK_SRCS) $(BLOCKS_SRC)
$$(CC_$(1)) $$(SYSTEM_CFLAGS) -static $(BINDIR)/hosted-$(1).o $(BINDIR)/v4_image_64.c $(CAPSULE_DIR_C) $$(ENGINE_SRCS) $$(SYSTEM_SRCS) $(BINDIR)/v3o-$(1)/*.o -o $$@
$$(CC_$(1)) $$(SYSTEM_CFLAGS) -static $(BINDIR)/hosted-$(1).o $(MACHINE_64) $(CAPSULE_DIR_C) $$(ENGINE_SRCS) $$(SYSTEM_SRCS) $(BINDIR)/v3o-$(1)/*.o -o $$@
$(BINDIR)/boot-$(1).txt: $(BINDIR)/starforth4-$(1)
@echo " [hosted $(1)]"
@@ -272,7 +262,7 @@ hosted-check: $(foreach i,$(HOSTED_ISAS),$(BINDIR)/boot-$(i).txt) $(BINDIR)/star
# in the place of system/post_cases.c): hosted-check boots it and requires
# that the boot stops there. docs/v4.0.0/MESH.md step 6b, acceptance 4.
$(BINDIR)/starforth4-postfail: $(BINDIR)/starforth4-amd64 $(HERE)/tests/post_cases_fail.c
$(CC) $(SYSTEM_CFLAGS) -static $(BINDIR)/hosted-amd64.o $(BINDIR)/v4_image_64.c $(CAPSULE_DIR_C) $(ENGINE_SRCS) $(filter-out %/post_cases.c,$(SYSTEM_SRCS)) $(HERE)/tests/post_cases_fail.c $(BINDIR)/v3o-amd64/*.o -o $@
$(CC) $(SYSTEM_CFLAGS) -static $(BINDIR)/hosted-amd64.o $(MACHINE_64) $(CAPSULE_DIR_C) $(ENGINE_SRCS) $(filter-out %/post_cases.c,$(SYSTEM_SRCS)) $(HERE)/tests/post_cases_fail.c $(BINDIR)/v3o-amd64/*.o -o $@
.PHONY: all test sanitize clean $(addprefix test-,$(WIDTHS))
v4/README.md
+12 -6
View File
@@ -22,18 +22,23 @@ uses (`v4/include/v4/text.h`). `make -C v4 test` builds
and runs the tests at both cell widths; `make -C v4 sanitize` repeats them
under ASan and UBSan. There is no POST and no K measurement yet.
## The system: nucleus, capsules, prompt
## The system: ROM, source, capsules, prompt
`docs/v4.0.0/NUCLEUS.md` is the design. A v4 system is four things:
`docs/v4.0.0/MACHINE.md` and `docs/v4.0.0/NUCLEUS.md` are the design. A v4
system is five things:
| Part | Where | What it is |
|---|---|---|
| Engine | `v4/src` | The golden model of the 32-opcode node |
| Nucleus | `v4/capsule/*.v4`, built by `v4/tools/mkimage.c` into `capsules/v4/nucleus-64.f18` | The assembled words, as a capsule of F18 code: sent through its port to a node born empty |
| ROM | `capsules/v4/rom/*.f18`, assembled by `v4/tools/mkrom.c` | The machine's one binary: F18 code that assembles F18 source when the machine starts |
| System's source | `capsules/v4/sys/*.f18` | The system as F18 assembler text: the memory map, the fourteen, and `end.f18` (the switch-on state and `start`). No prebuilt nucleus: the ROM assembles it at every boot |
| Capsules | `capsules/v4/*.4th`, baked by `tools/mkcapsule.c` | FORTH source, loaded when the system comes up |
| Boot | `v4/system/boot.c` | Starts the nucleus, checks and loads each capsule, prints the parity lines, gives the prompt |
| Boot | `v4/system/boot.c` | Feeds the system's source to the ROM, checks and loads each capsule, prints the parity lines, gives the prompt |
Two products link the same four and differ only in the console:
A node that is born is sent the system as assembled code, never source
(Captain Bob, 2026-10-15): the host's machine assembles it once.
Two products link the same five and differ only in the console:
- **Hosted Linux**, `v4/tools/hosted.c`: `make -C v4 hosted` builds
`v4/build/starforth4-amd64`, `-aarch64` and `-riscv64`, static, 64-bit cells.
@@ -42,7 +47,8 @@ Two products link the same four and differ only in the console:
A boot prints:
```
PARITY:V4_NUCLEUS words=292 image_hash=0x...
PARITY:V4_F18 name=v4:sys:map-64.f18 capsule_hash=0x... (one line for each blob of the system's source)
PARITY:V4_ROM words=2049 rom_hash=0x... instructions=60719827
PARITY:V4_CAPSULE name=v4:forth79.4th capsule_id=0x... capsule_hash=0x... dict_hash=0x...
PARITY:OK
ok>
v4/capsule/acl.v4
-83
View File
@@ -1,83 +0,0 @@
\ acl.v4 -- word-level access control: the fields of an entry.
\
\ DECOMPOSITION.md 5.20, as v3: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
\ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
\ ACL-WORD-ID. These are all the capsule does itself; the policy -- what is
\ strict, how long a TTL is, what is pinned -- is FORTH source, ACL.fth, as
\ it is ACL.4th in v3. The fields and the check are described in
\ compile.v4. Rests on compile.v4, quit.v4 and system.v4.
\
\ An xt of 0 is an error (code 16, "Not a word"). A pinned word's fields are
\ not changed by the ! words: they do nothing, as in v3.
\
\ Constants the loader supplies:
\ (ACL-HOOK) word address of the variable: the xt of the recheck word, or 0
\ ( xt -- xt ) refuse 0
: (ACL-XT) if NULL ; NULL: drop NODE-ERROR b! 16 !b 0 ;
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
: (PINNED) -3 + a! @ 64 and ;
header ACL-HOOK inline : ACL-HOOK' (ACL-HOOK) ;
header ACL-MODE@
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
header ACL-TTL@
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
header ACL-ALLOW@
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
header ACL-PINNED?
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
header ACL-PIN
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
header ACL-MODE!
: ACL-MODE! ( mode xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop 255 and 8* @ -65281 and + ! ;
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
header ACL-TTL!
: ACL-TTL! ( n xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop
-if POS drop 0 jump SET
POS: dup -65536 and if SMALL drop drop 65535 jump SET
SMALL: drop
SET: 8* 8* @ 65535 and + ! ;
header ACL-ALLOW!
: ACL-ALLOW! ( flag xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop if DENY drop @ -33 and ! ;
DENY: drop @ 32 OR ! ;
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
\ is 0 and it is allowed. This is the one word that unpins.
header ACL-INHERIT
: ACL-INHERIT
(ACL-XT) SWAP (ACL-XT) \ dst src
-3 + a! @ $FF00 and \ dst mode
SWAP -3 + a! @ 255 and -97 and + ! ; \ the five flags, nothing else
\ ( xt -- ) every entry from xt back that is not pinned: TTL mode, TTL 0,
\ allowed
: (ACL-INIT)
L: if DONE
dup (PINNED) if FREE drop jump NXT
FREE: drop @ 31 and !
NXT: -1 + a! @ jump L
DONE: drop ;
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
header ACL-INIT-PRIMITIVES
: ACL-INIT-PRIMITIVES
(LATEST) a! @ (ACL-INIT)
VOC-LINK a! @
V: if DONE dup a! @ (ACL-INIT) 1 + a! @ jump V
DONE: drop ;
\ ( xt -- heat ) how often the word has been used. The node's heat
\ counters are not readable from a programme yet (D-6): 0.
header ACL-HEAT@
: ACL-HEAT@ (ACL-XT) drop 0 ;
\ ( xt -- n ) a number for the word that never changes: its address
header ACL-WORD-ID
: ACL-WORD-ID (ACL-XT) ;
v4/capsule/blocks.v4
-127
View File
@@ -1,127 +0,0 @@
\ blocks.v4 -- mass storage: blocks of 1024 characters, and text loaded from them.
\
\ DECOMPOSITION.md 5.11, FORTH-79: BLOCK BUFFER UPDATE SAVE-BUFFERS
\ EMPTY-BUFFERS LIST LOAD SCR BLK, and v3's FLUSH THRU and --> . Part of the
\ compiler capsule; rests on everything before it.
\
\ STORAGE IS THE KERNEL'S (docs/v4.0.0/MESH.md section 8, ENGINE.md 3.3), as
\ it is for a v3 VM. A node only ever asks for a block by number, and it
\ asks its kernel: it writes a request to port 0, where its kernel is, and
\ when the write has been served the answer is on the data stack. The
\ node has a window in its memory, four slots of 256 cells; the kernel
\ keeps the record of which block is in which slot, does the copying, and
\ decides when a block is written. The requests (v4/include/v4/blocks.h):
\ BLOCK# ( n -- waddr status ) the slot holding block n
\ BUFFER# ( n -- waddr status ) a slot for block n, not read
\ UPDATE# ( -- status ) the block last asked for is changed
\ SAVE-BUFFERS# ( -- status ) every changed block is written
\ EMPTY-BUFFERS# ( -- ) every slot is let go
\ The status is 0, or 2 storage refused (error 17), or 3 there is no such
\ block (error 13). BLOCK and BUFFER give a byte address, as PAD and TIB
\ are: what C@ CMOVE and TYPE take.
\
\ Constants the loader supplies:
\ BLOCK# BUFFER# UPDATE# SAVE-BUFFERS# EMPTY-BUFFERS# the requests' numbers
\ SCR word address of the variable: the block LIST showed last
\ BLK (SRC) (SRC-HOOK) see input.v4
header SCR inline : SCR' SCR ;
header BLK inline : BLK' BLK ;
\ ( status -- ) a request that did not work is an error
: (B-ERR)
if FINE -2 + if E17 drop NODE-ERROR b! 13 !b ;
E17: drop NODE-ERROR b! 17 !b ;
FINE: drop ;
\ ( waddr status -- baddr ) the slot's byte address, or the error
: (B-GOT)
if OK SWAP drop jump (B-ERR)
OK: drop 2* 2* ;
\ ( n -- baddr ) FORTH-79: the address of a buffer assigned to block n.
\ What the buffer holds is not read from storage.
header BUFFER
: BUFFER BUFFER# (PORT) b! !b jump (B-GOT)
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
\ read from storage if it is not already in one.
header BLOCK
: BLOCK BLOCK# (PORT) b! !b jump (B-GOT)
\ FORTH-79: mark the block most recently asked for as changed, so that it is
\ written before its buffer is used for another.
header UPDATE
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
\ FORTH-79: write every block that has been UPDATEd.
header SAVE-BUFFERS
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
\ As v3: the same.
header FLUSH
: FLUSH jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
header EMPTY-BUFFERS
: EMPTY-BUFFERS EMPTY-BUFFERS# (PORT) b! !b ;
\ ---- LIST ----------------------------------------------------------------------
\ ( n -- ) as v3: a new line, "Block n", then sixteen lines of 64
\ characters, each after its number, and an empty line. SCR is left holding n. A character
\ that is not printable is shown as a blank. (Q)+0 is the line, (Q)+1 the
\ column, (Q)+2 the block's number.
header LIST
: LIST
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
(Q)+2 a! @ dup SCR a! !
CR $636F6C42 (EMIT4) $206B (EMIT4) 0 DOT-R CR \ "Block "
0 (Q) a! !
LN: (Q) a! @ 0 <# # # #> TYPE 58 EMIT SPACE
0 (Q)+1 a! !
CH: SCR a! @ BLOCK (Q) a! @ 2* 2* 2* 2* 2* 2* + (Q)+1 a! @ + C@
dup -32 + -if GE drop drop 32 jump EM
GE: drop dup -127 + -if BIG drop jump EM
BIG: drop drop 32
EM: EMIT
(Q)+1 a! @ 1 + dup ! -64 + if EOL drop jump CH
EOL: drop CR
(Q) a! @ 1 + dup ! -16 + if DONE drop jump LN
DONE: drop jump CR
\ ---- LOAD ----------------------------------------------------------------------
\ The text being interpreted is at (SRC), SPAN characters of it, >IN the
\ place in it. LOAD saves those and BLK on the return stack, points them at
\ the block, interprets it, and puts them back; so a block may LOAD another,
\ and the rest of the line LOAD was on is interpreted afterwards. (v3's
\ LOAD loses the rest of its line.)
\ ( -- ) what WORD calls before it reads: while a block is being loaded,
\ make sure it is in a buffer and (SRC) is that buffer.
: (BLK-SRC)
BLK a! @ if TERM BLOCK (SRC) a! ! ;
TERM: drop ;
\ ( n -- ) FORTH-79: interpret block n, then go on with what follows.
header LOAD
: LOAD
-if POS jump BAD
POS: if BAD
BLK a! @ push >IN a! @ push SPAN a! @ push (SRC) a! @ push
BLK a! ! 0 >IN a! ! 1024 SPAN a! !
&(BLK-SRC) (SRC-HOOK) a! !
INTERPRET
pop (SRC) a! ! pop SPAN a! ! pop >IN a! ! pop BLK a! ! ;
BAD: drop NODE-ERROR b! 13 !b ;
\ ( -- ) go on with the next block. Only in a block being loaded: at the
\ terminal it is an error (code 14).
header --> immediate
: NEXT-BLOCK
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
TERM: drop NODE-ERROR b! 14 !b ;
\ ( first last -- ) as v3: LOAD each block from first to last.
header THRU
: THRU
push
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
GO: drop dup push LOAD pop 1 + jump L
v4/capsule/codegen.v4
-119
View File
@@ -1,119 +0,0 @@
\ codegen.v4 -- the code generator: opcodes, literals and branches packed into
\ instruction words at HERE.
\
\ This is what the compiling words ( : ; IF LOOP LITERAL ... ) are built on.
\ It lays code down exactly as DECOMPOSITION.md 1.2 and 2 require and as the
\ test harness's own packers do (v4/include/v4/asm.h, text.h):
\
\ - opcodes fill slots 0 .. 5 of a word left to right; a full word is
\ appended to the dictionary and a new one started; unused slots are nop
\ - a literal is @p in a slot and its value in the cell after the word;
\ several in one word follow it in order
\ - ; and ex close the word, since nothing after them runs
\ - a branch closes the word: the bits to its right are its address
\ - a branch goes only in a slot whose address field reaches all of the
\ node's memory; otherwise the word is closed first and the branch starts
\ the next one. So no branch ever needs a reach check.
\
\ An instruction word is 32 bits at every cell width (D-9): slot k is the five
\ bits whose lowest is bit 27 - 5k, and a branch there has 27 - 5k address bits.
\
\ Rests on core.v4 and dict.v4. Constants the loader supplies:
\ (CG) word address of fourteen cells of scratch for this file
\ CG-BSLOTS how many slots, counted from slot 0, may hold a branch
\ Like WORD, these run under whatever the user has on the stacks, so what they
\ work on is in (CG), they keep at most three cells of their own on the data
\ stack, and they call each other as little as they can (D-2):
\ (CG)+0 the word being built (CG)+1 its next free slot
\ (CG)+2 how many literals it owes, and (CG)+3 .. (CG)+8 the literals
\ (CG)+9 the opcode (OP,) was given (CG)+10 the ref (BRANCH0) made
\ (CG)+11 the target a branch is to reach (CG)+12 which literal (FLUSH) is at
\ (CG)+13 what (FLUSH) fills unused slots with: nop, or 0 after a branch
\
\ The word being built is kept right-justified: each opcode is shifted in
\ below the ones before it, and (FLUSH) shifts in what fills the rest and the
\ two spare bits. So nothing is ever shifted by a counted loop, which would
\ want a return-stack entry for its count.
\ ( k -- mask ) the address bits of a branch in slot k: 2^(27-5k) - 1
: (MASK)
if K0 -1 + if K1 -1 + if K2
drop 4095 ;
K2: drop 131071 ;
K1: drop 4194303 ;
K0: drop 134217727 ;
\ ( -- ) forget the word being built
: (CG-RESET) 0 (CG) a! ! 0 (CG)+1 a! ! 0 (CG)+2 a! ! 28 (CG)+13 a! ! ;
\ ( x -- ) five bits into the next free slot, which must be free
: (PUT)
(CG) a! @ 2* 2* 2* 2* 2* + !
(CG)+1 a! @ 1 + ! ;
\ ( -- ) append the word being built, its unused slots filled, then the
\ literals it owes; nothing if no slot is in use
: (FLUSH)
(CG)+1 a! @ if EMPTY drop
P: (CG)+1 a! @ -6 + if FULL drop (CG)+13 a! @ (PUT) jump P
FULL: drop
(CG) a! @ 2* 2* , \ the two spare bits
0 (CG)+12 a! !
L: (CG)+12 a! @ (CG)+2 a! @ xor if DONE
drop (CG)+12 a! @ dup 1 + ! (CG)+3 + a! @ ,
jump L
DONE: drop
jump (CG-RESET)
EMPTY: drop ;
\ ( op -- ) any opcode that is neither a branch nor @p
: (OP,)
dup (CG)+9 a! ! (PUT)
(CG)+9 a! @ if ENDS -1 + if ENDS \ ; and ex end the word
drop (CG)+1 a! @ -6 + if ENDS drop ; \ and so does its last slot
ENDS: drop jump (FLUSH)
\ ( x -- ) @p and its value
: (LIT,)
(CG)+2 a! @ dup 1 + ! \ x n
(CG)+3 + a! !
8 (PUT)
(CG)+1 a! @ -6 + if FULL drop ;
FULL: drop jump (FLUSH)
\ ( -- addr ) where the next word will go: a branch target
: (LABEL) (FLUSH) HERE ;
\ ( op -- ) a branch (jump 2, call 3, next 5, if 6, -if 7) whose address is
\ not filled in yet. Its ref -- the branch's word address times 8, plus its
\ slot -- is left in (CG)+10. The rest of its word is filled with 0, which
\ is its address field. It ends by jumping to (FLUSH), so that the chain of
\ calls under it is one shorter.
: (BRANCH0)
(CG)+1 a! @ CG-BSLOTS inv + 1 + -if MOVE drop jump PLACED \ slot - CG-BSLOTS
MOVE: drop (FLUSH)
PLACED:
\ the word will be appended at HERE; its literals, if any, come after it
HERE 2* 2* 2* (CG)+1 a! @ + (CG)+10 a! !
(PUT)
0 (CG)+13 a! ! jump (FLUSH)
\ ( op -- ref ) the same, leaving the ref, for (RESOLVE) to fill in later
: (BRANCH>) (BRANCH0) (CG)+10 a! @ ;
\ ( ref -- ) put the address in (CG)+11 into the branch at ref
: (RESOLVE1)
dup 7 and (MASK) push \ ref R: mask
2/ 2/ 2/ a! \ A: the branch's word
(CG)+11 b! @b pop dup push and \ the address bits
@ pop inv and + ! ;
\ ( target ref -- ) put the address into the branch at ref
: (RESOLVE) SWAP (CG)+11 a! ! jump (RESOLVE1)
\ ( target op -- ) a branch to a known address
: (BRANCH,) SWAP (CG)+11 a! ! (BRANCH0) (CG)+10 a! @ jump (RESOLVE1)
: (JUMP,) ( addr -- ) 2 jump (BRANCH,)
: (CALL,) ( addr -- ) 3 jump (BRANCH,)
v4/capsule/compile.v4
-466
View File
@@ -1,466 +0,0 @@
\ compile.v4 -- the interpreter's inner loop, and the defining and compiling
\ words.
\
\ DECOMPOSITION.md 5.17 and 5.18: STATE [ ] : ; EXIT IMMEDIATE LITERAL COMPILE
\ [COMPILE] ' EXECUTE CREATE VARIABLE CONSTANT DOES>, the control structures
\ IF ELSE THEN BEGIN UNTIL AGAIN WHILE REPEAT DO ?DO LOOP +LOOP, and INTERPRET,
\ which they cannot be run without. Part of the compiler capsule. Rests on
\ core.v4, input.v4, dict.v4 and codegen.v4.
\
\ HOW A WORD IS COMPILED. v4 code is native: a colon definition is
\ instruction words, and compiling a word into one lays down a call to it.
\ Two flags on an entry (dict.v4) change that:
\ inline its code is a straight run of opcodes and literals ending
\ in ; -- that run is copied in place of a call. Everything
\ that touches the return stack must be, since a call would
\ bury what it works on (DECOMPOSITION.md 0, fate IN).
\ compile-only it may not be executed by the interpreter.
\ An immediate word is executed even when compiling.
\
\ THE STACKS ARE SHORT: written for ten cells of data and nine return entries
\ (D-2; the host node now has 32 of each, D-17), and one more of either is a
\ fault (D-16). The interpreter and compiler run on the same
\ stacks as the user's words, with the user's values beneath them, so:
\ - every word here keeps what it works on in (C), and has at most three
\ cells of its own on the data stack at any moment;
\ - what an IF or a DO leaves for its THEN or LOOP goes on a control-flow
\ stack in memory, not on the data stack, so structures may nest as
\ deep as that stack (32 cells) allows whatever the user has stacked.
\
\ Constants the loader supplies:
\ STATE word address of the variable: non-zero while compiling
\ (C) word address of ten cells of scratch for this file:
\ (C)+0 (C)+1 (C)+4 the in-liner's word, literal pointer and slot
\ (C)+2 LATEST before a header is made (C)+3 a data word's routine
\ (C)+5 what a loop's end lays after its test
\ (C)+6 (C)+7 a branch and a tag a control word is holding
\ (C)+8 whether a data word's entry was made
\ (C)+9 the error code a line is being abandoned with
\ (CFP) word address of the control-flow stack's pointer
\ CFBASE CFEND word addresses of its first cell and of the cell past its last
macro ROT push SWAP pop SWAP endmacro
\ ---- errors ------------------------------------------------------------------
\ ( -- ) give up the line: stop compiling, forget the word being built and
\ whatever control structures were open, skip the rest of the input, and set
\ NODE-ERROR. A definition that was under way stays hidden. It returns to
\ whatever called INTERPRET, which is QUIT (quit.v4): QUIT sees NODE-ERROR
\ and prints ERROR.
\ (ABANDON-AS) is the same with an error code (core.v4) for the prompt to
\ print the message of.
: (ABANDON-AS) ( code -- )
(C)+9 a! !
0 STATE a! ! (CG-RESET)
CFBASE (CFP) a! !
SPAN a! @ >IN a! !
(C)+9 a! @ NODE-ERROR b! !b ;
: (ABANDON) -1 jump (ABANDON-AS)
\ ---- the control-flow stack ----------------------------------------------------
\ ( x -- ) push; a full stack abandons the line
: >CF
(CFP) a! @ CFEND xor if FULL
drop (CFP) a! @ dup 1 + ! a! ! ;
FULL: drop drop 8 jump (ABANDON-AS) \ control structures too deep
\ ( -- x ) pop; 0 from an empty stack, which no opening word leaves
: CF>
(CFP) a! @ CFBASE xor if EMPTY
drop (CFP) a! @ -1 + dup ! a! @ ;
EMPTY: ;
\ ---- compiling one word ------------------------------------------------------
\ ( w -- op ) the opcode in slot 0 of the instruction word w
: (TOP5) 8/ 8/ 8/ 2/ 2/ 2/ 31 and ;
\ ( xt -- ) copy the in-line word at xt into the definition being built.
\ Each slot is read from the top of the word in (C)+0, which is then moved
\ up five bits for the next.
: (INLINE,)
W: dup a! @ (C) a! ! 1 + (C)+1 a! ! \ the word, and its literals after it
0 (C)+4 a! ! \ slot
S: (C) a! @ dup 2* 2* 2* 2* 2* ! (TOP5) \ op
if END \ ; ends the copy
dup -8 + if LIT
drop dup -28 + if NOP \ nop is padding
drop (OP,)
NXT: (C)+4 a! @ 1 + dup ! -6 + if NEXTW drop jump S
NEXTW: drop (C)+1 a! @ jump W \ the next instruction word follows the literals
LIT: drop drop (C)+1 a! @ dup 1 + ! a! @ (LIT,) jump NXT
NOP: drop drop jump NXT
END: drop ;
\ ( xt -- ) compile the word at xt: in line if it is flagged so, else a call
: (COMPILE,)
dup -3 + a! @ 8 and if CALL drop jump (INLINE,)
CALL: drop jump (CALL,)
\ ---- access control (5.20) -------------------------------------------------------
\ Each entry's flags cell also holds its access control fields:
\ bit 5 (32) denied: the word may not be used
\ bit 6 (64) pinned: the fields cannot be changed
\ bits 8 .. 15 the mode: 0 TTL, 1 STRICT
\ bits 16 .. 31 the TTL, a count of uses left before the next recheck
\ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0.
\
\ (ACL?) is run by INTERPRET for every word it is about to execute or
\ compile. As v3: if the TTL is 0 the word is rechecked, otherwise the TTL
\ is counted down; then a denied word is refused. The recheck is the word
\ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded --
\ and with none there the word is allowed and given the longest TTL.
\
\ v3 checks every execution, inside definitions too. v4 code is native: a
\ compiled call goes straight to its word. So v4 checks a word when it is
\ compiled as well as when it is interpreted -- a denied word cannot be
\ built into anything new -- but a call compiled while the word was allowed
\ is not checked again.
\ ( xt -- ) recheck
: (ACL-RECHECK)
(ACL-HOOK) a! @ if NONE push ex \ call it with the xt
;
NONE: drop -3 + a! @ 65535 and -33 and $FFFF0000 + ! ;
\ ( xt -- xt ) as above; a denied word ends the line
: (ACL?)
dup -3 + a! @ \ xt flags
dup $FFFF0000 and if ZERO
drop -65536 + ! jump TEST \ one use fewer
ZERO: drop drop dup (ACL-RECHECK)
TEST: dup -3 + a! @ 32 and if OK
drop drop
$33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) \ v3's line: WARN: in yellow
$3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4)
(.WORD) 39 EMIT CR
DSTACK-DEPTH b! a !b \ as v3, the stack is emptied
pop drop jump (ABANDON)
OK: drop ;
\ ( -- ) print the word WORD has just left
: (.WORD) WBUF COUNT jump TYPE
header EXECUTE
: EXECUTE ( xt -- ) push ;
\ ---- the interpreter's inner loop ---------------------------------------------
\ ( -- n flag ) the word WORD has just left, as a single-cell number in the
\ current BASE, and -1; or 0 0 if it is not one. A leading minus sign is
\ allowed. This is what the interpreter uses: NUMBER (input.v4) makes a
\ double and needs more of the stack than can be spared here.
\ (P)+2 the number so far, (P)+3 where it is in the word, (P)+4 the word's
\ length, (P)+5 the sign, (P)+6 the base.
: (NUM?)
WBUF C@ if EMPTY
(P)+4 a! ! 0 (P)+2 a! ! 1 (P)+3 a! ! 0 (P)+5 a! !
(BASE) (P)+6 a! !
WBUF+1 C@ -45 + if NEG drop jump DIGITS
NEG: drop -1 (P)+5 a! ! 2 (P)+3 a! !
(P)+4 a! @ -1 + if EMPTY drop \ a sign alone
DIGITS:
L: (P)+4 a! @ (P)+3 a! @ - -if MORE
drop (P)+2 a! @ (P)+5 a! @ if POS drop NEGATE -1 ;
POS: drop -1 ;
MORE: drop
(P)+3 a! @ dup 1 + ! WBUF + C@ (DIGIT) \ d
-if DIGIT jump BAD1
DIGIT: dup (P)+6 a! @ - -if BAD2 drop
(P)+2 a! @ (P)+6 a! @ STAR + (P)+2 a! !
jump L
BAD2: drop
BAD1: drop 0 0 ;
EMPTY: drop 0 0 ;
\ ( -- ) FORTH-79: take words from the input stream until it is exhausted.
\ A word in the dictionary is executed, or, when compiling and not immediate,
\ compiled. Anything else must be a number in the current BASE: it is left
\ on the stack, or compiled as a literal. What is neither, or a compile-only
\ word met while interpreting, abandons the line, with v3's message:
\ UNKNOWN WORD: 'xxx' xxx: compile-only
header INTERPRET
: INTERPRET
L: 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
dup -3 + a! @ \ xt flags
STATE a! @ if INTERP
drop 1 and if COMP \ compiling: immediate words still run
drop (ACL?) EXECUTE jump L
COMP: drop (ACL?) (COMPILE,) jump L
INTERP: drop 16 and if RUN
drop drop (.WORD) \ ": compile-only"
$6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR
jump (ABANDON)
RUN: drop (ACL?) EXECUTE jump L
NUM: drop (NUM?) if BAD
drop
STATE a! @ if KEEP drop (LIT,) jump L
KEEP: drop jump L
BAD: drop drop (UNKNOWN) drop jump (ABANDON)
EOL: drop drop ;
\ ---- state ---------------------------------------------------------------------
header [ immediate
: LEFT-BRACKET 0 STATE a! ! ;
header ]
: RIGHT-BRACKET -1 STATE a! ! ;
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
header LITERAL immediate
: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ;
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
\ compiling, compiled as a literal
header ' immediate
: TICK (') jump LITERAL
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
\ which v3 has as another name for LITERAL.
header ['] immediate compile-only
: BRACKET-TICK (') jump (LIT,)
header [LITERAL] immediate
: BRACKET-LITERAL jump LITERAL
\ ---- colon definitions -----------------------------------------------------------
\ FORTH-79: start a definition; it cannot be found until ; ends it. The
\ CONTEXT vocabulary is set to the CURRENT one.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
header :
: COLON
CURRENT a! @ CONTEXT a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
HIDDEN (CG-RESET) CFBASE (CFP) a! ! jump RIGHT-BRACKET
NONE: drop jump (ABANDON) \ no entry: the rest of the line is not a definition
\ FORTH-79: compile the return, let the word be found, stop compiling
header ; immediate compile-only
: SEMICOLON
0 (OP,)
LATEST (FLAGS) a! @ -3 and !
jump LEFT-BRACKET
\ ( n -- ) KERNEL-WORD xxx A WORD THAT ASKS THE KERNEL (docs/v4.0.0/
\ ENGINE.md 3.3). xxx is made a word whose whole body is "write n to the
\ port": n is the number of a request, the port is the node's way to its
\ kernel, and the write blocks the node until the kernel has served it
\ (DECOMPOSITION.md section 6). xxx's arguments are whatever it finds on
\ the data stack and its results are what the kernel leaves there. This is
\ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a
\ node. Not FORTH-79 and not in v3, where such a word is registered from C.
\ The constant (PORT) is the port's word address.
header KERNEL-WORD
: KERNEL-WORD
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
jump SEMICOLON
\ FORTH-79: return from the definition at this point
header EXIT immediate compile-only
: EXIT 0 jump (OP,)
header IMMEDIATE
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
header COMPILE immediate compile-only
: COMPILE
32 WORD (LOOKUP) if MISSING
(LIT,) &(COMPILE,) jump (CALL,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate
header [COMPILE] immediate compile-only
: BRACKET-COMPILE
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ ---- data words ---------------------------------------------------------------------
\ A data word's code is one call to its run-time routine; the call leaves the
\ address of the cell after it -- the parameter field -- on the return stack.
: (DOVAR) pop ; \ leave the parameter field address
: (DOCON) pop a! @ ; \ leave what it holds
\ ( -- ) an entry for the next word, flagged data, its code a call to the
\ routine whose address is in (C)+3. (C)+8 is left -1 if one was made, else
\ 0. It ends by jumping, and CREATE jumps to it, so that a defining word
\ has as few return entries under it as can be.
: (DATA)
0 (C)+8 a! !
LATEST (C)+2 a! !
32 WORD (HEADER)
LATEST (C)+2 a! @ xor if NONE drop
(CG-RESET)
LATEST (FLAGS) a! @ 4 OR !
-1 (C)+8 a! !
(C)+3 a! @ jump (CALL,)
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
header CREATE
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
\ programme; here it is 0.
header VARIABLE
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
\ ( n -- ) FORTH-79: an entry whose word leaves n
header CONSTANT
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ;
\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become
\ what each word DEFINER makes does, starting with its parameter field address
\ on the stack. (DOES), run by DEFINER, turns the newest entry's code into a
\ call to the code after it and leaves DEFINER; that code starts with pop,
\ which fetches the parameter field address the call left.
: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0
header DOES> immediate compile-only
: DOES> &(DOES) (CALL,) 25 jump (OP,)
\ ---- control structures (5.18, section 2) ---------------------------------------------
\ All immediate and compile-only. Each puts what the word that closes it
\ needs on the control-flow stack, with a number on top saying which word put
\ it there: 1 IF, 2 ELSE, 3 BEGIN, 4 WHILE, 5 DO, 6 ?DO, 7 CASE, 8 OF. A closing word that
\ finds the wrong number abandons the line.
\ ( tag wanted -- ) if they differ, abandon the line and leave the control
\ word that called this as well: its return address is dropped, so the
\ abandoning returns to the interpreter and nothing more is laid down.
: (PAIR) xor if OK drop pop drop 7 jump (ABANDON-AS) OK: drop ;
\ ( ref -- ) the branch at ref lands here
: (HERE!) (FLUSH) HERE SWAP jump (RESOLVE)
\ Native if leaves the flag, so both ways out of it drop it (section 2):
\ IF a THEN if L1 drop a jump L2 L1: drop L2:
\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2:
header IF immediate compile-only
: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF
header ELSE immediate compile-only
: ELSE
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF \ the jump over the else part
(C)+6 a! @ (HERE!) 23 (OP,)
2 jump >CF
header THEN immediate compile-only
: THEN
CF> dup -1 + if PLAIN
drop 2 (PAIR) CF> jump (HERE!)
PLAIN: drop drop
CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF
(C)+6 a! @ (HERE!) 23 (OP,)
CF> jump (HERE!)
\ A loop that tests at its end jumps back with the flag still there, so it
\ jumps back to a drop laid just ahead of the body:
\ BEGIN a UNTIL jump L0 Ld: drop L0: a if Ld drop
\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop
\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0
\ The control-flow stack holds Ld, L0 and 3.
header BEGIN immediate compile-only
: BEGIN
2 (BRANCH>) (C)+6 a! !
(LABEL) >CF 23 (OP,)
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
3 jump >CF
header UNTIL immediate compile-only
: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,)
header AGAIN immediate compile-only
: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ;
header WHILE immediate compile-only
: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF
header REPEAT immediate compile-only
: REPEAT
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
CF> 3 (PAIR) CF> (JUMP,) CF> drop
(C)+6 a! @ (HERE!) 23 jump (OP,)
\ CASE: the value being chosen on stays on the stack through the clauses.
\ CASE x1 OF a ENDOF x2 OF b ENDOF c ENDCASE
\ lays, for each clause,
\ over xor if M drop jump N M: drop drop a jump END N:
\ and ENDCASE lays the drop that the part after the last ENDOF leaves the
\ value for, with END after it. The control-flow stack holds the jumps to
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
: (of) over xor ;
header CASE immediate compile-only
: CASE 0 >CF 7 jump >CF
header OF immediate compile-only
: OF
CF> 7 (PAIR)
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
8 jump >CF
header ENDOF immediate compile-only
: ENDOF
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
CF> (C)+7 a! ! \ how many jumps to END so far
2 (BRANCH>) >CF \ one more
(C)+7 a! @ 1 + >CF
(C)+6 a! @ (HERE!) \ N:
7 jump >CF
header ENDCASE immediate compile-only
: ENDCASE
CF> 7 (PAIR) CF> (C)+7 a! !
23 (OP,)
L: (C)+7 a! @ if DONE -1 + !
CF> (HERE!) jump L
DONE: drop ;
\ DO loops: the limit and index are on the return stack, limit below (5.18).
: (do) over push push drop ;
: (?do) over over xor ;
: (inc) pop 1 + pop ; \ index' limit
: (+inc) dup a! pop + pop ; \ index' limit A: the step
: (differ) drop over ;
: (same) drop over over - ;
: (a-xor) a xor ;
: (again) drop push push ;
: (3drop) drop drop drop ;
\ The end of a loop. The control-flow stack holds the body's address and 5,
\ or for ?DO its skip, the body and 6; (C)+5 holds the xt of in-line code to
\ lay after the test, or 0. Laid down, in order:
\ <less> ( i' lim -- i' lim s ), the top bit of s set when i' < lim:
\ over over xor -if SAME drop over jump T SAME: drop over over - T:
\ the code in (C)+5, if any
\ -if EXIT drop push push jump BODY EXIT: drop drop drop
\ and for ?DO the landing of its skip: jump PAST SKIP: drop drop drop PAST:
\ It is one word, jumped to by LOOP and +LOOP, so that laying a loop's end
\ takes as few return entries as laying anything else.
: (LOOPS)
&(?do) (INLINE,) 7 (BRANCH>) >CF
&(differ) (INLINE,) 2 (BRANCH>) (C)+6 a! !
CF> (HERE!) &(same) (INLINE,)
(C)+6 a! @ (HERE!)
(C)+5 a! @ if NOMORE (INLINE,) jump TESTED
NOMORE: drop
TESTED:
CF> (C)+7 a! ! \ the tag
7 (BRANCH>) (C)+6 a! !
&(again) (INLINE,) CF> (JUMP,)
(C)+6 a! @ (HERE!) &(3drop) (INLINE,)
(C)+7 a! @ -5 + if PLAIN
drop (C)+7 a! @ 6 (PAIR)
2 (BRANCH>) (C)+6 a! !
CF> (HERE!) &(3drop) (INLINE,)
(C)+6 a! @ jump (HERE!)
PLAIN: drop ;
header DO immediate compile-only
: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF
header ?DO immediate compile-only
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
header LOOP immediate compile-only
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
header +LOOP immediate compile-only
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
v4/capsule/core.v4
-479
View File
@@ -1,479 +0,0 @@
\ core.v4 -- the core words the host-node capsules rest on.
\
\ Each is the definition DECOMPOSITION.md gives and the golden-model tests
\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c),
\ written here as text for the text assembler (v4/include/v4/text.h).
\
\ Constants the loader supplies: N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX,
\ CONSOLE-RX, CONSOLE-STATUS, BASE, (MSG), (REPLY), (ME), (OUT),
\ (OUT^), (CONSOLE), (ROUTES), (ROUTE#), (ROUTE-DEFAULT), (PRINT-TO),
\ (PRINT-PORT).
\
\ ERRORS (D-18). A word that finds an error takes its arguments off the stack
\ and stores a code in NODE-ERROR. On a node with a prompt that store is a
\ trap: the word goes no further, and the prompt prints the message for the
\ code and ERROR (quit.v4, (RAISED)). The codes:
\ 1 Negative count 2 Not a number 3 Number too long
\ 4 Not a character 5 Dictionary full 6 Name missing
\ 7 Control structure mismatch 8 Control structures too deep
\ 9 Shift count out of range 10 Protected word
\ 11 Division by zero (Q./) 12 Argument out of range
\ 13 Block out of range 14 No block is being loaded
\ 15 Deferred word not set 16 Not a word
\ 17 Storage refused 18 No one on that port
\ 19 Message refused 20 Node gone
\ 21 Interrupted
\ -1 the word has printed its own message
macro SWAP over push push drop pop pop endmacro
macro - push inv pop + inv endmacro \ x y -- x-y
macro NEGATE inv 1 + endmacro
macro NIP push drop pop endmacro
\ ---- section 4: multiply ------------------------------------------------
header UM*
: UM* ( u1 u2 -- ulo uhi )
over 1 and inv 1 + over 2/ and \ u1 u2 t0 t0 = u2 2/ if u1 odd
over a! N-1 push \ A: u2 R: loop count
push over 2/ pop \ u1 u2 s t0 s = u1 2/
L: +* unext \ u1 u2 s hi A: lo
push drop pop \ u1 u2 hi
2* a -if L0 drop 1 + jump L1 L0: drop L1: push
over -if L2 drop dup jump L3 L2: drop 0 L3: push
dup -if L4 drop over 1 and jump L5 L4: drop 0 L5:
pop + pop + push
and 1 and a 2* + pop ;
\ ---- section 5.7: doubles ------------------------------------------------
header D+
: D+ ( d1 d2 -- d3 )
push over push push drop pop \ al bl R: bh ah
over over xor -if L1
drop + -if C1 jump C0
L1: drop over -if L2
drop + jump C1
L2: drop +
C0: pop pop + ;
C1: pop pop + 1 + ;
header DNEGATE
: DNEGATE ( d -- -d )
inv over if L1 drop push inv 1 + pop ;
L1: drop 1 + ;
\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2). The result is the same.
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
header C@
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop @ 8/ 8/ 8/ 255 and ;
K2: drop @ 8/ 8/ 255 and ;
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
header C!
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
drop 8* 8* 8* 4278190080 and @ 4278190080 inv and + ! ;
K2: drop 8* 8* 16711680 and @ -16711681 and + ! ;
K1: drop 8* 65280 and @ -65281 and + ! ;
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
header CMOVE
: CMOVE ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push
over C@ over C! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
\ ---- section 5.10: the console -------------------------------------------
\ ---- what a node prints (docs/v4.0.0/MESH.md section 6) ------------------------
\ A node has no console of its own. It does what a message asks, and what
\ it prints while doing it is sent as a message: to the node in (CONSOLE), or
\ if that is 0 to whoever sent the text; by the port that leads there, or if
\ this node knows of none, by the port the text came on. A message is seven words and then its text, four
\ characters to a word:
\ to, from, type, heat and TTL, ACL tag, sequence, length in characters
\ The types: 1 text to be interpreted 2 what a node printed 3 how the
\ text ended (one word of text: 0 QUIT, 1 completed, 2 an error).
\ The header of the text being served is in the seven cells (MSG); (REPLY)
\ is the port it came on, by its number; (ME) is this node's number.
\
\ Characters are kept in (OUT), 256 of them, a character to a cell, and sent
\ when it is full and when the text has been done with (quit.v4). (OUT^)
\ is where the next goes.
\
\ THE STACK. What prints may be run with the data stack all but full: EMIT
\ has always needed one free cell and no more, and still does -- it keeps
\ the character and A on the return stack while it works. Sending needs
\ three.
\ FINDING THE WAY (MESH.md section 7). A node knows its ports and nothing of
\ the shape they are wired in. Whoever wires it tells it, for a node, which
\ port leads toward that node: the table (ROUTES), (ROUTE#) entries of a
\ node's number and a port's address; and (ROUTE-DEFAULT), the port for any
\ node that is not in the table, or 0.
\ ( node -- port | -1 ) the port, by its number, that leads toward the node
: (WAY)
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
0
NONE: drop drop (ROUTE-DEFAULT) a! @ if NOWAY (PORT) - ;
NOWAY: drop -1 ;
HIT: drop drop @+ pop drop (PORT) - ;
\ WHOLE MESSAGES (MESH.md section 7d). A message waits on a wire, in the
\ fabric, and not in a node: each wire has a queue of whole messages each
\ way. A node asks the fabric to look at one, take it, move it to another
\ wire, drop it, or put one on, by the six addresses after its ports:
\ (WIRE) the port, by its number, that what follows is about
\ (WIRE-A) (WIRE-B) what the operation needs
\ (WIRE-DO) the operation: a store here is the asking
\ (WIRE-HOW) how it went: 0 done, 1 no room, 2 no one on that port,
\ 3 no such message, 4 not a message
\ (WIRE-HAVE) which wires have a message waiting, a bit to a port
\ The operations: 1 look 2 take 3 move 4 drop 5 put 6 first 7 next
\ 8 sleep 9 sleep for room 10 room. Each is whole: all of a message
\ moves or none of it. So a fault or an error in the middle of anything
\ here leaves no message half moved; and nothing here keeps, from one
\ operation to the next, anything a later pass does not set again for
\ itself: every pass over a wire begins by naming the wire and putting its
\ mark at its first message.
\ This replaced a ring of messages waiting in the node's own memory, a
\ list of refusals owed, and messages written and read a word at a time
\ (MESH.md 7a, 7b, 7c.6). The ports themselves are still written a word at
\ a time for the two things that are not messages: a newborn node's
\ nucleus (PORT!, quit.v4) and a node's requests to its kernel.
\
\ THE STACKS. All of this runs on the stacks the node's text is using.
\ (SERVE) and what it calls keep to four cells of the data stack and four
\ entries of the return stack, its own call among them; what they need
\ from one operation to the next is in cells. (ROOM-SERVE) tries that much.
\ ( op -- how ) ask the fabric for the operation, and say how it went
: (DO) (WIRE-DO) b! !b (WIRE-HOW) b! @b ;
\ ( port -- ) what is asked next is about that port's wire, by its number.
\ A number that is no port's is no wire: every operation then answers 2.
: (WIRE!) (WIRE) b! !b ;
\ ( cells port -- how ) has the port's wire that many cells free? 0: it
\ has; 1: it has not; 2: no one is on that port. Only this node puts
\ messages on the wires that lead from it, so room found stays until it
\ uses it.
: (ROOM?) (WIRE!) (WIRE-A) b! !b 10 jump (DO)
\ ( -- ) ROOM FOR WHAT A WAIT DOES. A node that waits within text -- for
\ an answer, or for room to print -- passes on meanwhile what comes for
\ other nodes, on the stacks the text has left it: four cells of the data
\ stack and four entries of the return stack, (SERVE)'s. They are tried
\ before anything is taken off a wire or put on one: if they are not there
\ the fault comes here, and the text ends "Stack overflow" with nothing
\ half done (MESH.md 7c.7, 7d.4).
\ (ROOM-SERVE) tries just those, and is what a wait for room does each time
\ a message wakes it. (ROOM), which AWAIT does once before it waits, tries
\ six cells, as it did when a message was read a word at a time: the wait
\ ends in an error that leaves the stack as it is, and the line from the
\ console that broke it is then done on that stack, where printing needs
\ six (MESH.md 7c.7).
: (ROOM-SERVE)
0 0 0 0 drop drop drop drop
0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ;
: (ROOM)
0 0 0 0 0 0 drop drop drop drop drop drop
0 push 0 push 0 push 0 push pop drop pop drop pop drop pop drop ;
\ ( to type -- ) the first six words of a message this node puts, in
\ (OUT-HDR): to, from, type, and the three that are carried: how many nodes
\ may pass it on, sixteen (the TTL: MESH.md 7b.3); ACL tag; sequence.
: (HDR)
push (OUT-HDR) a! !+ (ME) b! @b !+ pop !+ 16 !+ 0 !+ 0 !+ ;
\ ( text port -- how ) put the message whose seven words are in (OUT-HDR)
\ and whose text is at the word address given on the wire of the port, by
\ its number. How it went is the fabric's answer: 0 it is on the wire.
\ THE ROOM KEPT FOR AN ANSWER. While this node does text, (KEEP) is the
\ port its word of how the text ended will go by, and nothing else it puts
\ on that wire may take the last 8 cells: a message that would is refused
\ here, 1, as if the wire were full. With no text being done (KEEP) is -1.
: (PUT-ON)
push (WIRE-B) b! !b pop
dup (WIRE!)
(KEEP) a! @ xor if KEPT
GO: drop (OUT-HDR) (WIRE-A) b! !b 5 jump (DO)
KEPT: drop (OUT-HDR)+6 a! @ 3 + 2/ 2/ 15 + (WIRE-A) b! !b 10 (DO) if GO ;
\ REFUSALS (MESH.md 7b, 7d.4). A message this node cannot pass on is
\ dropped and counted in (LOST), and whoever waits on it is told, by a
\ message of type 4, a NACK, whose one word is the node the refused message
\ was for: its sender; or, for a node's answer (type 3), the node the
\ answer was for, which is the one that waits, about the node that
\ answered. The NACK is put at once. If it cannot go -- no way, no one on
\ the port, no room -- it is counted in (LOST) too, and that is the end of
\ it. Nothing is told for a NACK or for a GONE, type 5: there is no NACK
\ for a NACK.
\ ( -- ) the message the mark of the wire in (WIRE) is at, whose seven
\ words are in (IN), is refused. A refusal for this node itself -- its own
\ message came back to it -- is counted in (REFUSED) as one that came by a
\ wire would be; or, if it is about the node this one is waiting on,
\ (A-SELF) is set for AWAIT to find (quit.v4).
\ (WIRE) is not what it was afterwards: the NACK went by another.
\ If the drop does not drop -- the wire was cut after the message was looked
\ at, which let it go already -- nothing is counted and no one is told.
: (REFUSE)
4 (DO) if DROPPED drop ; \ it was not there to drop -- its wire has been cut: nothing is counted or told
DROPPED: drop
(LOST) a! @ 1 + !
(IN)+2 a! @ -4 + if NOT -1 + if NOT 2 + if ANSWER
drop (IN) a! @ (ONE) a! ! (IN)+1 a! @ jump TELL \ about whom it was for; to its sender
ANSWER: drop (IN)+1 a! @ (ONE) a! ! (IN) a! @ \ about the node that answered; to whom the answer was for
TELL: dup (ME) a! @ xor if SELF drop
dup 4 (HDR) 4 (OUT-HDR)+6 a! !
(WAY) (ONE) SWAP (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! ;
SENT: drop ;
SELF: drop drop
(AWAIT-FROM) a! @ if COUNT (ONE) a! @ xor if MINE
COUNT: drop (REFUSED) a! @ 1 + ! ;
MINE: drop 1 (A-SELF) a! ! ;
NOT: drop ;
\ ( port -- bit ) the bit for a port, by its number, in a word of a bit to a port
: (WBIT)
push 1 pop if Z -1 + FOR 2* NEXT ;
Z: drop ;
\ ( -- ) A MESSAGE FOR ANOTHER NODE is passed on (MESH.md section 7): the
\ one the mark of the wire in (WIRE) is at, whose seven words are in (IN),
\ is moved, whole, to the wire that leads toward that node. It is refused
\ instead if it has been passed on as often as a message may be; or if
\ there is no way, or no one on the port.
\ WITH NO ROOM on that wire -- or none but the room kept on it, (KEEP) --
\ text, a NACK and a GONE are refused, at once. But what a node printed
\ (type 2) and its word of how text ended (type 3) are NOT let go for want
\ of room: the message is left where it is, on the wire it came by, and
\ gone past; what is behind it is served; and it is moved on a later pass,
\ when there is room. Printing waits; it is not lost (MESH.md 7d.1,
\ ruling 3). (H-PORT) and (H-NEED) are the port of the first message left
\ so on this pass and the cells it needs there: a node that then sleeps,
\ sleeps for that room, (SLEEP), and is woken by room on any wire.
\ (H-MASK) has a bit for each port something was left for: what is behind
\ it for the same port is left too, though it be shorter and would fit, so
\ that what a node printed goes on in the order it came.
\ HOW OFTEN. A message's fourth word is how many more nodes may pass it
\ on; a node sends it with 16, and a move takes one off. The node that
\ finds 1 there refuses it. A device sends it with 0, which is taken for
\ 16: so 0 down to -14 are passed on and -15 is refused. Anything else is
\ nothing a node or a device sent, and is refused.
: (PASS)
(IN)+3 a! @ -if POS
14 + -if OK jump SPENT
POS: if OK -1 + if SPENT -16 + -if SPENT
OK: drop
(IN) a! @ (WAY) (P-WAY) a! !
(IN)+6 a! @ 3 + 2/ 2/ 7 + \ the cells it takes,
(P-WAY) a! @ (KEEP) a! @ xor if KEPT drop jump NEED
KEPT: drop 8 + \ and the room kept, if it is that wire
NEED: (P-NEED) a! !
(P-WAY) a! @ -if WAY \ no way: refused
SPENT: drop jump (REFUSE)
WAY: (WBIT) (H-MASK) a! @ and if CLEAR \ something is left for that port already?
FULL: drop (IN)+2 a! @ -2 + if HOLD -1 + if HOLD jump SPENT \ no room: only output and answers wait
CLEAR: drop
(P-NEED) a! @ (P-WAY) a! @ (ROOM?) (S-WIRE) a! @ (WIRE!)
if GO -1 + if FULL jump SPENT \ no one on that port: refused
GO: drop (P-WAY) a! @ (WIRE-A) b! !b 3 (DO) if MOVED jump SPENT
MOVED: drop ;
HOLD: drop
(P-WAY) a! @ (WBIT) dup inv (H-MASK) a! @ and + !
(H-PORT) a! @ -if HELD drop (P-WAY) a! @ (H-PORT) a! ! (P-NEED) a! @ (H-NEED) a! ! 7 (DO) drop ;
HELD: drop 7 (DO) drop ;
\ ( -- ) SLEEP until a message comes -- or, if (SERVE) left a message
\ on a wire for want of room, until there is that room or a message comes
\ or any wire of this node's gains room (operation 9, MESH.md 7d.3).
: (SLEEP)
(H-PORT) a! @ -if ROOM drop 8 (DO) drop ;
ROOM: (WIRE!) (H-NEED) a! @ (WIRE-A) b! !b 9 (DO) drop ;
\ ( -- ) ONE PASS OVER EVERY WIRE THAT HAS A MESSAGE. What is for another
\ node is passed on, or refused; what is for this node is left where it
\ is. Fetching (WIRE-HAVE) is what tells the fabric this node has seen
\ what had come: a sleep after this is woken only by what comes later
\ (MESH.md 7d.3). (S-HAVE) keeps which wires they were, for whoever then
\ looks for what is this node's own, (MINE).
: (SERVE)
(WIRE-HAVE) b! @b dup (S-HAVE) a! ! (S-MASK) a! !
0 (S-WIRE) a! ! -1 (H-PORT) a! ! 0 (H-MASK) a! !
W: (S-MASK) a! @ if END
dup 2/ ! 1 and if NEXTW
drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop
M: (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED jump NEXTW
LOOKED: drop
(IN) a! @ (ME) a! @ xor if MINE drop (PASS) jump M
MINE: drop 7 (DO) drop jump M
NEXTW: drop (S-WIRE) a! @ 1 + ! jump W
END: drop ;
\ WHAT IS FOR THIS NODE is gone through after (SERVE), a message at a time:
\ (MINE0) begins, and each (MINE) puts the mark of a wire at the next
\ message for this node and its seven words in (IN). Whoever asked then
\ takes or drops that message -- the mark is then at the one that followed
\ -- or leaves it and goes past it, (SKIP). The wire is (S-WIRE).
\ ( -- ) begin with the wires (SERVE) found a message on
: (MINE0) (S-HAVE) a! @ (S-MASK) a! ! -1 (S-WIRE) a! ! 0 (S-ON) a! ! ;
\ ( -- flag ) the next message for this node; 0: there are no more
: (MINE)
L: (S-ON) a! @ if WIRE
drop (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b 1 (DO) if LOOKED
drop 0 (S-ON) a! ! jump L \ this wire has no more
LOOKED: drop (IN) a! @ (ME) a! @ xor if HIT
drop 7 (DO) drop jump L
HIT: drop -1 ;
WIRE: drop (S-WIRE) a! @ 1 + ! \ the next wire that had one
(S-MASK) a! @ if NONE
dup 2/ ! 1 and if NOT
drop (S-WIRE) a! @ (WIRE!) 6 (DO) drop 1 (S-ON) a! ! jump L
NOT: drop jump L
NONE: ;
\ ( -- ) go past the message (MINE) found: it stays on its wire
: (SKIP) (S-WIRE) a! @ (WIRE!) 7 (DO) drop ;
\ ( -- ) A TAKE DID NOT TAKE the message (MINE) found. The fabric takes
\ only the message last looked at (MESH.md 7d.3), so either the wire has
\ been cut -- and there is nothing there, or another message that has not
\ been looked at -- or the message cannot be taken at all. It is dropped,
\ and counted in (LOST); if it cannot be dropped either it is gone past.
\ Either way whoever goes through the messages next is at another one:
\ nothing goes round on one that will not be taken.
: (UNTAKEN)
(S-WIRE) a! @ (WIRE!) 4 (DO) if GONE drop jump (SKIP)
GONE: drop (LOST) a! @ 1 + ! ;
\ ( -- how ) take the message (MINE) found, which has one word of text:
\ its seven words stay in (IN), and its word goes to (ONE). 0: it is
\ taken. Anything else: it is not -- the wire was cut after the message
\ was looked at -- and (ONE) is not its word: nothing is to be done for it.
: (TAKE1) (S-WIRE) a! @ (WIRE!) (IN) (WIRE-A) b! !b (ONE) (WIRE-B) b! !b 2 jump (DO)
\ ( -- how ) WAIT UNTIL THE WIRE of the port (W-PORT) has (W-NEED) cells
\ free. 0: it has. 2: no one is on that port. The node sleeps until
\ there is room, or a message comes, or another wire of its own gains
\ room; woken with no room yet, it passes on what is for other nodes,
\ (SERVE), and sleeps again. It is the one thing a node waits to put:
\ what a text prints (MESH.md 7d.1, ruling 3).
\ NOTHING BREAKS THIS WAIT but the room coming or the wire being cut
\ (ruled 2026-10-08): text for this node that comes meanwhile, from its
\ console or anyone, stays on its wire and is done when this text has been
\ finished with. A text whose printing can never go, because a stuck node
\ is on the way, waits until that node is killed (MESH.md 7d.6).
: (WAIT-ROOM)
L: (W-PORT) a! @ (WIRE!) (W-NEED) a! @ (WIRE-A) b! !b 9 (DO)
if DONE -1 + if WOKEN drop 2 ;
WOKEN: drop (WIRE-HAVE) b! @b if QUIET \ no wire has a message: there is nothing to pass on,
drop (ROOM-SERVE) (SERVE) jump L \ and no more of the stacks is asked for than a wait needs
QUIET: drop jump L
DONE: ;
\ ( -- ) send what has been printed, to where (PRINT-TO) says, by the port
\ (PRINT-PORT): a message of type 2, its characters four to a word, the
\ first lowest. quit.v4 sets those two when text for this node arrives.
\ It waits for room on the wire, and for the 8 cells kept as well when the
\ wire is the one the answer goes by. The characters are made ready in
\ (OUT-TEXT), not where they are: until the message is on the wire the
\ buffer is as it was, and a fault on the way leaves it to be sent again.
\ The three cells after the last character are made zero first, so that
\ nothing printed earlier goes on the wire in the last word (they are in
\ the buffer, or the four free cells after it).
\ The three cells and two return entries this needs are tried first.
\ WITH NO ONE ON THE PORT -- when it waits for room, or when it comes to
\ put -- what was printed cannot be sent. While the text is being done
\ that is its error, 18; and the data stack is emptied first, as a fault
\ empties it. A word that raises an error has taken its own arguments
\ off; this one comes from under whatever word was printing, in the
\ middle of its work, and what that word had on the stack is nothing its
\ caller can use (as first built those values were left there). Once it has been finished with, what it printed
\ is let go and counted in (LOST), and the text is said to have ended in
\ an error: (LINE-STATUS), which is the word then sent of how it ended.
: (FLUSH-OUT)
(OUT^) a! @ (OUT) xor if NONE drop
0 0 0 drop drop drop 0 push 0 push pop drop pop drop
(OUT^) a! @ (OUT) - 3 + 2/ 2/ 7 +
(PRINT-PORT) a! @ (KEEP) a! @ xor if SAME drop jump NEED
SAME: drop 8 +
NEED: (W-NEED) a! ! (PRINT-PORT) a! @ (W-PORT) a! !
(WAIT-ROOM) if ROOM
NOONE: drop (QUIET) a! @ if TELL
drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! 2 (LINE-STATUS) a! ! ;
TELL: drop DSTACK-DEPTH b! a !b NODE-ERROR b! 18 !b ; \ the data stack is emptied, as by a fault: see below
ROOM: drop
(PRINT-TO) a! @ 2 (HDR)
(OUT^) a! @ a! 0 !+ 0 !+ 0 !
(OUT^) a! @ (OUT) - dup (OUT-HDR)+6 a! !
3 + 2/ 2/ -1 + push (OUT-TEXT) pop (OUT) a!
FOR @+ @+ 8* + @+ 8* 8* + @+ 8* 8* 8* + over b! !b 1 + NEXT
drop
(OUT-TEXT) (PRINT-PORT) a! @ (PUT-ON) if SENT jump NOONE
SENT: drop (OUT) (OUT^) a! ! ;
NONE: drop ;
\ EMIT puts the character with what has been printed. Everything the node
\ prints goes through EMIT. A is kept: the words that print have always
\ been free to use it across an EMIT. As v3, only the low 8 bits of the
\ character are printed.
\ A BUFFER FOUND FULL is sent first. It is full when a flush of it ended
\ in a fault -- the stack too deep to begin a message -- and what is printed
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
header EMIT
: EMIT ( c -- )
255 and a push push \ A, and then the character, to the return stack
(OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT
STALE: drop (FLUSH-OUT)
PUT:
(OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on
a (OUT)+256 xor if FULL drop pop a! ;
FULL: drop (FLUSH-OUT) pop a! ;
header KEY
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
header CR
: CR ( -- ) 10 jump EMIT
header SPACE
: SPACE ( -- ) 32 jump EMIT
header COUNT
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
header TYPE
: TYPE ( baddr u -- )
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
DONE: drop drop ;
\ ( x -- ) up to four characters packed in one cell, the first in the low
\ byte: how the capsule prints its own short messages, a literal at a time.
: (EMIT4)
L: if DONE dup EMIT 8/ jump L
DONE: drop ;
\ ---- section 5.8: the number base ----------------------------------------
: (BASE) ( -- b ) \ BASE, or 10 when it is outside 2 .. 36
BASE b! @b dup -2 + -if L1 drop drop 10 ;
L1: drop dup -37 + -if L2 drop ;
L2: drop drop 10 ;
v4/capsule/dict.v4
-233
View File
@@ -1,233 +0,0 @@
\ dict.v4 -- the dictionary: its space, its entries, and looking a name up.
\
\ DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND ' ,
\ and the entry-field words >LINK LFA LINK> >NAME NFA NAME> CFA PFA >BODY
\ TRAVERSE SMUDGE HIDDEN. Part of the compiler capsule: it runs on the host
\ node. Rests on core.v4 and input.v4.
\
\ AN ENTRY. A word's execution address (xt) is the address of its code, and
\ everything else is found from it:
\
\ name the count byte, then the characters, four bytes to a cell,
\ padded with zeros to a whole cell
\ xt - 3 flags: 1 immediate, 2 hidden, 4 data
\ xt - 2 the word address of the name
\ xt - 1 the link: the xt of the entry before this one, 0 for the first
\ xt the code
\
\ A name holds at most 31 characters; longer ones are cut to 31 both when
\ defined and when looked up, so 31 characters are significant (FORTH-79).
\ A "data" word is one whose code is a single call to its run-time routine,
\ with its parameter field in the cell after it: xt + 1. For any other word
\ the parameter field is the code itself.
\
\ THE SPACE. DP is a byte address, so that C, can pack characters; HERE is
\ the next whole cell. An address unit is a cell (D-1): ALLOT counts cells.
\
\ Constants the loader supplies:
\ DP word address of the variable: the next free byte
\ (LATEST) word address of the variable: the xt of the newest entry of the
\ FORTH vocabulary, or 0
\ CONTEXT CURRENT word addresses of the variables: each holds the address
\ of a vocabulary's head cell -- the cell that holds the xt of
\ that vocabulary's newest entry. FORTH's head cell is (LATEST).
\
\ VOCABULARIES (FORTH-79). A name is looked up in the CONTEXT vocabulary and
\ then, if that is not FORTH, in FORTH. A new entry goes into the CURRENT
\ vocabulary: it is linked to that vocabulary's newest entry and becomes it.
\ DBASE DLIMIT byte addresses of the start and end of dictionary space
\ PAD byte address of the scratch area for strings, 84 bytes or more
\ (D) word address of five cells of scratch for this file
\ (WORD-DEFINED) (WORD-FORGOTTEN) word addresses of two variables: see
\ "telling the kernel" below
\ PAD is in line.
macro 4* 2* 2* endmacro
macro 4/ 2/ 2/ endmacro
macro OR over inv and xor endmacro
\ ---- the space (5.12) ------------------------------------------------------
\ These reach DP through B and leave A alone, so that , and C, can keep what
\ they are storing in A while the space is taken: nothing of theirs is then
\ on the data stack under (DP+), which itself needs three cells (D-2).
: (DERR) ( -- 0 ) NODE-ERROR b! 5 !b 0 ; \ dictionary full
\ ( n -- flag ) move DP by n bytes if it stays inside the dictionary space
\ and say -1; otherwise leave it, set NODE-ERROR and say 0. The two
\ subtractions are x + ~y + 1, which unlike the in-line - needs no return
\ entry: these words are called at the bottom of long chains of calls.
: (DP+)
DP b! @b +
dup DBASE inv + 1 + -if LOW drop drop jump (DERR) \ new - DBASE
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
HIGH: drop DP b! !b -1 ;
header HERE
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
header ALIGN
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
header ALLOT
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
header ,
: , ( x -- )
a!
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
dup inv DLIMIT + -3 + -if ROOM \ DLIMIT - (it + 4)
drop drop NODE-ERROR b! 5 !b ;
ROOM: drop dup 4 + !b \ DP is past it
4/ b! a !b ;
header C,
: C, ( c -- )
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
header 2,
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
header LATEST
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
header >LINK
: >LINK ( xt -- addr ) -1 + ;
header LFA
: LFA ( xt -- addr ) jump >LINK
header LINK>
: LINK> ( addr -- xt ) a! @ ;
header >NAME
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
header NFA
: NFA ( xt -- baddr ) jump >NAME
header NAME>
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
header CFA
: CFA ( xt -- xt ) ;
header PFA
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
header >BODY
: >BODY ( xt -- addr ) jump PFA
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
header TRAVERSE
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
header SMUDGE
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
header HIDDEN
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
\ ---- telling the kernel (docs/v4.0.0/ENGINE.md 3b) ------------------------------
\ A word's code is here on the node; its accounts are a record its kernel
\ keeps. So the kernel has to be told of every entry that is made and of
\ every entry that goes. An entry is made in one place, (HEADER); entries go
\ in two, FORGET and COLD (system.v4). Each tells through a variable that
\ holds the xt of a word to run, or 0 for a node whose host keeps no records:
\ (WORD-DEFINED) ( xt -- ) an entry has been made; its code will be at xt
\ (WORD-FORGOTTEN) ( w -- ) every entry at word address w or above is gone
\ On the bare-metal system the kernel puts words of its own there.
\ ( -- ) tell of the entry just made, whose code starts at HERE
: (DEFINED)
(WORD-DEFINED) b! @b if NONE HERE SWAP push ;
NONE: drop ;
\ ( w -- ) tell that the entries from word address w up have gone
: (FORGOTTEN)
(WORD-FORGOTTEN) b! @b if NONE push ;
NONE: drop drop ;
\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count (D)+4 whether a lookup has gone on to FORTH
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
: (NEED) (D)+3 a! @ 4 + -4 and 12 + ;
\ ( baddr -- ) an entry for the counted string at baddr; its code starts at
\ HERE afterwards. An empty name, or no room, makes nothing and sets
\ NODE-ERROR.
: (HEADER)
dup (D)+2 a! ! \ (CLIP), in line
C@ -32 + -if LONG drop jump CLIPPED
LONG: drop 31 (D)+2 a! @ C!
CLIPPED:
(D)+2 a! @ C@ if EMPTY \ len
(D)+3 a! !
ALIGN
(NEED) (DP+) if FULL drop \ there is room;
(NEED) NEGATE (DP+) drop \ DP back where it was
HERE (D) a! ! \ where the name starts
(D)+3 a! @ C,
L: (D)+3 a! @ if DONE -1 + !
(D)+2 a! @ 1 + dup ! C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop
0 , (D) a! @ , LATEST ,
HERE CURRENT a! @ a! !
jump (DEFINED)
FULL: drop ; \ (DP+) has set NODE-ERROR
EMPTY: drop NODE-ERROR b! 6 !b ; \ name missing
\ ---- looking a name up -----------------------------------------------------
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string.
\ Written out in one piece -- the string cut to 31, each entry's flags and
\ name fetched, the two names compared byte by byte -- so that the only call
\ it makes is C@: it is called from the interpreter for every word of every
\ line, with the user's return stack beneath it.
: (LOOKUP)
dup (D)+1 a! ! \ cut the string to 31 characters
C@ -32 + -if LONG drop jump CUT
LONG: drop 31 (D)+1 a! @ C!
CUT:
0 (D)+4 a! ! \ not yet on to FORTH
CONTEXT a! @ a! @
L: if END
(D)+2 a! !
(D)+2 a! @ -3 + a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop
(D)+2 a! @ -2 + a! @ 4* (D) a! ! \ its name
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
C: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop jump OLDER
EQ: drop jump C
SAME: drop (D)+2 a! @ ;
OLDER: (D)+2 a! @ -1 + a! @ jump L
END: (D)+4 a! @ if FIRST drop ; \ FORTH has been searched: not found
FIRST: drop -1 (D)+4 a! !
CONTEXT a! @ (LATEST) xor if ISFORTH \ CONTEXT is FORTH: that was it
drop drop (LATEST) a! @ jump L
ISFORTH: drop ;
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
header FIND
: FIND 32 WORD jump (LOOKUP)
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
\ input stream. Not found is an error: 0, and NODE-ERROR is set. This is '
\ when interpreting; compile.v4 adds what ' does when compiling.
\ ( -- 0 ) say that the word WORD has just left is not known, as v3 does:
\ UNKNOWN WORD: 'xxx'
: (UNKNOWN)
$4E4B4E55 (EMIT4) $204E574F (EMIT4) $44524F57 (EMIT4) $27203A (EMIT4)
WBUF COUNT TYPE 39 EMIT CR
NODE-ERROR b! -1 !b 0 ;
: (') 32 WORD (LOOKUP) if MISSING jump PFA
MISSING: drop jump (UNKNOWN)
v4/capsule/forth.v4
-229
View File
@@ -1,229 +0,0 @@
\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are
\ opcodes or short runs of them, and the variables that are in-line addresses.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18).
\ A word flagged inline is copied into a definition in place of a call; the
\ ones that touch the return stack are compile-only as well. Rests on core.v4,
\ compile.v4's loader constants, and quit.v4, which the division words leave
\ through when the divisor is zero. (F) is seven cells of scratch for
\ this file.
\ ---- stack ----
header DUP inline : DUP dup ;
header DROP inline : DROP drop ;
header OVER inline : OVER over ;
header SWAP inline : SWAP' SWAP ;
header ROT inline : ROT' ROT ;
header -ROT inline : -ROT SWAP push SWAP pop ;
header ?DUP : ?DUP if Z dup ; Z: ;
header 2DUP inline : 2DUP over over ;
header 2DROP inline : 2DROP drop drop ;
\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
\ stack that has no addresses: the values above the one wanted are set aside
\ in (S), and put back. (F)+3 how many are still to set aside, (F)+4 where
\ the next goes, (F)+5 the value wanted, (F)+6 how many are set aside. With n on top of a stack that is
\ otherwise one short of full there is no room at all, so until a value has been set aside nothing here pushes
\ anything while n is still there, and never more than one cell after.
\ FORTH-79: how many values were on the stack before DEPTH
header DEPTH
: DEPTH DSTACK-DEPTH b! @b ;
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
: (INDEX)
R-CLEAR (EMIT4) $6E49203A (EMIT4) $696C6176 (EMIT4) $6E692064 (EMIT4) $786564 (EMIT4) CR
2 jump (DONE)
\ ( x1 .. xn-1 -- ) A: n, which is 2 or more. Set the n-1 values above
\ the n-th aside. If there are not that many, the pop that finds the stack
\ empty is a fault: "Stack underflow". The count is taken down only after a
\ value has been set aside, when there is room to do the arithmetic.
: (DIG)
(F)+3 b! a !b
(F)+4 b! (S) !b
(F)+6 b! 0 !b
L: (F)+4 b! @b a! !+
a (F)+4 b! !b
(F)+6 b! @b 1 + !b
(F)+3 b! @b -1 + dup !b
-1 + if DONE drop jump L
DONE: drop ;
\ ( -- x1 .. xk ) put them back. The test that ends it pushes one cell:
\ after the last value is back the stack may be one short of full.
: (BURY)
L: (F)+6 b! @b if DONE -1 + !b
(F)+4 a! @ -1 + dup ! a! @
jump L
DONE: drop ;
\ ( n -- x ) FORTH-79: a copy of the n-th value, not counting n itself.
\ 1 PICK is DUP, 2 PICK is OVER. n less than one is an error.
header PICK
: PICK
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop \ n is 1 when half of it is 0
(DIG) dup (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop dup ;
BAD: drop $4B434950 jump (INDEX)
\ ( n -- ) FORTH-79: the n-th value, not counting n itself, is taken out
\ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n
\ less than one is an error.
header ROLL
: ROLL
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop
(DIG) (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop ;
BAD: drop $4C4C4F52 jump (INDEX)
\ ---- return stack: in line, and only inside a definition ----
header >R inline compile-only : >R push ;
header R> inline compile-only : R> pop ;
header R@ inline compile-only : R@ pop dup push ;
header I inline compile-only : I pop dup push ;
header J inline compile-only : J pop pop pop dup push a! push push a ;
header LEAVE inline compile-only : LEAVE pop pop drop dup push push ;
header UNLOOP inline compile-only : UNLOOP pop drop pop drop ;
\ ---- memory ----
header @ inline : FETCH a! @ ;
header ! inline : STORE a! ! ;
header +! inline : +! a! @ + ! ;
header CELLS inline : CELLS ; \ an address unit is a cell (D-1)
\ ---- arithmetic ----
header + inline : PLUS + ;
header - inline : MINUS - ;
\ The low cell of the product, by N steps of +* with nothing but the count on
\ the return stack. UM* drop gives the same cell but needs two more return
\ entries, which a word inside two DO loops does not have (D-2). The low
\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach
\ the bit that moves into A, and the loop ends first.
header * : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
header NEGATE inline : NEGATE' NEGATE ;
header 1+ inline : 1+ 1 + ;
header 1- inline : 1- -1 + ;
header 2+ inline : 2+ 2 + ;
header 2- inline : 2- -2 + ;
header 2* inline : TWO* 2* ;
header 2/ inline : TWO/ 2/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
\ does anything else, and a zero divisor prints v3's message --
\ /: Division by zero
\ -- and ends the line with ERROR, from however deep, as an address fault
\ does. The word's operands are taken off the stack, as v3 takes them, and
\ its caller is not returned to.
\ ( name2 name1 -- ) the word's name: its first four characters, and the
\ rest or 0 (EMIT4). The return stack is emptied before anything is called:
\ the word may have been run with it full.
: (DIV0)
R-CLEAR (EMIT4) (EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b"
$657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero"
2 jump (DONE)
\ ( d n -- rem quot ) truncating toward zero: the quotient has the sign of
\ d xor n, the remainder the sign of d. This is section 4's SM/REM with its
\ UM/MOD -- restoring division, one step a bit, the divisor in A -- written
\ into it, and the two signs kept in (F) where section 4 has them on the
\ return stack. A word that divides is then four return entries deep, not
\ eight, so division can be used inside words that other words call (D-2).
\ The answer is the same. Exact when the quotient fits a cell; its callers
\ have seen to it that n is not zero.
: SM/REM
over over xor (F) a! ! \ the quotient's sign, in its top bit
over (F)+1 a! ! \ the remainder's
-if L0 inv 1 + L0: a! \ A: |n|
-if L1 DNEGATE L1: \ |d|
N-1 FOR
-if S0
2* over -if S1 drop 1 + jump S2
S1: drop S2: push 2* pop
jump SUB
S0:
2* over -if S3 drop 1 + jump S4
S3: drop S4: push 2* pop
dup a xor -if S5
drop -if NOSUB jump SUB
S5: drop dup inv a + inv -if S6
drop jump NOSUB
S6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop \ urem uquot
(F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
header S>D
: S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
header M*
: M* ( n1 n2 -- d )
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop jump DNEGATE P: drop ;
\ ( n1 n2 n3 -- rem quot ) n1 * n2 as a double, divided by n3, which is
\ not zero. M* is written in, and n3 waits in (F)+2, so that the multiply
\ is as few return entries down as it can be.
: (*/MOD)
(F)+2 a! !
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop DNEGATE jump Q P: drop Q:
(F)+2 a! @ jump SM/REM
header /MOD
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: drop drop 0 $444F4D2F jump (DIV0)
header /
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: drop drop 0 $2F jump (DIV0)
header MOD
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: drop drop 0 $444F4D jump (DIV0)
header */MOD
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
header */
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: drop drop drop 0 $2F2A jump (DIV0)
header M/MOD
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
\ ---- logic and comparison ----
header AND inline : AND and ;
header XOR inline : XOR xor ;
header OR inline : OR' OR ;
header 0= : 0= if L1 drop 0 ; L1: drop -1 ;
header 0< : 0< -if L1 drop -1 ; L1: drop 0 ;
header NOT : NOT jump 0=
header = : EQUALS xor jump 0=
header < : LESS
over over xor -if SAME drop drop jump 0<
SAME: drop - jump 0<
header > : GREATER SWAP jump LESS
\ ---- in-line addresses and constants ----
header BL inline : BL' BL ;
header TIB inline : TIB' TIB ;
header >IN inline : >IN' >IN ;
header SPAN inline : SPAN' SPAN ;
header BASE inline : BASE' BASE ;
header PAD inline : PAD' PAD ;
header STATE inline : STATE' STATE ;
v4/capsule/input.v4
-217
View File
@@ -1,217 +0,0 @@
\ input.v4 -- reading a line and splitting it into words and numbers.
\
\ DECOMPOSITION.md 5.9: TIB >IN SPAN SOURCE BL EXPECT QUERY WORD ENCLOSE
\ CONVERT NUMBER, and the comment words ( and \ of 5.15 (named PAREN and
\ BACKSLASH here, since the text assembler reads those two characters as its
\ own comments; the dictionary will give them their names). Part of the compiler
\ capsule: it runs on the host node. Rests on core.v4.
\
\ Constants the loader supplies:
\ TIB byte address of the text input buffer; QUERY fills at most 81 bytes
\ >IN word address of the variable: offset in TIB of the next character
\ SPAN word address of the variable: how many characters the last
\ EXPECT or QUERY read
\ WBUF byte address of WORD's buffer, 257 bytes
\ (P) word address of eight cells of scratch for this file
\ (SRC) word address of the variable: the byte address of the text being
\ interpreted. QUERY makes it TIB; LOAD (blocks.v4) makes it a
\ block buffer. >IN is an offset from it and SPAN its length.
\ (SRC-HOOK) word address of a variable: 0, or the address of a word
\ that WORD calls before it looks at the text, to make sure (SRC)
\ is right. LOAD puts one there: a block buffer can be given to
\ another block between one word of the text and the next.
\ BLK word address of the variable: the block being interpreted, or
\ 0 for the terminal (FORTH-79)
\ TIB >IN SPAN and BL are in-line: written in a definition they are literals.
macro BL 32 endmacro
\ ( -- baddr u ) the input buffer and how much of it is in use
header SOURCE
: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ;
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
\ baddr upward until a new-line or until n have been received; the new-line
\ is taken but not stored. A zero is added after the text, so the buffer
\ must hold n + 1 bytes. No action for n <= 0. SPAN is how many characters
\ were stored (SPAN is not FORTH-79; v3 has it). A line longer than n leaves
\ the rest, its new-line included, to be read next.
\ It is what the prompt reads every line with, with whatever the user has left
\ on the stack beneath it, so it works in (P) -- (P)+0 where the next
\ character goes, (P)+1 how many more may come, (P)+2 where the first went --
\ and has at most three cells of its own on the data stack (D-2).
header EXPECT
: EXPECT
-if NN drop drop ; \ n < 0
NN: if ZERO
(P)+1 a! ! dup (P)+2 a! ! (P) a! !
L: (P)+1 a! @ if END drop
KEY dup -10 + if NL drop \ c
(P) a! @ C!
(P) a! @ 1 + ! (P)+1 a! @ -1 + !
jump L
NL: drop drop jump FIN
END: drop
FIN: 0 (P) a! @ C!
(P) a! @ (P)+2 a! @ - SPAN a! ! ;
ZERO: drop drop ;
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
header QUERY
: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
\ ---- WORD ------------------------------------------------------------------
\ WORD is called from deep inside the interpreter and compiler, with whatever
\ the user has on the stacks beneath it, and the stacks are ten and nine deep
\ (D-2). So everything it works on is in (P), and it never has more than
\ three cells of its own on the data stack:
\ (P)+0 the delimiter (P)+1 the length of the text in TIB
\ (P)+2 the word's length (P)+3 how much of it is still to be copied
\ (P)+6 where it is in TIB (P)+7 where the word starts
\ (CONVERT and NUMBER use (P)+2 .. (P)+5; they and WORD never run inside
\ each other.)
\ ( -- c ) the character WORD is at. A zero reads as a blank when words
\ are being split at blanks: a block that has never been written is all
\ zeros, and so is the end of one whose lines were put there one at a time.
: (SRC@)
(P)+6 a! @ (SRC) a! @ + C@ if Z ;
Z: drop (P) a! @ -32 + if B drop 0 ;
B: drop 32 ;
\ In line, not called: WORD may have only a few return entries to spare.
macro (LEFT) (P)+6 a! @ (P)+1 a! @ - endmacro \ ( -- d ) d < 0 while inside the text
macro (CH) (SRC@) (P) a! @ xor endmacro \ ( -- x ) x = 0 at a delimiter
macro (STEP) (P)+6 a! @ 1 + ! endmacro
\ ( c -- baddr ) FORTH-79: characters are taken from TIB until the
\ delimiter c or the end of the text, leading delimiters ignored, and stored
\ in WBUF as a counted string. The delimiter met -- c, or a zero if the text
\ ran out -- is stored after them and is not counted. >IN is left just past
\ that delimiter. With nothing left the count is 0. The count is a byte,
\ so a word longer than 255 characters is cut to 255.
\ The three parts of WORD. The first is called and returns before anything
\ else is; the last is jumped to; so WORD's calls of C@ and C! are no deeper
\ than if it were written in one piece.
: (WORD-SET) ( c -- )
255 and (P) a! !
(SRC-HOOK) a! @ if NONE push ex \ call it: ex comes back to the next word
jump HOOKED
NONE: drop
HOOKED:
SPAN a! @ -if A drop 0 A: (P)+1 a! !
>IN a! @ -if B drop 0 B: (P)+6 a! ! ;
: (WORD-TAKE) ( -- baddr )
(P)+6 a! @ (P)+7 a! ! \ where it starts
SC: (LEFT) -if SCE drop (CH) if SCE drop (STEP) jump SC \ up to a delimiter
SCE: drop
(P)+6 a! @ (P)+7 a! @ - \ its length
dup -256 + -if CAP drop jump FITS CAP: drop drop 255 FITS:
dup (P)+2 a! ! (P)+3 a! !
(P)+2 a! @ WBUF C!
\ copy it, last character first
CP: (P)+3 a! @ if COPIED -1 + dup ! \ k
dup (P)+7 a! @ + (SRC) a! @ + C@ \ k c
SWAP WBUF+1 + C!
jump CP
COPIED: drop
(LEFT) -if RANOUT
drop (P) a! @ (P)+2 a! @ WBUF+1 + C! \ the delimiter after the text
(P)+6 a! @ 1 + >IN a! ! WBUF ;
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
(P)+6 a! @ >IN a! ! WBUF ;
header WORD
: WORD
(WORD-SET)
SK: (LEFT) -if SKE drop (CH) if SKS drop jump (WORD-TAKE) \ past delimiters
SKS: drop (STEP) jump SK
SKE: drop jump (WORD-TAKE)
\ ( c -- baddr ) as WORD, but leading delimiters are not ignored: the text
\ starts at >IN, and may be empty. This is what ." needs: ." " is an
\ empty string, where WORD would step over its closing quote.
: (PARSE) (WORD-SET) jump (WORD-TAKE)
\ ---- ENCLOSE ---------------------------------------------------------------
\ (P)+0 the delimiter, (P)+1 the string's address.
: (E?) ( i -- i k ) \ k: 0 at the end of the string, 1 at a delimiter, else 2
dup (P)+1 a! @ + C@ if END (P) a! @ xor if DEL drop 2 ;
DEL: drop 1 ;
END: drop 0 ;
: (ESKIP) ( i -- i' ) L: (E?) -1 + if S drop ; S: drop 1 + jump L
: (ESCAN) ( i -- i' ) L: (E?) -2 + if S drop ; S: drop 1 + jump L
\ ( baddr c -- baddr n1 n2 n3 ) in the zero-terminated string at baddr:
\ n1 the offset of the first character that is not c, n2 the offset of the
\ first c after it, n3 the offset of the first character after that run of c.
header ENCLOSE
: ENCLOSE
255 and (P) a! ! dup (P)+1 a! !
0 (ESKIP) dup (ESCAN) dup (ESKIP) ;
\ ---- CONVERT and NUMBER ----------------------------------------------------
\ ( c -- n ) the value of the digit c, 0 .. 35, in either case; -1 if none
: (DIGIT)
dup -48 + -if GE0 drop drop -1 ;
GE0: drop dup -58 + -if GT9 drop -48 + ;
GT9: drop dup -65 + -if GEA drop drop -1 ;
GEA: drop dup -91 + -if GTZ drop -55 + ;
GTZ: drop dup -97 + -if GEa drop drop -1 ;
GEa: drop dup -123 + -if GTz drop -87 + ;
GTz: drop drop -1 ;
\ ( d1 baddr1 -- d2 baddr2 ) FORTH-79: the characters from baddr1 + 1 on are
\ taken as digits in the current BASE, each accumulated into the double after
\ it is multiplied by BASE, until one is not a digit; baddr2 is its address.
\ (P)+2 holds the digit while the double is multiplied and (P)+5 the address,
\ so nothing waits on the return stack across the calls.
header CONVERT
: CONVERT
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
-if DIG drop (P)+5 a! @ ;
DIG: dup (BASE) - -if BIG
drop (P)+2 a! ! \ lo hi
(BASE) UM* drop \ lo hi*base
SWAP (BASE) UM* \ hi*base plo phi
push SWAP pop + \ plo hi'
(P)+2 a! @ 0 D+
(P)+5 a! @ jump L
BIG: drop drop (P)+5 a! @ ;
\ ( baddr -- d flag ) the counted string at baddr as a signed double in the
\ current BASE, and -1; it may begin with a minus sign. If it is empty, is
\ only a sign, or holds anything that is not a digit: 0 0 and 0. The character after the string must not be a digit
\ (WORD puts the delimiter or a zero there); if it is, that too is reported
\ as an error. (P)+3 the address of its last character, (P)+4 the sign.
: (NUMBER?)
dup C@ if ERR2
over + (P)+3 a! ! \ baddr
dup 1 + C@ -45 + if NEG
drop 0 (P)+4 a! ! jump GO
NEG: drop -1 (P)+4 a! ! 1 +
dup (P)+3 a! @ xor if ERR2 drop
GO: push 0 0 pop CONVERT \ lo hi baddr2
(P)+3 a! @ 1 + xor if FINE
drop drop drop jump ERR0
FINE: drop (P)+4 a! @ if POS drop DNEGATE -1 ;
POS: drop -1 ;
ERR2: drop drop
ERR0: 0 0 0 ;
\ ( baddr -- d ) FORTH-79. What is not a number gives 0 and sets NODE-ERROR.
header NUMBER
: NUMBER
(NUMBER?) if BAD drop ;
BAD: drop NODE-ERROR b! 2 !b ;
\ ---- comments (5.15) -------------------------------------------------------
\ PAREN skips to the closing parenthesis; BACKSLASH skips the rest of the line.
header ( immediate
: PAREN 41 WORD drop ;
header \ immediate
\ In a block a line is 64 characters: skip to the start of the next.
: BACKSLASH
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
TERM: drop SPAN a! @ >IN a! ! ;
v4/capsule/log.v4
-72
View File
@@ -1,72 +0,0 @@
\ log.v4 -- logging, as v3: a message has a level, and is printed if the
\ level is at or below LOG-LEVEL.
\
\ DECOMPOSITION.md 5.25: the level constants LOG-ERROR LOG-WARN LOG-INFO
\ LOG-TEST LOG-DEBUG (0 .. 4), LOG-LEVEL! LOG-LEVEL@, LOG-ERROR" ... LOG-DEBUG"
\ and LOG-ERROR-STR ... LOG-DEBUG-STR. Part of the compiler capsule; rests
\ on core.v4, codegen.v4 and quit.v4.
\
\ WHAT IS PRINTED is v3's line without its time of day, which a node has
\ not got: the level's colour, the level's name and a colon, the colour off,
\ the text, a new line --
\ ESC [32m INFO: ESC [0m text
\ On the mesh a message will go to the recorder's log ring (5.25); until
\ then it goes to the console.
\
\ Constants the loader supplies:
\ (LOG-LEVEL) word address of the variable: 2, LOG-INFO, at switch-on
header LOG-ERROR inline : LOG-ERROR 0 ;
header LOG-WARN inline : LOG-WARN 1 ;
header LOG-INFO inline : LOG-INFO 2 ;
header LOG-TEST inline : LOG-TEST 3 ;
header LOG-DEBUG inline : LOG-DEBUG 4 ;
header LOG-LEVEL@
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
header LOG-LEVEL!
: LOG-LEVEL!
-if POS drop 0 jump SET
POS: dup -5 + -if BIG drop jump SET
BIG: drop drop 4
SET: (LOG-LEVEL) a! ! ;
\ ( baddr u level -- ) the message, if the level is at or below LOG-LEVEL
: (LOG)
dup inv (LOG-LEVEL) a! @ + 1 + -if SHOW drop drop drop drop ; \ LOG-LEVEL - level
SHOW: drop
if P0 -1 + if P1 -1 + if P2 -1 + if P3 -1 + if P4
drop jump OUT
P0: drop $31335B1B (EMIT4) $6D (EMIT4) $4F525245 (EMIT4) $203A52 (EMIT4) $6D305B1B (EMIT4) jump OUT
P1: drop $33335B1B (EMIT4) $6D (EMIT4) $4E524157 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P2: drop $32335B1B (EMIT4) $6D (EMIT4) $4F464E49 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P3: drop $35335B1B (EMIT4) $6D (EMIT4) $54534554 (EMIT4) $203A (EMIT4) $6D305B1B (EMIT4) jump OUT
P4: drop $34335B1B (EMIT4) $6D (EMIT4) $55424544 (EMIT4) $203A47 (EMIT4) $6D305B1B (EMIT4) jump OUT
OUT: TYPE jump CR
header LOG-ERROR-STR : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
header LOG-WARN-STR : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
header LOG-INFO-STR : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
header LOG-TEST-STR : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
header LOG-DEBUG-STR : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
\ ( level -- ) the run time of LOG-xxx" : the text is after the call, as
\ for ." ; log it at that level and go on after it.
header (LOG") compile-only
: (LOG")
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
COUNT ROT jump (LOG)
\ ( level -- ) LOG-xxx" text" logs the text -- now, if interpreting; when
\ the word it is compiled into runs, if compiling. (Q)+3 holds the level.
: (LOG-QUOTE)
(Q)+3 a! ! 34 (PARSE) drop
STATE a! @ if NOW
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT (Q)+3 a! @ jump (LOG)
header LOG-ERROR" immediate : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
header LOG-WARN" immediate : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
header LOG-INFO" immediate : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
header LOG-TEST" immediate : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
header LOG-DEBUG" immediate : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
v4/capsule/numout.v4
-153
View File
@@ -1,153 +0,0 @@
\ numout.v4 -- printing numbers: pictured output, the . words, and .S
\
\ DECOMPOSITION.md 5.8: <# # #S HOLD SIGN #> . .R U. U.R D. D.R ? SPACES
\ DECIMAL HEX OCTAL, each the definition given there and executed on the mesh
\ node by test_pictured.c, test_numout.c and test_printing.c; and .S, which
\ D-16 makes possible again. Part of the compiler capsule. Rests on core.v4
\ and forth.v4.
\
\ Constants the loader supplies:
\ HEND byte address just past the hold buffer, which is 64 bytes
\ -HFLOOR minus the lowest address HOLD may store at: -(HEND - 62)
\ HLD word address of the variable: where the picture has got to
\ (W) word address of three cells of scratch for this file:
\ (W)+0 the width a number is to be printed in
\ (W)+1 whether a blank follows it (W)+2 .S's count
macro (-ROT) SWAP push SWAP pop endmacro
\ ---- unsigned division (section 4) ----
\ One step a bit, the divisor in A. Exact for uhi < ud.
: UM/MOD ( ulo uhi ud -- urem uquot )
a! N-1 FOR
-if L0
2* over -if L1 drop 1 + jump L2
L1: drop L2: push 2* pop
jump SUB
L0:
2* over -if L3 drop 1 + jump L4
L3: drop L4: push 2* pop
dup a xor -if L5
drop -if NOSUB jump SUB
L5: drop dup inv a + inv -if L6
drop jump NOSUB
L6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop ;
\ ---- pictured output ----
header <#
: <# ( -- ) HEND HLD b! !b ;
header HOLD
: HOLD ( c -- )
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
OKC: drop HLD b! @b -HFLOOR + -if ROOM
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
ROOM: drop HLD b! @b -1 + dup !b jump C!
header SIGN
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
header #
: # ( ud1 -- ud2 )
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
(BASE) UM/MOD (-ROT) \ qlo qhi rem
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
header #S
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
header #>
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
header SPACES
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
header DECIMAL
: DECIMAL 10 BASE a! ! ;
header HEX
: HEX 16 BASE a! ! ;
header OCTAL
: OCTAL 8 BASE a! ! ;
\ ---- numbers ----
\ One picture for signed singles, one for unsigned, one for doubles. Each
\ plain word is its .R word with a width of 0 and the blank flag set, and all
\ six share one tail, which prints the blank only when the flag is set.
\ ( baddr u -- ) right-justified in the width, then the blank if wanted
: (.TAIL)
(W) b! @b -if POS drop jump OUT \ width < 0
POS: over - SPACES \ width - u spaces
OUT: TYPE (W)+1 b! @b if DONE drop jump SPACE
DONE: drop ;
: (.BODY) ( n width -- )
(W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> jump (.TAIL)
: (U.BODY) ( u width -- )
(W) b! !b 0 <# #S #> jump (.TAIL)
: (D.BODY) ( d width -- )
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
header .R
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
header .
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
header U.R
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
header U.
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
header D.R
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
header D.
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
header ?
: QUESTION a! @ jump DOT
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line. The stack is
\ left as it was. It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
header .S
: DOT-S
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
DEPTH (W)+2 b! !b
L: (W)+2 b! @b if DONE
PICK DOT
(W)+2 b! @b -1 + !b jump L
DONE: drop jump CR
\ ---- DUMP ----
\ ( baddr u -- ) u bytes from the byte address baddr, sixteen to a line: the
\ address, the bytes in hex, and the bytes as characters between bars.
\ Everything it keeps between words is in (DP): the saved BASE, the address,
\ the count and the column. ADDR-DIGITS is two for each byte of a cell.
: (DB) ( -- c ) (DP)+1 b! @b (DP)+3 b! @b + jump C@
header DUMP
: DUMP
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: (DP)+2 b! !b (DP)+1 b! !b
BASE b! @b (DP) b! !b 16 BASE b! !b
LINE: (DP)+2 b! @b if DONE drop
(DP)+1 b! @b 0 <# ADDR-DIGITS (DP)+3 b! !b
AD: # (DP)+3 b! @b -1 + dup !b if ADX drop jump AD
ADX: drop #> TYPE 58 EMIT SPACE
0 (DP)+3 b! !b
HX: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVE
drop SPACE SPACE SPACE jump HN
HAVE: drop (DB) 0 <# # # #> TYPE SPACE
HN: (DP)+3 b! @b 1 + dup !b -16 + -if HXX drop jump HX
HXX: drop SPACE 124 EMIT
0 (DP)+3 b! !b
CH: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVC jump CHX
HAVC: drop (DB)
dup -32 + -if GE drop drop 46 jump EM
GE: drop dup -127 + -if BIG drop jump EM
BIG: drop drop 46
EM: EMIT
(DP)+3 b! @b 1 + dup !b -16 + -if CHX drop jump CH
CHX: drop 124 EMIT CR
(DP)+1 b! @b 16 + !b
(DP)+2 b! @b -16 + -if MORE jump DONE
MORE: !b jump LINE
DONE: drop (DP) b! @b BASE b! !b ;
v4/capsule/qmath.v4
-247
View File
@@ -1,247 +0,0 @@
\ qmath.v4 -- Q48.16 fixed point: a signed double with sixteen bits of
\ fraction (D-8, D-10).
\
\ DECOMPOSITION.md 5.26. Each word is the definition given there and
\ executed on the mesh node by test_foundation.c and test_printing.c, here in
\ the host node's vocabulary. Rests on core.v4, forth.v4, numout.v4 and
\ words.v4.
\
\ ERRORS. Q./ by zero, and Q.SQRT and Q.LOG outside their domain, leave the
\ result D-11 and D-12 give and then raise an error (D-18): codes 11,
\ "Division by zero", and 12, "Argument out of range".
\
\ Constants the loader supplies:
\ MSB MAXHI the high cells of Q min and Q max
\ HIMASK every bit but the top sixteen
\ 2N+15 N-18 N-17 loop counts, N the cell width in bits
\ (Q/) (QE) (QR) (QL) (QT) (QP) word addresses of the words' scratch
\ cells: 5, 8, 5, 7, 6 and 4 of them
\ the logical double shift right: one +* step with S = 0, the top bit cleared
macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
: (QERR11) NODE-ERROR b! 11 !b ;
: (QERR12) NODE-ERROR b! 12 !b ;
\ ---- conversion and constants ----
header Q.FROM-INT
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
header Q.TO-INT
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
header Q.1 inline : Q.1 65536 0 ;
header Q.0 inline : Q.0 0 0 ;
header Q.SCALE inline : Q.SCALE 65536 0 ;
\ ---- the double words under other names ----
header Q.+ : Q.+ jump D+
header Q.- : Q.- jump D-
header Q.ABS : Q.ABS jump DABS
header Q.NEG : Q.NEG jump DNEGATE
header Q.= : Q.= jump D=
header Q.< : Q.< jump D<
header Q.> : Q.> 2SWAP jump D<
header Q.0= : Q.0= jump D0=
header Q.MAX : Q.MAX jump DMAX
header Q.MIN : Q.MIN jump DMIN
\ ---- multiply ----
header Q.*
: Q.* ( a b -- c )
SWAP push over over UM* drop
push push over pop
-if L1 SWAP jump L2 L1: SWAP drop 0 L2:
pop SWAP - push
push over pop UM* pop +
ROT pop dup push
over -if L3 drop dup jump L4 L3: drop 0 L4:
push UM* pop - D+
ROT pop UM*
SWAP push 0 D+ pop
push over pop SWAP Q.TO-INT push Q.TO-INT pop SWAP ;
\ ---- divide ----
: D2*C ( lo hi cin -- lo' hi' cout )
a! dup -if L1 drop 1 jump L2 L1: drop 0 L2: push
over -if L3 drop 1 jump L4 L3: drop 0 L4:
over + +
push 2* a + pop pop ;
: (UQ/) ( a0 a1 b0 b1 -- q0 q1 )
(Q/)+2 a! SWAP !+ ! (Q/) a! SWAP !+ ! 0 0 0
2N+15 FOR
push (Q/) a! @+ @ pop D2*C
push (Q/)+1 a! ! (Q/) a! ! pop D2*C
if CMP drop jump TAKE
CMP: drop (Q/)+3 b! @b
over over xor if EQH -if SAMEH
drop drop -if NT1 jump TAKE NT1: jump NOTAKE
SAMEH: drop over SWAP push inv pop + inv
-if T2 drop jump NOTAKE T2: drop jump TAKE
EQH: drop drop over (Q/)+2 b! @b
over over xor -if SAMEL
drop drop -if NT3 drop jump TAKEL NT3: drop jump NOTAKEL
SAMEL: drop push inv pop + inv
-if T4 drop jump NOTAKEL T4: drop jump TAKEL
TAKEL: drop (Q/)+2 b! @b push inv pop + inv 0 1 jump END
NOTAKEL: 0 jump END
TAKE: push (Q/)+2 b! @b over over push inv pop + inv push
over over xor -if SB drop NIP -if NB drop 1 jump BD NB: drop 0 jump BD
SB: drop push inv pop + inv -if NB2 drop 1 jump BD NB2: drop 0
BD: pop pop (Q/)+3 b! @b push inv pop + inv
push SWAP pop SWAP - 1 jump END
NOTAKE: 0
END:
NEXT
push (Q/) a! @+ @ pop D2*C drop push push drop drop pop pop ;
header Q./
: Q./ ( a b -- q )
over over OR if ZERO drop
push over pop SWAP over xor (Q/)+4 b! !b
-if L1 DNEGATE L1: push push -if L2 DNEGATE L2: pop pop
dup if CHK drop jump DIV
CHK: drop over -131072 and if CHK2 drop jump DIV
CHK2: drop push push dup pop dup push N-18 FOR 2* UNEXT
over over xor -if SAME drop drop -if NOOV jump OV
SAME: drop push inv pop + inv -if OV
NOOV: drop pop pop jump DIV
OV: drop drop drop pop pop drop drop
(Q/)+4 b! @b -if OVP drop 0 MSB ; OVP: drop -1 MAXHI ;
DIV: (UQ/) (Q/)+4 b! @b -if L3 drop DNEGATE ; L3: drop ;
ZERO: drop drop drop
over over OR if Z0 drop -if ZP drop drop 0 MSB jump (QERR11)
ZP: drop drop -1 MAXHI jump (QERR11)
Z0: drop jump (QERR11)
\ ---- e to the x ----
header Q.EXP
: Q.EXP ( q -- e )
over over OR if ONE drop
dup (QE)+6 b! !b -if L1 DNEGATE L1:
over over -1048576 -1 D+ push drop pop -if BIG drop
over over (QE)+2 a! SWAP !+ ! over over (QE) a! SWAP !+ !
65536 0 D+ (QE)+4 a! SWAP !+ !
2 (QE)+7 b! !b
LOOP:
(QE)+2 a! @+ @ (QE) a! @+ @ Q.*
(QE)+7 b! @b Q.FROM-INT Q./
over over (QE)+2 a! SWAP !+ !
(QE)+4 a! @+ @ D+ (QE)+4 a! SWAP !+ !
(QE)+2 a! @+ @ if HI0 drop drop jump CONT
HI0: drop -if SM drop jump CONT
SM: -50 + -if CONT1 drop jump DONE
CONT1: drop
CONT: (QE)+7 b! @b 1 + dup !b -11 + -if DONE1 drop jump LOOP
DONE1: drop
DONE: (QE)+4 a! @+ @ (QE)+6 b! @b -if POS drop 65536 0 2SWAP jump Q./
POS: drop ;
BIG: drop drop drop (QE)+6 b! @b -if BIGP drop 0 0 ; BIGP: drop -1 MAXHI ;
ONE: drop drop drop 65536 0 ;
\ ---- square root ----
header Q.SQRT
: Q.SQRT ( q -- r )
dup -if POS drop drop drop 0 0 jump (QERR12)
POS: drop over over OR if ZERO drop
over 65536 xor over OR if ONE drop
over over (QR) a! SWAP !+ ! (UD2/) 16384 0 D+ (QR)+2 a! SWAP !+ !
8 (QR)+4 b! !b
LOOP: (QR) a! @+ @ (QR)+2 a! @+ @ Q./ (QR)+2 a! @+ @ D+ (UD2/)
over over (QR)+2 a! @+ @ DNEGATE D+ -if L1 DNEGATE L1:
if HI0 drop drop jump NXT
HI0: drop -if SM drop jump NXT
SM: -10 + -if NXT1 drop drop drop (QR)+2 a! @+ @ ;
NXT1: drop
NXT: (QR)+2 a! SWAP !+ !
(QR)+4 b! @b -1 + dup !b if DONE drop jump LOOP
DONE: drop (QR)+2 a! @+ @ ;
ZERO: drop ;
ONE: drop ;
\ ---- natural logarithm ----
header Q.LOG
: Q.LOG ( x -- ln x )
dup -if POS drop jump ERR
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
DOWN: dup if CHKLO drop jump SHR
CHKLO: drop over -131072 and if DOWNDONE drop
SHR: (UD2/) (QL)+2 b! @b 1 + !b jump DOWN
DOWNDONE: drop drop
UP: dup -65536 and if UPSHIFT drop jump NORM
UPSHIFT: drop 2* (QL)+2 b! @b -1 + !b jump UP
NORM: dup (QL) b! !b -65536 + (QL)+1 b! !b 6 (QL)+3 b! !b
NEWTON: (QL)+1 b! @b dup (QL)+4 b! !b 65536 + (QL)+5 b! !b
131072 (QL)+6 b! !b
EXPL: (QL)+4 b! @b 0 (QL)+1 b! @b 0 Q.* drop
0 (QL)+6 b! @b 0 Q./ drop dup (QL)+4 b! !b
dup (QL)+5 b! @b + !b
-50 + -if EXPC drop jump EXPD
EXPC: drop (QL)+6 b! @b 65536 + dup !b -720896 + -if EXPD2 drop jump EXPL
EXPD2: drop
EXPD: (QL) b! @b (QL)+5 b! @b push inv pop + inv
dup (QL)+4 b! !b
if DZ -if DPOS
inv 1 + 0 (QL)+5 b! @b 0 Q./ drop
(QL)+1 b! @b SWAP push inv pop + inv -if KEEP drop 0 KEEP: (QL)+1 b! !b
jump TEST
DPOS: 0 (QL)+5 b! @b 0 Q./ drop (QL)+1 b! @b + !b jump TEST
DZ: drop
TEST: (QL)+4 b! @b -if AP inv 1 + AP: -100 + -if CONT drop jump FIN
CONT: drop (QL)+3 b! @b -1 + dup !b if FIN0 drop jump NEWTON
FIN0: drop
FIN: (QL)+1 b! @b (QL)+2 b! @b
-if KP inv 1 + 45426 UM* drop inv 1 + jump KS KP: 45426 UM* drop
KS: + dup -if SP drop -1 ; SP: drop 0 ;
ZERO: drop
ERR: drop drop 0 0 jump (QERR12)
\ ---- sine and cosine ----
: (Q.REDUCE) ( x -- r )
dup (QT) b! !b -if L1 DNEGATE L1:
0 411774 UM/MOD drop 411774 UM/MOD drop
(QT) b! @b -if P1 drop inv 1 + jump J1 P1: drop J1:
dup -205888 + -if BIG drop
dup 205887 + -if OK drop 411774 + ;
OK: drop ;
BIG: drop -411774 + ;
\ The Taylor loop both use; each sets (QT) up and jumps here.
: (TRIG)
T: (QT)+2 b! @b 0 (QT)+1 b! @b 0 Q.* drop
0 (QT)+4 b! @b dup -1 + UM* drop 65536 UM* drop 0 Q./ drop
dup (QT)+2 b! !b
(QT)+5 b! @b if ADDT drop inv 1 + jump ACC ADDT: drop
ACC: (QT)+3 b! @b + !b (QT)+5 b! @b inv !b
(QT)+2 b! @b -10 + -if CONT drop jump END
CONT: drop (QT)+4 b! @b 2 + dup !b -12 + -if END2 drop jump T
END2: drop
END: (QT)+3 b! @b (QT) b! @b -if PR drop inv 1 + jump SD PR: drop
SD: dup -if SP drop -1 ; SP: drop 0 ;
header Q.SIN
: Q.SIN ( x -- sin x )
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
dup (QT)+2 b! !b dup (QT)+3 b! !b
0 over 0 Q.* drop (QT)+1 b! !b
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
header Q.COS
: Q.COS ( x -- cos x )
(Q.REDUCE) -if A1 inv 1 + A1:
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
65536 (QT)+2 b! !b 65536 (QT)+3 b! !b
2 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
\ ---- printing ----
\ The integer part, a point, five digits, a blank; always in decimal.
header Q.PRINT
: Q.PRINT ( q -- )
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
BASE b! @b (QP) b! !b 10 BASE b! !b
65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT
0 <# # # # # # drop drop 46 HOLD
(QP)+1 b! @b (QP)+2 b! @b dup push
push a! 0 pop 15 FOR +* UNEXT drop drop a
pop 15 FOR 2/ UNEXT HIMASK and
#S (QP)+3 b! @b SIGN #>
(QP) b! @b BASE b! !b
TYPE jump SPACE
v4/capsule/quit.v4
-585
View File
@@ -1,585 +0,0 @@
\ quit.v4 -- a line of text, interpreted; how it ends; and the words that
\ print text written in the source.
\
\ DECOMPOSITION.md 5.15 and 5.10: QUIT ABORT ABORT" (ABORT") ." (."). Part of
\ the compiler capsule. Rests on all the files before it.
\
\ A NODE IS SENT TEXT (docs/v4.0.0/MESH.md section 6). It does not read its
\ own command line and prints no prompt. A node with nothing to do sleeps;
\ a message comes to one of its wires; if that is text for this node it is
\ taken and interpreted; what it printed goes back as a message, and then
\ a message saying how the text ended:
\ 1 it completed a console says " ok"
\ 2 it ended in an error the message is already printed; " ERROR"
\ 0 QUIT nothing is said
\ What a console then shows is v3's:
\ ok> 65 EMIT the console's prompt, and the line
\ A ok what the line printed, then " ok"
\ ok> NOSUCH
\ UNKNOWN WORD: 'NOSUCH'
\ ERROR
\ ok> -1 @
\ Address out of range an address fault (D-14), from any depth
\ ERROR
\ KEY, EXPECT and QUERY are FORTH-79 words that read characters, as before;
\ they are not how text reaches the node. They still read the console's
\ registers, CONSOLE-RX and CONSOLE-STATUS, and not a message.
\
\ THE STACKS are guarded (D-16): each counts what it holds, and a push onto
\ a full one or a pop from an empty one is a fault. So QUIT and ABORT, which
\ never return to whatever ran them, must empty the return stack, and ABORT
\ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that.
\
\ Constants the loader supplies:
\ (LINE-STATUS) word address of the variable: how the last text ended
\ (MSG) (REPLY) (ME) (OUT) (OUT^) see core.v4, "what a node prints"
\ (PORT) word address of the node's port 0
\ (Q) word address of four cells of scratch, which system.v4 and
\ blocks.v4 use too
\ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers
\ ( -- ) empty the return stack. `a` is only something to store: any
\ store to the register empties the stack, and `a` needs nothing to be on
\ the data stack. One cell of the data stack is used for a moment.
macro R-CLEAR RSTACK-DEPTH b! a !b endmacro
\ ( -- ) stop compiling; forget the word being built and any open control
\ structures. A definition that was under way stays hidden.
: (RESET) 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! ;
\ ( s -- ) the text is done with. What it printed is sent, then a message
\ saying how it ended -- 0 QUIT, 1 completed, 2 an error -- and the node waits
\ for the next. (DONE) is entered with the same number and, for an error,
\ stops compiling first; it is always jumped to, never called, by
\ something that has emptied the return stack (or by a fault, which empties
\ it). (LINE-STATUS) keeps how the last text ended, and is the one word of
\ the message's text.
\ THE ANSWER IS NOT REFUSED HERE: the text was not begun until the wire it
\ goes by had room for it, and that room has been kept, (KEEP), which is
\ let go only now (MESH.md 7d.4). If no one is on that port any more it
\ is counted in (LOST).
\ FOUR CELLS OF THE DATA STACK are tried first: what a node does between
\ texts -- this, passing messages on, taking the next text in -- and the
\ interpreter need that many, so text may leave 28 values on a stack of 32
\ and no more. Text that leaves more ends here, "Stack overflow", with
\ the stack emptied, and not later, in the middle of the text after it.
: (FINISH) ( s -- )
1 (QUIET) a! ! \ from here nothing is this text's doing
(LINE-STATUS) b! !b
0 0 0 0 drop drop drop drop
(FLUSH-OUT)
-1 (KEEP) a! !
(MSG)+1 a! @ 3 (HDR) 4 (OUT-HDR)+6 a! ! \ to whoever sent the text: type 3, four characters
(LINE-STATUS) (DONE-PORT) a! @ (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! jump (IDLE)
SENT: drop jump (IDLE)
: (DONE)
if GO -1 + if OK
drop (RESET) 2 jump (FINISH)
OK: drop 1 jump (FINISH)
GO: drop 0 jump (FINISH)
\ ( -- flag ) A GONE has been taken: its seven words are in (IN), the
\ node it is about in (ONE), and (S-WIRE) is the wire it came by. It is
\ believed only if it came by the port that leads to this node's centre
\ and says it is from the centre (MESH.md 7b.4): the way to the node is
\ then forgotten, and the flag is -1. Otherwise nothing is done, and 0.
\ (As first built only what it said it was from was looked at, and one
\ that came by another port was believed.)
: (GONE?)
(CENTRE) if NOT (IN)+1 a! @ xor if FROM drop 0 ;
NOT: ;
FROM: drop (ROUTE-DEFAULT) a! @ (PORT) - (S-WIRE) a! @ xor if YES drop 0 ;
YES: drop (ONE) a! @ NO-ROUTE -1 ;
\ ( -- ) WAITING (MESH.md 7d.4). A node with nothing to do passes on
\ what has come for other nodes, (SERVE), and then goes through what has
\ come for itself, the lowest port first and each wire from its front:
\ text is taken, into TIB, and done: (LINE), and then (FINISH) says
\ how it ended. But not unless the wire its answer goes by --
\ the way to whoever sent it; with none known, or no one on
\ that port, the wire it came on -- has room for the answer,
\ 8 cells. If it has not, the text stays on its wire and the
\ node looks further: there may be several such, on wires
\ whose answers go different ways, and each is begun when
\ its own has the room. That room is kept from then until
\ the answer has gone.
\ TEXTS WHOSE ANSWERS GO THE SAME WAY ARE BEGUN IN THE ORDER
\ THEY CAME. Once one has been left for want of room, every
\ text behind it on this pass whose answer goes by that port
\ is left too, though the room has come since: (D-MASK) has
\ a bit for each such port. (As first built only the room
\ was asked, each time; room that came between the look at
\ one text and at the next began the second first. Found
\ by the final review of step 6e.)
\ a NACK is taken and counted in (REFUSED)
\ a GONE is taken, and believed if this node's centre sent it
\ an answer no one is waiting for is dropped: a SEND that is not waited
\ on is ordinary use, and its answer is not a loss.
\ any other is dropped, and counted in (LOST): what a node printed
\ that came here, a type there is none of, or a NACK or GONE
\ that is not as long as one is. (LOST) counts what should
\ have been delivered or acted on and was not.
\ A TAKE THAT DOES NOT TAKE -- the wire was cut after the message was
\ looked at -- leaves nothing to act on: no text is done and nothing is
\ believed for it, (UNTAKEN). The same for a drop that does not drop.
\ With nothing to begin it sleeps, executing nothing, until a message
\ comes; or, if text is waiting for room for its answer, or (SERVE) left a
\ message for want of room, until there is room on any wire that leads
\ from it or a message comes. Then it does all of this again.
\ It has fetched which wires have a message before it looks at any, and
\ sleeps after: a message that comes while it looks wakes it at once, and
\ one it left on a wire does not keep it awake (MESH.md 7d.3).
\ (KEEP) and (AWAIT-FROM) are put back here every time: whatever was
\ abandoned on the way, a node with nothing to do keeps no room and waits
\ for no one.
: (IDLE)
L: 1 (QUIET) a! ! \ nothing here is any text's doing: see (RAISED)
-1 (KEEP) a! ! 0 (AWAIT-FROM) a! ! -1 (DEFER) a! ! 0 (D-MASK) a! !
(SERVE) (MINE0)
M: (MINE) if REST
drop (IN)+2 a! @ -1 + if TEXT -3 + if NACK -1 + if GONE
OTHER: drop 4 (DO) if LETGO drop (SKIP) jump M \ it was not there to drop: nothing is counted
LETGO: drop (IN)+2 a! @ -3 + if ANSWER \ let go. An answer no one waits for is ordinary:
drop (LOST) a! @ 1 + ! jump M \ anything else should not have come here, and is counted
ANSWER: drop jump M
NACK: drop (IN)+6 a! @ -4 + if N1 jump OTHER
N1: drop (TAKE1) if N2 drop (UNTAKEN) jump M \ not taken: nothing is done for it
N2: drop (REFUSED) a! @ 1 + ! jump M \ a message of this node's was refused: counted
GONE: drop (IN)+6 a! @ -4 + if G1 jump OTHER
G1: drop (TAKE1) if G2 drop (UNTAKEN) jump M
G2: drop (GONE?) drop jump M
TEXT: drop
(IN)+1 a! @ (WAY) -if T1 drop (S-WIRE) a! @ \ the way back; with none known, the wire it came on
T1: (DONE-PORT) a! !
(DONE-PORT) a! @ (WBIT) (D-MASK) a! @ and if FREE1 jump FULL \ text ahead of it waits for room on that wire
FREE1: drop
8 (DONE-PORT) a! @ (ROOM?) if START -1 + if FULL
drop (S-WIRE) a! @ (DONE-PORT) a! ! \ no one is on that port: back by the wire it came on,
(S-WIRE) a! @ (WBIT) (D-MASK) a! @ and if FREE2 jump FULL
FREE2: drop
8 (S-WIRE) a! @ (ROOM?) -1 + if FULL jump START \ if that has the room -- or has no one on it either
FULL: drop (DONE-PORT) a! @ (WBIT) dup inv (D-MASK) a! @ and + !
(DEFER) a! @ -if LATER drop (DONE-PORT) a! @ (DEFER) a! ! (SKIP) jump M
LATER: drop (SKIP) jump M
REST: drop
(DEFER) a! @ -if ROOM drop (SLEEP) jump L
ROOM: (WIRE!) 8 (WIRE-A) b! !b 9 (DO) drop jump L
START: drop
(S-WIRE) a! @ dup (REPLY) a! ! (WIRE!)
(MSG) (WIRE-A) b! !b TIB 2/ 2/ (WIRE-B) b! !b 2 (DO) \ its seven words, and its text
if TAKEN drop (UNTAKEN) jump M \ not taken: the wire was cut since it was looked at
TAKEN: drop
0 (MSG)+6 a! @ TIB + C! \ a zero after the text
(MSG)+6 a! @ SPAN a! !
(DONE-PORT) a! @ (KEEP) a! ! \ the room for its answer is kept from here
(CONSOLE) a! @ if P0 jump P1 \ where what it prints goes: the console,
P0: drop (MSG)+1 a! @ \ or whoever sent it;
P1: dup (PRINT-TO) a! !
(WAY) -if Q1 drop (REPLY) a! @ \ by the way there, or the wire the text came on
Q1: (PRINT-PORT) a! !
jump (LINE)
\ ( -- ) THE TEXT, INTERPRETED. It is in TIB with a zero after it and its
\ length in SPAN, and the return stack is empty. It is interpreted with one
\ return entry under it, this word's call of INTERPRET; whatever is on the
\ data stack stays there.
: (LINE)
0 (QUIET) a! ! \ an error from here on is this text's
0 BLK a! ! \ the terminal, whatever was being loaded
TIB (SRC) a! ! 0 >IN a! !
0 NODE-ERROR b! !b
INTERPRET
NODE-ERROR b! @b if GOOD
drop 2 jump (DONE)
GOOD: drop 1 jump (DONE)
\ ---- the node among others (MESH.md sections 6 and 7) ---------------------------
\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel.
\ ( node port -- ) the port, by its number, leads toward that node
header ROUTE
: ROUTE
(ROUTE#) a! @ -16 + if FULL drop
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
push !+ pop !+
(ROUTE#) a! @ 1 + ! ;
FULL: drop drop drop NODE-ERROR b! 12 !b ;
\ ( node port -- ) the node on the other end of the port, by its number;
\ 0: none, or a device. Whoever wires the node tells it, and tells it again
\ when the wiring changes. It is how a node knows who its centre is, the
\ one node whose GONE it believes: (CENTRE).
header NEIGHBOUR
: NEIGHBOUR
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( port -- ) the port, by its number, leads toward every node not told of
header DEFAULT-ROUTE
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
\ ( node -- ) forget the way to that node, if one is known: what is for it
\ then goes by the way for every node not told of, if there is one. The
\ last way in the table takes its place.
header NO-ROUTE
: NO-ROUTE
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
drop ;
NONE: drop drop ;
HIT: drop drop pop drop
a -1 + push \ where its entry is
(ROUTE#) a! @ -1 + dup ! \ one way fewer
2* (ROUTES) + a! @+ @ \ the last entry: node port
pop a! SWAP !+ ! ;
\ ( about node type -- ) send the node a message of one word, `about`:
\ a GONE is type 5 (MESH.md 7b). With no way to the node it is error 12.
\ It goes or is refused at once; refused -- no one on the port, or no room
\ on the wire -- it is counted in (LOST) (MESH.md 7d.4).
: (SEND1)
push dup (WAY) -if GO
drop drop drop pop drop NODE-ERROR b! 12 !b ;
GO: (W-PORT) a! ! SWAP (ONE) a! !
pop (HDR) 4 (OUT-HDR)+6 a! !
(ONE) (W-PORT) a! @ (PUT-ON) if SENT
drop (LOST) a! @ 1 + ! ;
SENT: drop ;
\ ( n node -- ) tell the node that node n is gone. It acts on that only
\ if this node is its centre: it forgets the way to n, and if it is waiting
\ for n's answer the wait ends.
header GONE
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
header NO-ROUTES
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
\ ( baddr u node port -- ) send the node u characters of text to
\ interpret, by the port given, by its number. The text is made ready in
\ (SEND-TEXT), four characters to a word, the message is put on the wire
\ whole, and it is on its way when this returns. IT GOES OR IS REFUSED AT
\ ONCE (MESH.md 7d.1, ruling 3): with no room on the wire it is counted in
\ (REFUSED), as a refusal that came back would be, and is error 19, Message
\ refused; with no one on the port, error 18. Nothing is on a
\ wire until the put, the last thing done. More characters than a message
\ carries, or fewer than none, is error 12. What lies after the text in
\ this node's memory does not go with it: the last word is made zero past
\ the last character.
: (SEND-ON)
push 1 (HDR)
-if POS
BAD: drop drop pop drop NODE-ERROR b! 12 !b ;
LONG: drop jump BAD
POS: dup -1025 + -if LONG
drop dup (OUT-HDR)+6 a! !
(SEND-TEXT) (SEND^) a! !
3 + 2/ 2/ if NONE -1 +
FOR dup C@ over 1 + C@ 8* + over 2 + C@ 8* 8* + over 3 + C@ 8* 8* 8* +
(SEND^) b! @b a! !+ a !b 4 + NEXT
drop
(OUT-HDR)+6 a! @ 3 and if PUT \ the last word: nothing in it past the last character
(SEND^) b! @b -1 + a!
-1 + if M1 -1 + if M2
drop @ 16777215 and ! jump PUT0
M2: drop @ 65535 and ! jump PUT0
M1: drop @ 255 and ! jump PUT0
NONE: drop
PUT: drop
PUT0: (SEND-TEXT) pop (PUT-ON)
if SENT -1 + if FULL drop NODE-ERROR b! 18 !b ;
FULL: drop (REFUSED) a! @ 1 + ! NODE-ERROR b! 19 !b ;
SENT: drop ;
\ ( baddr u node -- ) send the node u characters of text to interpret,
\ by the way this node knows to it. What it prints there goes to that
\ node's console. With no way to the node it is error 12.
header SEND
: SEND
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
GO: jump (SEND-ON)
\ ( baddr u node port -- ) the same by a port this node names, by its
\ number, whatever ways it knows: for a neighbour that has no number of
\ its own yet, to which text is sent as to node 0.
header SEND-ON
: SEND-ON
dup -if POS jump BAD
POS: -PORTS + -if BAD drop jump (SEND-ON)
BAD: drop drop drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- n ) the number of this node's centre: the node on the port that
\ leads to everything it has no other way to. 0: it has none, or has not
\ been told who is there (NEIGHBOUR).
: (CENTRE)
(ROUTE-DEFAULT) a! @ if NONE (PORT) - (NEAR) + a! @ ;
NONE: ;
\ ( -- n ) the number of this node's console: the one it was told of, or
\ with none told of, whoever sent the text it is doing
: (A-CONSOLE)
(CONSOLE) a! @ if C0 ;
C0: drop (MSG)+1 a! @ ;
\ ( what -- how | ) the wait is over: 1 the answer has come, and its
\ word, in (ONE), is left; 2 refused, error 19; 3 the node is gone, error
\ 20; 4 a line from the console, error 21
: (A-END)
0 (AWAIT-FROM) a! !
-1 + if ANS -1 + if REF -1 + if LEFT drop NODE-ERROR b! 21 !b ;
ANS: drop (ONE) a! @ ;
REF: drop NODE-ERROR b! 19 !b ;
LEFT: drop NODE-ERROR b! 20 !b ;
\ ( node -- how ) WAIT FOR THE NODE'S WORD OF HOW TEXT ENDED: 0 QUIT,
\ 1 completed, 2 an error. (AWAIT-FROM) holds the node while this node
\ waits, and 0 otherwise. It sleeps, executing nothing, until a message
\ comes; then it passes on what is for other nodes, (SERVE), and goes
\ through what is for itself (MESH.md 7d.4):
\ the answer -- a message of type 3 from that node -- is taken, and the
\ wait is over;
\ a NACK is taken: about that node, the wait ends in error 19, Message
\ refused; about another it is counted, as at any time;
\ a GONE is taken: believed (its centre sent it: (GONE?)) and about that
\ node, the wait ends in error 20, Node gone;
\ text from its console ends the wait in error 21, Interrupted (7b.6).
\ The text is not taken: it stays on its wire and is done when this
\ text has been finished with. It is the one way to end a wait on
\ a node that is alive and never answers, short of Hera's killing
\ that node;
\ anything else stays on its wire, in its order, for when this node has
\ nothing to do.
\ WHAT HAS COME ALREADY is on the wires and is found the first time
\ through: the node looks before it sleeps. A message it left on a wire
\ does not keep it awake.
\ The stack what it does needs is tried first, (ROOM), core.v4: text that
\ has left too little ends "Stack overflow" with nothing taken off a wire.
header AWAIT
: AWAIT
(ONE) a! ! (ROOM) \ if this faults, no one is waited for:
(ONE) a! @ (AWAIT-FROM) a! ! 0 (A-SELF) a! ! \ (AWAIT-FROM) is set only when the stack has been tried
L: (SERVE)
(A-SELF) a! @ if SCAN drop 2 jump (A-END) \ this node's own message for that node came back to it
SCAN: drop (MINE0)
M: (MINE) if SLEEP
drop (IN)+2 a! @ -1 + if TEXT -2 + if ANSWER -1 + if NACK -1 + if GONE
KEEP: drop (SKIP) jump M
TEXT: drop (A-CONSOLE) (IN)+1 a! @ xor if BREAK jump KEEP \ text: from the console?
BREAK: drop 4 jump (A-END)
ANSWER: drop (IN)+1 a! @ (AWAIT-FROM) a! @ xor if A1 jump KEEP
A1: drop (IN)+6 a! @ -4 + if A2 jump KEEP
A2: drop (TAKE1) if A3 drop (UNTAKEN) jump M \ not taken: nothing is done for it
A3: drop 1 jump (A-END)
NACK: drop (IN)+6 a! @ -4 + if N1 jump KEEP
N1: drop (TAKE1) if N0 drop (UNTAKEN) jump M
N0: drop (ONE) a! @ (AWAIT-FROM) a! @ xor if N2 \ about the node waited for?
drop (REFUSED) a! @ 1 + ! jump M \ another: counted
N2: drop 2 jump (A-END)
GONE: drop (IN)+6 a! @ -4 + if G1 jump KEEP
G1: drop (TAKE1) if G0 drop (UNTAKEN) jump M
G0: drop (GONE?) if M0 \ only its centre is believed
drop (ONE) a! @ (AWAIT-FROM) a! @ xor if G2 drop jump M
G2: drop 3 jump (A-END)
M0: drop jump M
SLEEP: drop (SLEEP) jump L
\ ( w port -- ) write a cell to the port, by its number. It waits until
\ the neighbour has taken it. This is how a node is sent a capsule of F18
\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a
\ message, to a node that is executing from its ports.
header PORT!
: PORT!
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- ) WHAT IS IN THE DICTIONARY NOW IS THE SYSTEM: COLD comes back to
\ it and FORGET will not go below it. Whoever has loaded a node's capsules
\ has it do this (system.v4, (BOOT) and FENCE).
header (SEAL)
: (SEAL)
DP a! @ (BOOT) a! !
(LATEST) a! @ (BOOT)+1 a! !
DP a! @ 3 + 2/ 2/ FENCE a! ! ;
\ FORTH-79: clear the return stack, set execution mode, return control to
\ the terminal; no message is given. The data stack is left as it is.
\ NODE-ERROR, by name: how a definition written in FORTH raises an error.
\ A store of a code that is not zero is the trap of D-18 -- the word goes no
\ further, the message for the code is printed (-1: the word has printed
\ its own) and the line ends with ERROR. The codes are listed in core.v4.
header NODE-ERROR inline : NODE-ERROR' NODE-ERROR ;
header (ME) inline : (ME)' (ME) ;
header (CONSOLE) inline : (CONSOLE)' (CONSOLE) ;
header (LOST) inline : (LOST)' (LOST) ;
header (REFUSED) inline : (REFUSED)' (REFUSED) ;
header (WORD-DEFINED) inline : (WORD-DEFINED)' (WORD-DEFINED) ;
header (WORD-FORGOTTEN) inline : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
header QUIT
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
\ FORTH-79: clear the data and return stacks, set execution mode, return
\ control to the terminal. As v3, the line it stops ends with " ok".
\ Both are emptied before anything is called: ABORT may be run with the
\ return stack full.
header ABORT
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
\ ---- faults (D-14, D-16) -------------------------------------------------------
\ Where the node goes when a programme uses an address outside its memory,
\ pushes onto a full stack or pops an empty one. The opcode that faulted did
\ nothing, and both stacks have been emptied. Each handler says what happened;
\ whatever was running is abandoned, as by ABORT, and the line ends with
\ ERROR.
: (FAULT) \ "Address out of range"
$72646441 (EMIT4) $20737365 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR
2 jump (DONE)
: (D-OVER) \ "Stack overflow"
$63617453 (EMIT4) $766F206B (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
: (D-UNDER) \ "Stack underflow"
$63617453 (EMIT4) $6E75206B (EMIT4) $66726564 (EMIT4) $776F6C (EMIT4) CR
2 jump (DONE)
: (R-OVER) \ "Return stack overflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $65766F20 (EMIT4) $6F6C6672 (EMIT4) $77 (EMIT4) CR
2 jump (DONE)
: (R-UNDER) \ "Return stack underflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $646E7520 (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
\ A word has stored an error code in NODE-ERROR (D-18; the codes are listed
\ in core.v4). Print its message -- a negative code means the word printed
\ its own -- and end the line with ERROR. The return stack has been
\ emptied; the data stack is as the word left it.
\ (QUIET) is 1 while the node is doing something that is no text's doing:
\ passing a message on, or sending what a text printed and word of how it
\ ended. An error then has nobody to be told to, and telling it would
\ begin another message for a text that is over. Nothing the nucleus does
\ there raises one as it stands -- with no one on a port it counts what it
\ could not send, and goes on -- so this is a guard: if one is raised, what
\ was being sent is let go and counted, and the node goes back to waiting.
: (RAISED)
(QUIET) a! @ if SPEAK
drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! jump (IDLE)
SPEAK: drop
NODE-ERROR b! @b
-if POS drop 2 jump (DONE)
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9
-1 + if M10 -1 + if M11 -1 + if M12 -1 + if M13 -1 + if M14
-1 + if M15 -1 + if M16 -1 + if M17 -1 + if M18
-1 + if M19 -1 + if M20 -1 + if M21
drop 2 jump (DONE)
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (DONE)
M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (DONE)
M3: drop $626D754E (EMIT4) $74207265 (EMIT4) $6C206F6F (EMIT4) $676E6F (EMIT4) CR 2 jump (DONE)
M4: drop $20746F4E (EMIT4) $68632061 (EMIT4) $63617261 (EMIT4) $726574 (EMIT4) CR 2 jump (DONE)
M5: drop $74636944 (EMIT4) $616E6F69 (EMIT4) $66207972 (EMIT4) $6C6C75 (EMIT4) CR 2 jump (DONE)
M6: drop $656D614E (EMIT4) $73696D20 (EMIT4) $676E6973 (EMIT4) CR 2 jump (DONE)
M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (DONE)
M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (DONE)
M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (DONE)
M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M11: drop $69766944 (EMIT4) $6E6F6973 (EMIT4) $20796220 (EMIT4) $6F72657A (EMIT4) CR 2 jump (DONE)
M12: drop $75677241 (EMIT4) $746E656D (EMIT4) $74756F20 (EMIT4) $20666F20 (EMIT4) $676E6172 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M13: drop $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR 2 jump (DONE)
M14: drop $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR 2 jump (DONE)
M15: drop $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR 2 jump (DONE)
M16: drop $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M17: drop $726F7453 (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M18: drop (OUT) (OUT^) a! ! \ what was printed and not sent cannot be sent: it is let go
$6F206F4E (EMIT4) $6F20656E (EMIT4) $6874206E (EMIT4) $70207461 (EMIT4) $74726F (EMIT4) CR 2 jump (DONE)
M19: drop $7373654D (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M20: drop $65646F4E (EMIT4) $6E6F6720 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M21: drop $65746E49 (EMIT4) $70757272 (EMIT4) $646574 (EMIT4) CR 2 jump (DONE)
\ The table the loader gives the node: six words, one for each kind of
\ fault in the node's order, each a jump. A jump fills its word, so they
\ are one after another.
: (FAULTS)
jump (FAULT) jump (D-OVER) jump (D-UNDER) jump (R-OVER) jump (R-UNDER) jump (RAISED)
\ ---- text in the source ---------------------------------------------------------
\ The three run-time words have names, as v3's have, so that SEE can tell a
\ string in a definition from code; they cannot be used from the prompt.
\ ." and ABORT" take the text up to the next " , which may be none at all
\ (input.v4's (PARSE)); with no closing " it is the rest of the line. Inside a definition they lay
\ down a call to their run-time word and, after it, the text as a counted
\ string: the count byte and the characters, four to a cell, the last cell
\ filled with zeros. The run-time word finds the string by the return
\ address the call left, and returns to the cell after the string.
\ ( -- ) lay the counted string in WBUF into the dictionary, as above.
\ (Q)+0 how many bytes are still to go, (Q)+1 which is next.
: (STRING,)
(FLUSH)
WBUF C@ 1 + (Q) a! ! 0 (Q)+1 a! !
L: (Q) a! @ if DONE -1 + !
(Q)+1 a! @ dup 1 + ! WBUF + C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop ;
\ The run time of ." : print the string after the call, go on after it.
\ It takes the return address off before it calls anything and keeps the
\ count there instead, so a word that prints text goes no deeper than one
\ that calls any other word.
header (.") compile-only
: (.")
pop 4* dup C@ \ baddr n
L: if DONE
push 1 + dup C@ EMIT pop -1 + jump L
DONE: drop 4/ 1 + push ; \ the cell after the last character
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
\ it is compiled into runs, if compiling.
header ." immediate
: DOT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(.") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT jump TYPE
\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the
\ string after the call, start a new line and ABORT; otherwise go on after
\ the string.
header (ABORT") compile-only
: (ABORT")
if NO
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
NO: drop pop 4* dup C@ + 4/ 1 + push ;
\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if
\ the flag is not zero, print the text and ABORT.
header ABORT" immediate
: ABORT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(ABORT") (CALL,) jump (STRING,)
NOW: drop if NO
drop WBUF COUNT TYPE CR jump ABORT
NO: drop ;
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
header (S") compile-only
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
push 1 + pop ; \ baddr+1 n
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
header S" immediate
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(S") (CALL,) jump (STRING,)
NOW: drop WBUF+1 PAD WBUF C@ CMOVE PAD WBUF jump C@
v4/capsule/system.v4
-170
View File
@@ -1,170 +0,0 @@
\ system.v4 -- words about the dictionary as a whole: WORDS, FORGET, FENCE.
\
\ DECOMPOSITION.md 5.13 and 5.15. Part of the compiler capsule; rests on
\ dict.v4, quit.v4 and forth.v4.
\
\ Constants the loader supplies:
\ FENCE word address of the variable: FORGET will not remove an entry
\ that starts below the address it holds
\ VOC-LINK word address of the variable: the newest vocabulary, or 0
\ (BOOT) word address of two cells: DP and (LATEST) as the loader left them
header FENCE inline : FENCE' FENCE ;
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
\ A vocabulary is two cells: its head -- the xt of its newest entry, or 0 --
\ and the address of the vocabulary defined before it, or 0. VOC-LINK holds
\ the newest one's address. FORTH's head is (LATEST) and it is in no chain.
header CONTEXT inline : CONTEXT' CONTEXT ;
header CURRENT inline : CURRENT' CURRENT ;
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
header FORTH immediate
: FORTH (LATEST) CONTEXT a! ! ;
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
header DEFINITIONS
: DEFINITIONS CONTEXT a! @ CURRENT a! ! ;
\ VOCABULARY xxx FORTH-79: xxx is a new, empty list of words; executing
\ xxx makes it the CONTEXT vocabulary. When a search of it finds nothing,
\ FORTH is searched.
: (DOVOC) pop CONTEXT a! ! ;
header VOCABULARY
: VOCABULARY
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
0 , VOC-LINK a! @ , HERE -2 + VOC-LINK a! ! ;
NONE: drop ;
\ ( cell -- ) print the name of the vocabulary whose head cell this is
: (.VOC)
dup (LATEST) xor if F drop -1 + -2 + a! @ 4* COUNT 31 and jump TYPE
F: drop drop $54524F46 (EMIT4) $48 (EMIT4) ;
\ ( -- ) as v3's, but true: where names are looked for, and where new ones go
header ORDER
: ORDER
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
CONTEXT a! @ dup (.VOC) SPACE
(LATEST) xor if ONLY drop (LATEST) (.VOC) jump TWO
ONLY: drop
TWO: CR
$72727543 (EMIT4) $3A746E65 (EMIT4) $20 (EMIT4)
CURRENT a! @ (.VOC) jump CR
\ ( -- ) the names in the CONTEXT vocabulary, the newest first, a blank after
\ each, a new line whenever one has passed column 64. Hidden entries -- a
\ definition under way -- are not shown. (Q)+0 is the column.
header WORDS
: WORDS
0 (Q) a! !
CONTEXT a! @ a! @
L: if DONE
dup -3 + a! @ 2 and if SHOW drop jump NXT
SHOW: drop
dup -2 + a! @ 4* COUNT 31 and \ xt baddr u
dup (Q) a! @ + 1 + !
TYPE SPACE
(Q) a! @ -64 + -if WRAP drop jump NXT
WRAP: drop CR 0 (Q) a! !
NXT: -1 + a! @ jump L
DONE: drop jump CR
header VLIST
: VLIST jump WORDS
\ ( cell -- ) take off a vocabulary's list every entry at or above the
\ address in (Q)+0. The newest are first, so it stops at the first one below.
: (PRUNE)
(Q)+1 a! !
L: (Q)+1 a! @ a! @ if DONE
dup (Q) a! @ inv + 1 + -if CUT drop drop ;
CUT: drop -1 + a! @ (Q)+1 a! @ a! ! jump L
DONE: drop ;
\ FORGET xxx FORTH-79: remove xxx and every word defined after it, in
\ whatever vocabulary; the space they took is free again. A vocabulary that
\ goes is no longer CONTEXT or CURRENT: FORTH is. A word that is not there
\ is an error, and so is one below FENCE, which is where the capsule's own
\ words are (code 10, "Protected word").
header FORGET
: FORGET
32 WORD (LOOKUP) if MISSING
-2 + a! @ \ where its name starts
dup FENCE a! @ inv + 1 + -if OK \ name - fence
drop drop NODE-ERROR b! 10 !b ;
OK: drop
dup (Q) a! ! 4* DP a! ! \ the space from its name on
(LATEST) (PRUNE)
V: VOC-LINK a! @ if PRUNED \ vocabularies that go
dup (Q) a! @ inv + 1 + -if GONE drop jump KEPT
GONE: drop 1 + a! @ VOC-LINK a! ! jump V
KEPT: P: if PRUNED \ the lists of those that stay
dup (PRUNE) 1 + a! @ jump P
PRUNED: drop
CONTEXT a! @ (Q) a! @ inv + 1 + -if C1 drop jump C2
C1: drop (LATEST) CONTEXT a! !
C2: CURRENT a! @ (Q) a! @ inv + 1 + -if C3 drop jump TOLD
C3: drop (LATEST) CURRENT a! !
TOLD: (Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.v4)
MISSING: drop (UNKNOWN) drop ;
\ ---- the system as a whole -------------------------------------------------------
\ (BOOT) is two cells the loader fills when the capsule is in place: DP and
\ the newest FORTH entry as they then are. COLD goes back to them.
\ FORTH-79: execute to be sure a FORTH-79 system is there. It is: nothing
\ happens. (v3's prints two lines and leaves a flag.)
header 79-STANDARD
: 79-STANDARD ;
\ ( -- ) which system this is, and its cell width
header VERSION
: VERSION
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
N-1 1 + 0 U-DOT-R $7469622D (EMIT4) CR ;
\ ( -- ) clear the screen and put the cursor at the top, as v3: ESC [2J ESC [H
header PAGE
: PAGE 27 EMIT 91 EMIT 50 EMIT 74 EMIT 27 EMIT 91 EMIT 72 jump EMIT
\ ( -- ) as v3's message, and then ABORT: both stacks emptied, the prompt
header WARM
: WARM
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $72206D65 (EMIT4) $61747365 (EMIT4) $64657472 (EMIT4) $2E (EMIT4) CR
jump ABORT
\ ( -- ) the system as it was when the capsule had just been loaded:
\ everything defined since is gone, there is one vocabulary, numbers are
\ decimal, the block buffers are empty. Then as WARM.
header COLD
: COLD
(BOOT) a! @ DP a! !
(BOOT)+1 a! @ (LATEST) a! !
(BOOT) a! @ 2/ 2/ FENCE a! !
(LATEST) CONTEXT a! ! (LATEST) CURRENT a! ! 0 VOC-LINK a! !
10 BASE a! ! 0 SCR a! ! 2 (LOG-LEVEL) a! ! 0 (ACL-HOOK) a! ! EMPTY-BUFFERS
(BOOT) a! @ 2/ 2/ (FORGOTTEN) \ the kernel's records of what has gone go too (dict.v4)
$54524F46 (EMIT4) $39372D48 (EMIT4) $6C6F4320 (EMIT4) $74532064 (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $69206D65 (EMIT4) $6974696E (EMIT4) $7A696C61 (EMIT4) $2E6465 (EMIT4) CR
jump ABORT
\ ---- deferred words (as v3) -------------------------------------------------------
\ DEFER xxx makes xxx, which does whatever word it has been given:
\ ' yyy IS xxx gives it one; DEFER@ xxx leaves the one it has. A deferred
\ word with none is an error (code 15, "Deferred word not set").
: (DODEFER)
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
UNSET: drop NODE-ERROR b! 15 !b ;
header DEFER
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
: (is!) a! ! ;
: (defer@) a! @ ;
header IS immediate
: IS
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
NOW: drop jump (is!)
header DEFER@ immediate
: DEFER@
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
NOW: drop jump (defer@)
v4/capsule/words.v4
-201
View File
@@ -1,201 +0,0 @@
\ words.v4 -- more of the FORTH vocabulary: the stack, comparison, double,
\ mixed, shift and string words that are short runs of opcodes or small loops.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.7, 5.9)
\ and the mesh-node tests execute (test_cells.c, test_foundation.c,
\ test_strings.c), here as words of the host node's vocabulary. Rests on
\ core.v4, forth.v4 and numout.v4.
\
\ Constants the loader supplies:
\ MAX-INT the largest positive number: every bit but the top one
\ (X) word address of four cells of scratch for COMPARE and SEARCH
\ ---- stack ----
header 2SWAP
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
header 2OVER
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
header 2ROT
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
header 2>R inline compile-only : 2>R SWAP push push ;
header 2R> inline compile-only : 2R> pop pop SWAP ;
header 2R@ inline compile-only : 2R@ pop pop over over push push SWAP ;
header NOP inline : NOP' nop ;
header TRUE inline : TRUE -1 ;
header FALSE inline : FALSE 0 ;
header INVERT inline : INVERT inv ;
\ ---- memory ----
header 2@
: 2@ ( addr -- lo hi ) a! @+ @ ;
header 2!
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
header -!
: -! ( n addr -- ) a! NEGATE @ + ! ;
\ ---- comparison ----
header 0<>
: 0<> if Z drop -1 ; Z: ;
header 0>
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
header <>
: <> xor jump 0<>
header <=
: <= GREATER jump 0=
header >=
: >= LESS jump 0=
header U<
: U< over over xor -if SAME drop NIP jump 0<
SAME: drop - jump 0<
header U>
: U> SWAP jump U<
header ABS
: ABS -if P inv 1 + P: ;
header MAX
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
header MIN
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
header WITHIN
: WITHIN ( n low high -- flag ) push over pop LESS push LESS inv pop and ;
\ ---- shifts ----
\ As v3, a count that is negative or as large as the cell is wide is an
\ error (code 9, "Shift count out of range").
header LSHIFT
: LSHIFT ( x n -- x' )
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2* pop jump L
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
header RSHIFT
: RSHIFT ( x n -- x' ) \ zeros come in at the top
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2/ MAX-INT and pop jump L
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
\ ---- doubles and mixed ----
header D-
: D- DNEGATE jump D+
header DABS
: DABS -if P jump DNEGATE P: ;
header D0=
: D0= OR jump 0=
header D0<
: D0< push drop pop jump 0<
header D=
: D= D- jump D0=
header D2*
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
header D2/
: D2/ push a! 0 pop +* push drop a pop ;
header M+
: M+ S>D jump D+
header M-
: M- S>D DNEGATE jump D+
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
: (D<)
dup push push over pop over over xor if TIE
drop over over xor -if HS drop drop jump S1
HS: drop push inv pop + inv
S1: -if N1 drop -1 jump D1 N1: drop 0
D1: pop SWAP ;
TIE: drop drop drop dup push push over pop
over over xor -if LS drop NIP jump S2
LS: drop push inv pop + inv
S2: -if N2 drop -1 jump D2 N2: drop 0
D2: pop pop ROT ;
header D<
: D< (D<) push drop drop drop drop pop ;
header DMAX
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
header DMIN
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
\ ---- strings and memory ----
header ?TERMINAL
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
header CMOVE>
: CMOVE> ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE -1 + push
over pop dup push + C@
over pop dup push + C!
pop jump OK
DONE: drop drop drop ;
\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
header MOVE
: MOVE ( addr1 addr2 n -- )
-if OK drop drop drop ;
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
header FILL
: FILL ( baddr u c -- )
SWAP push SWAP pop \ c baddr u
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push over over C! 1 + pop -1 + jump OK
DONE: drop drop drop ;
header ERASE
: ERASE ( baddr u -- ) 0 jump FILL
header BLANK
: BLANK ( baddr u -- ) 32 jump FILL
header -TRAILING
: -TRAILING ( baddr u -- baddr u' )
-if L drop 0 ;
L: if DONE over over + -1 + C@ -32 + if SP drop ;
SP: drop -1 + jump L
DONE: ;
header COMPARE
: COMPARE ( a1 u1 a2 u2 -- n )
-if A drop 0 A: (X)+1 b! !b
SWAP -if B drop 0 B: dup (X) b! !b
(X)+1 b! @b
over over - -if GE drop drop jump M
GE: drop push drop pop
M:
L: if EQ push
over C@ over C@ - if SAME
-if GT drop drop drop pop drop -1 ;
GT: drop drop drop pop drop 1 ;
SAME: drop 1 + push 1 + pop pop -1 + jump L
EQ: drop drop drop (X) b! @b (X)+1 b! @b -
-if NN drop -1 ;
NN: if ZZ drop 1 ;
ZZ: ;
header SEARCH
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
-if A drop 0 A: (X)+1 b! !b (X) b! !b
-if B drop 0 B: dup (X)+3 b! !b over (X)+2 b! !b
L: dup (X)+1 b! @b - -if TRY
drop drop drop (X)+2 b! @b (X)+3 b! @b 0 ;
TRY: drop over (X) b! @b (X)+1 b! @b
I: if MATCH push
over C@ over C@ xor if SAME
drop drop drop pop drop push 1 + pop -1 + jump L
SAME: drop 1 + push 1 + pop pop -1 + jump I
MATCH: drop drop drop -1 ;
header SCAN
: SCAN ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if FOUND
drop push 1 + pop -1 + jump L
FOUND: drop
DONE: pop drop ;
header SKIP
: SKIP ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if SAME drop jump DONE
SAME: drop push 1 + pop -1 + jump L
DONE: pop drop ;
v4/include/v4/boot.h
+10 -7
View File
@@ -1,11 +1,13 @@
/* boot.h -- how a StarForth v4 system comes up: the nucleus, then its
* capsules, then the prompt. docs/v4.0.0/NUCLEUS.md.
/* boot.h -- how a StarForth v4 system comes up: the machine's ROM assembles
* the system, then its capsules are loaded, then the prompt.
* docs/v4.0.0/MACHINE.md, NUCLEUS.md.
*
* The hosted binary (tools/hosted.c) and the bare-metal kernel
* (kernel/src/v4/sk_v4.c) both call v4_boot_run and differ only in where
* the text goes. So the two start the same way and print the same lines:
*
* PARITY:V4_NUCLEUS name=v4:nucleus-64.f18 capsule_id=0x... capsule_hash=0x... words=N
* PARITY:V4_F18 name=v4:sys:map-64.f18 capsule_hash=0x... (one for each blob of the system's source)
* PARITY:V4_ROM words=N rom_hash=0x... instructions=N (the ROM, and what assembling the system cost)
* PARITY:V4_CAPSULE name=v4:forth79.4th capsule_id=0x... capsule_hash=0x... dict_hash=0x...
* PARITY:V4_POST tests=N pass=N fail=N (POST is the kernel's: v4/post.h)
* PARITY:V4_SYSTEM word_count=N dict_hash=0x... (the system as sealed, after POST)
@@ -39,13 +41,13 @@ typedef struct {
v4_node *n;
v4_exec_state *es;
v4_heat *h;
const v4_image *im; /* the nucleus */
v4_image *im; /* the system: the map's description (v4_map_image), which the boot completes */
void (*out)(const char *text, unsigned len); /* the console */
int (*key)(void); /* a character for a line that reads the keyboard, or 0: there is none */
/* THE KERNEL'S WORDS (docs/v4.0.0/ENGINE.md 3.3). `words` names them,
* `word_count` of them; the boot makes each a word on the node (KERNEL-
* WORD, v4/capsule/compile.v4) whose request number is its place in the
* WORD, capsules/v4/sys/compile.f18) whose request number is its place in the
* list, counting from 1. When the node writes a request to its port it
* is blocked, and `serve` is called with the number: it takes the
* word's arguments from the node's data stack and leaves its results
@@ -63,8 +65,9 @@ typedef struct {
#define V4_BOOT_KEY_NONE (-1) /* not yet: it is asked again */
#define V4_BOOT_KEY_END (-2) /* and there never will be */
/* A node is born empty (v4_image_born); it is sent the nucleus through its
* port; and the capsules are loaded. Its blocks are the kernel's block
/* A node is born empty (v4_image_born); its ROM assembles the system from
* its source, capsules/v4/sys, fed to it through its console; and the
* capsules are loaded. Its blocks are the kernel's block
* subsystem's, which whoever calls this has set up (v4/blocks.h). Returns 1 with the node idle,
* waiting to be handed a line; or 0, the failure printed. It prints no
* prompt: that is the host's. */
v4/include/v4/capsule.h
+3 -2
View File
@@ -18,8 +18,9 @@
* jump start
*
* This is the F18's own way of loading a node through a port. Nothing here
* knows what the programme is: StarForth's nucleus is one such capsule
* (v4/tools/mkimage.c), and anything written for the node is another.
* knows what the programme is: StarForth's system, as the machine's ROM
* assembled it, is one such capsule (what a node that is born is sent:
* tests/test_host_unit.c), and anything written for the node is another.
*/
#ifndef V4_CAPSULE_H
#define V4_CAPSULE_H
v4/include/v4/image.h
+41 -26
View File
@@ -1,18 +1,19 @@
/* image.h -- the StarForth nucleus, as its host knows it: where things are
* in a node that has taken it in, and how a line is handed to that node.
/* image.h -- the StarForth system, as its host knows it: where things are
* in a node that holds it, and how a line is handed to that node.
*
* The nucleus is text (capsule/ *.v4). tools/mkimage.c assembles it on the
* build machine and writes two things:
* The system is text, the .f18 blobs of capsules/v4/sys, and the machine's
* ROM assembles it when the machine starts (docs/v4.0.0/MACHINE.md; v4/
* system/boot.c). Its host knows two things of it:
*
* - the nucleus as a capsule of F18 code (capsule.h), which is put into
* an empty node through its port. It is a capsule like any other: in
* the capsule directory, with a name, a hash and a signature
* (capsules/v4/nucleus-<width>.f18). docs/v4.0.0/MESH.md section 5.
* - this description of it, a C file: the addresses a host needs.
* - the memory map, before it is built: v4_map_image, a C file that
* tools/mkmap.c writes from the map (`mkmap image`);
* - what only the assembled system knows -- where it waits, its fault
* table, KEY -- from the image record, a fixed block of RAM whose
* address is a constant of the map and which the system's source
* stores (capsules/v4/sys/end.f18): v4_image_from_node.
*
* A node that has taken the nucleus in is sent text as messages and sends
* back what it prints (v4/include/v4/message.h); nothing here hands it a
* line.
* A node that holds the system is sent text as messages and sends back
* what it prints (v4/include/v4/message.h); nothing here hands it a line.
*
* A description is for one cell width, one node size and one pair of stack
* sizes; v4_image_born refuses one the engine was not built for.
@@ -26,9 +27,11 @@ typedef struct {
/* what the image was built for */
unsigned cell_bits, node_words, data_ring, ret_ring;
/* Where the nucleus waits for a message (v4/capsule/quit.v4, (IDLE)):
* a node that has taken the nucleus in begins there, and with nothing
* to do it is asleep at a wire inside it (operation 8, MESH.md 7d.3). */
/* Where the system waits for a message (capsules/v4/sys/quit.f18,
* (IDLE)): a node that holds the system begins there, and with nothing
* to do it is asleep at a wire inside it (operation 8, MESH.md 7d.3).
* This, fault_table, key_start and key_end are -1 until the system is
* built (v4_image_from_node). */
v4_cell idle;
v4_cell fault_table; /* (FAULTS): where a fault goes */
v4_cell port; /* word address of the node's port (node.h) */
@@ -38,7 +41,7 @@ typedef struct {
v4_cell key_start, key_end;
/* the memory-mapped registers (DECOMPOSITION.md section 7; D-4 leaves
* the map to the loader, and this is the map the image was built with) */
* the map to the loader, and this is the map the system is built with) */
v4_cell console_tx, console_rx, console_status;
v4_cell dstack_reg, rstack_reg;
v4_cell node_error;
@@ -50,24 +53,36 @@ typedef struct {
/* What COLD returns the system to and FORGET will not go below: two
* cells, DP and LATEST as they were when the system was complete, and
* the variable FENCE. The image has them as the nucleus alone; a system
* that loads capsules when it boots sets them again when it has
* the variable FENCE. The system's source sets them; a system that
* loads capsules when it boots sets them again when it has
* (v4_image_seal). */
v4_cell boot_cells, fence;
/* the block window: the word address of the slots the kernel copies
* blocks into (v4/blocks.h) */
v4_cell block_window;
/* the image record (capsules/v4/sys/end.f18): four cells, where the
* system waits, its fault table, KEY and the word after KEY; and the
* ROM's two cells that say why it stopped, if it did: the code of its
* error (0 if none) and the line it was on, counting from 0 */
v4_cell record, rom_failed, rom_errline;
} v4_image;
/* The nucleus's error for a node blocked at a port with no one on it
* (v4/capsule/core.v4's list; node.h, v4_node_port_gone): "No one on that
* port". */
/* The system's error for a node blocked at a port with no one on it
* (capsules/v4/sys/core.f18's list; node.h, v4_node_port_gone): "No one on
* that port". */
#define V4_ERROR_NO_ONE 18
/* The description of the nucleus built from v4/capsule (the generated file
* defines it). */
extern const v4_image v4_capsule_image;
/* The memory map's description of the system (the generated file defines
* it): what is known of it before it is built. */
extern const v4_image v4_map_image;
/* What only the assembled system knows, read from the image record of the
* node `n` that holds it into `im`, which the map's description is in.
* Returns 1, or 0 if the record does not name addresses of the node's
* memory (nothing is then changed). */
int v4_image_from_node(const v4_node *n, v4_image *im);
/* The system is complete: what is in the dictionary now is what COLD comes
* back to, and FORGET will not go below it. */
@@ -79,9 +94,9 @@ void v4_image_seal(v4_node *n, const v4_image *im);
* width, gives the same hash for the same dictionary. */
uint64_t v4_image_dict_hash(const v4_node *n, const v4_image *im);
/* A node newly born (node.h), with the registers the nucleus expects of the
/* A node newly born (node.h), with the registers the system expects of the
* node it runs on. Its memory is empty and it is blocked
* reading its ports: the nucleus is yet to be sent to it. Returns 1, or 0
* reading its ports: its code is yet to be sent to it, or assembled on it. Returns 1, or 0
* if the description is not for this build of the engine (nothing is then
* done). */
int v4_image_born(v4_node *n, v4_exec_state *es, v4_heat *h, const v4_image *im);
v4/include/v4/manage.h
+1 -1
View File
@@ -5,7 +5,7 @@
* a node like any other and cannot make one: she asks, by a write to the
* port where her requests go (ENGINE.md 3.3), and the write blocks her until
* she is answered. Each request is a word on her, made with KERNEL-WORD
* (v4/capsule/compile.v4); its arguments are what it finds on her data
* (capsules/v4/sys/compile.f18); its arguments are what it finds on her data
* stack and its results are what is left there.
*
* These are the requests, in order. The n-th is request `first + n`, where
v4/include/v4/message.h
+1 -1
View File
@@ -18,7 +18,7 @@
*
* This is for whatever is on the other end of a node's port and is not a
* node -- a console, a host -- to speak what the nodes speak (v4/capsule/
* core.v4 and quit.v4 are the same thing in the node). Nothing here uses
* core.f18 and quit.f18 are the same thing in the node). Nothing here uses
* the C library.
*/
#ifndef V4_MESSAGE_H
v4/include/v4/node.h
+1 -1
View File
@@ -380,7 +380,7 @@ void v4_node_rom_attach(v4_node *n, const v4_cell *rom, unsigned words);
* chose to, after taking its own arguments off);
* - P becomes fault_vector + fault_kind. The handler table is six words,
* one for each kind in the order below, each a jump to that kind's
* handler (capsule/quit.v4, (FAULTS)).
* handler (capsules/v4/sys/quit.f18, (FAULTS)).
* With no table attached (fault_vector -1) the node stops instead: `stopped`
* is set and v4_exec_step_word does nothing more until the node is reset or
* a table is attached.
v4/include/v4/text.h
+23 -1
View File
@@ -56,7 +56,21 @@
* count byte, then its characters, four to a cell, low
* byte first, zero-padded to a whole cell.
*
* header NAME a dictionary entry for NAME (capsule/dict.v4), laid down
* set NAME VALUE an assembler variable: like a constant, but it may be
* set again (the newest value is its value). In code it
* is a literal.
* here as a VALUE: the next word address, the word being built
* ended first. Not something to assemble on its own.
* store ADDR VALUE ADDR, a VALUE that is a word of RAM, is given VALUE: the
* state the system is switched on in.
* start NAME the end of the text: every branch must have its target,
* and NAME, a word, is where the system starts
* (v4_text_start). Nothing may follow.
* These four, constant, #, and ", are the ROM's language
* (docs/v4.0.0/MACHINE.md): the ROM assembles the same
* text the same way.
*
* header NAME a dictionary entry for NAME (capsules/v4/sys/dict.f18), laid down
* in front of the word that the next `:` starts, and
* linked to the header before it. NAME is taken as it
* stands -- it may be ( or \ or + -- and is at most 31
@@ -123,6 +137,7 @@ typedef struct {
unsigned pool_used;
v4_cell latest; /* xt of the newest header, 0 if none */
v4_cell start; /* the word `start` named, -1 if none yet */
int header_pending; /* a header waits for its `:` */
unsigned line;
@@ -155,6 +170,13 @@ v4_cell v4_text_word(const v4_text *t, const char *name);
* dictionary's LATEST starts as. */
v4_cell v4_text_latest(const v4_text *t);
/* The value of the constant or set variable NAME: 1 and *value, or 0 if
* NAME is neither. */
int v4_text_value(const v4_text *t, const char *name, v4_cell *value);
/* The word `start` named, or -1 if the text has had no start. */
v4_cell v4_text_start(const v4_text *t);
/* The next free word address. */
v4_cell v4_text_here(v4_text *t);
v4/src/image.c
+16 -1
View File
@@ -1,4 +1,4 @@
/* image.c -- the StarForth nucleus, as its host knows it. See image.h.
/* image.c -- the StarForth system, as its host knows it. See image.h.
*
* Nothing here uses the C library: the bare-metal kernel links this file.
*/
@@ -22,6 +22,21 @@ int v4_image_born(v4_node *n, v4_exec_state *es, v4_heat *h, const v4_image *im)
return 1;
}
int v4_image_from_node(const v4_node *n, v4_image *im)
{
v4_cell r = im->record, idle, faults, key, key_end;
if (r < 0 || r + 3 >= (v4_cell)V4_NODE_WORDS) return 0;
idle = n->mem[r]; faults = n->mem[r + 1]; key = n->mem[r + 2]; key_end = n->mem[r + 3];
if (idle <= 0 || idle >= (v4_cell)V4_NODE_WORDS || faults <= 0 || faults >= (v4_cell)V4_NODE_WORDS
|| key <= 0 || key_end <= key || key_end >= (v4_cell)V4_NODE_WORDS)
return 0;
im->idle = idle;
im->fault_table = faults;
im->key_start = key;
im->key_end = key_end;
return 1;
}
int v4_image_waiting(const v4_node *n, const v4_image *im)
{
return n->input_pos == n->input_len && n->p >= im->key_start && n->p < im->key_end;
v4/src/manage.c
+1 -1
View File
@@ -10,7 +10,7 @@ const char *const v4_manage_words[V4_MANAGE_WORDS] = {
};
/* A character of the node's memory: four to a cell, the first lowest, as
* the nucleus keeps text (v4/capsule/core.v4). */
* the nucleus keeps text (capsules/v4/sys/core.f18). */
static int in_memory(v4_cell baddr) { return baddr >= 0 && (baddr >> 2) < (v4_cell)V4_NODE_WORDS; }
static char char_at(const v4_node *n, v4_cell baddr)
{
v4/src/text.c
+75 -8
View File
@@ -5,7 +5,7 @@
#include <stdlib.h>
#include <string.h>
enum { KIND_WORD = 1, KIND_CONST, KIND_MACRO };
enum { KIND_WORD = 1, KIND_CONST, KIND_MACRO, KIND_SET }; /* the ROM's kinds: 1 word, 2 constant, 3 macro, 4 set variable */
static const char *const mnemonic[V4_OPCODE_COUNT] = {
";", "ex", "jump", "call", "unext", "next", "if", "-if",
@@ -50,7 +50,7 @@ static const v4_text_symbol *find(const v4_text *t, const char *s)
return NULL;
}
/* The entry flags a `header` may be given (capsule/dict.v4). */
/* The entry flags a `header` may be given (capsules/v4/sys/dict.f18). */
static v4_cell flag_of(const char *s)
{
if (strcmp(s, "immediate") == 0) return 1;
@@ -66,7 +66,8 @@ static int is_reserved(const char *s)
|| strcmp(s, "\\") == 0 || strcmp(s, "(") == 0
|| strcmp(s, "FOR") == 0 || strcmp(s, "NEXT") == 0 || strcmp(s, "UNEXT") == 0
|| strcmp(s, "header") == 0 || strcmp(s, "constant") == 0
|| strcmp(s, "#,") == 0 || strcmp(s, "\",") == 0 || flag_of(s) != 0;
|| strcmp(s, "#,") == 0 || strcmp(s, "\",") == 0 || strcmp(s, "set") == 0 || strcmp(s, "here") == 0
|| strcmp(s, "store") == 0 || strcmp(s, "start") == 0 || flag_of(s) != 0;
}
static int is_label_def(const char *s)
@@ -189,7 +190,7 @@ static void lay_name(v4_text *t, const char *name)
}
}
/* `header NAME`: a dictionary entry for NAME, as capsule/dict.v4 lays one
/* `header NAME`: a dictionary entry for NAME, as capsules/v4/sys/dict.f18 lays one
* out, in front of the word the next `:` starts:
* the name: its count byte, then its characters, four bytes to a cell,
* zero-padded to a whole cell
@@ -366,12 +367,14 @@ static void constant_directive(v4_text *t, reader *r)
define(t, name, KIND_CONST, v);
}
/* A VALUE in a directive: a number, a constant, CONST+N, or &NAME of a word
* already defined. 1 and its value, or 0 having failed. */
/* A VALUE in a directive: a number, a constant, a set variable, CONST+N,
* here, or &NAME of a word already defined. 1 and its value, or 0 having
* failed. */
static int value_of(v4_text *t, const char *tok, v4_cell *out)
{
const v4_text_symbol *s;
int big;
if (strcmp(tok, "here") == 0) { *out = v4_asm_label(&t->as); return 1; }
if (number_of(tok, out, &big)) {
if (big) { fail(t, "number does not fit a cell", tok); return 0; }
return 1;
@@ -383,7 +386,7 @@ static int value_of(v4_text *t, const char *tok, v4_cell *out)
return 0;
}
s = find(t, tok);
if (s && s->kind == KIND_CONST) { *out = s->value; return 1; }
if (s && (s->kind == KIND_CONST || s->kind == KIND_SET)) { *out = s->value; return 1; }
if (!s) {
const char *plus = strrchr(tok, '+');
if (plus && plus != tok && plus[1] != 0) {
@@ -428,6 +431,51 @@ static void string_directive(v4_text *t, reader *r)
check_asm(t, tok);
}
/* `set NAME VALUE`: an assembler variable, set again if it is one already. */
static void set_directive(v4_text *t, reader *r)
{
char name[V4_TEXT_MAX_TOKEN + 1u], tok[V4_TEXT_MAX_TOKEN + 1u];
v4_cell v;
v4_text_symbol *s;
if (r->depth != 1) { fail(t, "not allowed in a macro", "set"); return; }
if (!next_token(t, r, name)) { if (!t->failed) fail(t, "set without a name", NULL); return; }
if (!next_token(t, r, tok)) { if (!t->failed) fail(t, "set without a value", name); return; }
if (!value_of(t, tok, &v)) return;
s = (v4_text_symbol *)find(t, name);
if (s && s->kind == KIND_SET) { s->value = v; return; }
define(t, name, KIND_SET, v);
}
/* `store ADDR VALUE`: a word of RAM is given VALUE. */
static void store_directive(v4_text *t, reader *r)
{
char tok[V4_TEXT_MAX_TOKEN + 1u];
v4_cell addr, v;
if (r->depth != 1) { fail(t, "not allowed in a macro", "store"); return; }
if (!next_token(t, r, tok)) { if (!t->failed) fail(t, "store without an address", NULL); return; }
if (!value_of(t, tok, &addr)) return;
if (!next_token(t, r, tok)) { if (!t->failed) fail(t, "store without a value", NULL); return; }
if (!value_of(t, tok, &v)) return;
if (addr < 0 || (v4_ucell)addr >= V4_NODE_WORDS) { fail(t, "address out of range", tok); return; }
v4_node_store(t->as.n, addr, v);
}
/* `start NAME`: the text has ended; NAME is where the system starts. */
static void start_directive(v4_text *t, reader *r)
{
char name[V4_TEXT_MAX_TOKEN + 1u];
const v4_text_symbol *s;
if (r->depth != 1) { fail(t, "not allowed in a macro", "start"); return; }
if (!next_token(t, r, name)) { if (!t->failed) fail(t, "start without a name", NULL); return; }
if (!v4_text_finish(t)) return;
s = find(t, name);
if (!s || s->kind != KIND_WORD) { fail(t, "start of something not a word", name); return; }
t->start = s->value;
}
static void one_token(v4_text *t, reader *r, const char *tok)
{
const v4_text_symbol *s;
@@ -435,6 +483,7 @@ static void one_token(v4_text *t, reader *r, const char *tok)
v4_cell v;
int op, big;
if (t->start >= 0) { fail(t, "text after start", tok); return; }
if (strcmp(tok, "header") == 0) { header(t, r); return; }
if (t->header_pending) {
v4_cell f = flag_of(tok);
@@ -454,6 +503,10 @@ static void one_token(v4_text *t, reader *r, const char *tok)
if (strcmp(tok, "constant") == 0) { constant_directive(t, r); return; }
if (strcmp(tok, "#,") == 0) { cell_directive(t, r); return; }
if (strcmp(tok, "\",") == 0) { string_directive(t, r); return; }
if (strcmp(tok, "set") == 0) { set_directive(t, r); return; }
if (strcmp(tok, "store") == 0) { store_directive(t, r); return; }
if (strcmp(tok, "start") == 0) { start_directive(t, r); return; }
if (strcmp(tok, "here") == 0) { fail(t, "here is only a value", NULL); return; }
if (strcmp(tok, "endmacro") == 0) { fail(t, "endmacro without macro", NULL); return; }
if (is_label_def(tok)) {
@@ -536,7 +589,7 @@ static void one_token(v4_text *t, reader *r, const char *tok)
check_asm(t, tok);
return;
}
if (s && s->kind == KIND_CONST) {
if (s && (s->kind == KIND_CONST || s->kind == KIND_SET)) {
v4_asm_lit(as, s->value);
check_asm(t, tok);
return;
@@ -572,6 +625,7 @@ void v4_text_begin(v4_text *t, v4_node *n, v4_cell origin)
t->failed = 0;
t->message[0] = 0;
t->latest = 0;
t->start = -1;
t->header_pending = 0;
}
@@ -654,6 +708,19 @@ v4_cell v4_text_latest(const v4_text *t)
return t->latest;
}
int v4_text_value(const v4_text *t, const char *name, v4_cell *value)
{
const v4_text_symbol *s = find(t, name);
if (!s || (s->kind != KIND_CONST && s->kind != KIND_SET)) return 0;
*value = s->value;
return 1;
}
v4_cell v4_text_start(const v4_text *t)
{
return t->start;
}
v4_cell v4_text_here(v4_text *t)
{
return v4_asm_label(&t->as);
v4/system/boot.c
+167 -72
View File
@@ -1,4 +1,5 @@
/* boot.c -- the nucleus, then its capsules, then the prompt. See boot.h.
/* boot.c -- the machine's ROM assembles the system, then its capsules, then
* the prompt. See boot.h.
*
* Nothing here uses the C library: the bare-metal kernel links this file.
* It is not part of the engine (v4/src): it needs the capsule directory,
@@ -311,25 +312,19 @@ static void post_say(void *self, const char *text, unsigned len)
/* ---- one capsule --------------------------------------------------------- */
static void say_where(const v4_boot *b, const char *name, uint32_t block, uint32_t line)
{
say(b, "\nV4: capsule "); say(b, name);
say(b, " block "); say_dec(b, block);
say(b, " line "); say_dec(b, line);
}
static int load_capsule(const v4_boot *b, const char *name)
/* The capsule `name`: found, its hash checked, its signature verified -- one
* that does not verify is refused, a missing one is only reported. Its
* payload, or NULL with what was wrong said. */
static const uint8_t *open_capsule(const v4_boot *b, const char *name, const CapsuleDesc **found)
{
const CapsuleDirHeader *dir = capsule_get_directory();
const CapsuleDesc *descs = capsule_get_descriptors();
const CapsuleNameEntry *names = capsule_get_names();
const uint8_t *arena = capsule_get_arena();
const CapsuleDesc *cap;
const uint8_t *p, *end;
const uint8_t *p;
CapsuleValidateResult vr;
CapsuleSigResult sr;
uint32_t block = 0, line = 0;
int in_block = 0;
cap = capsule_find_by_name(dir, descs, names, name);
if (!cap) { say(b, "V4: capsule "); say(b, name); say(b, " is not in this binary\n"); return 0; }
@@ -348,6 +343,27 @@ static int load_capsule(const v4_boot *b, const char *name)
p = capsule_get_payload(cap, arena);
if (!p) { say(b, "V4: capsule "); say(b, name); say(b, " has no payload\n"); return 0; }
*found = cap;
return p;
}
static void say_where(const v4_boot *b, const char *name, uint32_t block, uint32_t line)
{
say(b, "\nV4: capsule "); say(b, name);
say(b, " block "); say_dec(b, block);
say(b, " line "); say_dec(b, line);
}
static int load_capsule(const v4_boot *b, const char *name)
{
const CapsuleDesc *cap;
const uint8_t *p, *end;
uint32_t block = 0, line = 0;
int in_block = 0;
p = open_capsule(b, name, &cap);
if (!p) return 0;
end = p + cap->length;
while (p < end) {
@@ -391,78 +407,157 @@ static int load_capsule(const v4_boot *b, const char *name)
return 1;
}
/* ---- the nucleus ----------------------------------------------------------- */
/* ---- the system: the machine's ROM assembles it ----------------------------- */
/* The nucleus is a capsule of F18 code (v4/include/v4/capsule.h): the words
* themselves, to be written to the port of a node that has nothing in it.
* The boot is that node's neighbour. It finds the capsule, checks its hash
* and its signature as it does any capsule's, and gives the node a word
* each time it reads its port, until the node has taken them all and is
* where the nucleus waits to be handed a line. */
#define NUCLEUS_NAME_(bits) "v4:nucleus-" #bits ".f18"
#define NUCLEUS_NAME__(bits) NUCLEUS_NAME_(bits)
#define NUCLEUS_NAME NUCLEUS_NAME__(V4_CELL_BITS)
#define CELL_BYTES (V4_CELL_BITS / 8)
/* The ROM (docs/v4.0.0/MACHINE.md section 2): the machine's one binary,
* built by v4/tools/mkrom.c for this cell width. The machine starts at its
* entry 12, (ROM) (capsules/v4/rom/main.f18), which reads the system's
* source from the console, assembles it into RAM and, at the source's
* `start`, runs it. */
#if V4_CELL_BITS == 64
extern const v4_cell v4_rom_64[];
extern const unsigned v4_rom_64_words;
#define BOOT_ROM v4_rom_64
#define BOOT_ROM_WORDS v4_rom_64_words
#else
extern const v4_cell v4_rom_32[];
extern const unsigned v4_rom_32_words;
#define BOOT_ROM v4_rom_32
#define BOOT_ROM_WORDS v4_rom_32_words
#endif
#define ROM_START 12u /* the entry where the machine starts */
#define ROM_STEP_LIMIT 400000000ULL /* instruction words the ROM may take: it takes about 16 million */
#define EOT 4 /* the end of the source: the ROM's (KEY) sees no more */
static int load_nucleus(const v4_boot *b)
/* The system's source, in the order the ROM reads it: the memory map, then
* the system, then its end -- the state it is switched on in, and `start`.
* capsules/v4/sys; each blob is a capsule like any other. */
#define MAP_NAME_(bits) "v4:sys:map-" #bits ".f18"
#define MAP_NAME__(bits) MAP_NAME_(bits)
static const char *const system_blobs[] = {
MAP_NAME__(V4_CELL_BITS),
"v4:sys:core.f18", "v4:sys:input.f18", "v4:sys:dict.f18", "v4:sys:codegen.f18", "v4:sys:compile.f18",
"v4:sys:quit.f18", "v4:sys:forth.f18", "v4:sys:numout.f18", "v4:sys:words.f18", "v4:sys:system.f18",
"v4:sys:qmath.f18", "v4:sys:blocks.f18", "v4:sys:log.f18", "v4:sys:acl.f18",
"v4:sys:end.f18",
};
#define SYSTEM_BLOBS (sizeof system_blobs / sizeof system_blobs[0])
/* What the ROM's error codes mean (v4/tests/host_map.h, ROM_ERR_*): the ROM
* stops with the code, and the loader, which owns the console, says it. */
static const char *const rom_errors[] = {
"", "name too long", "comment not closed", "cannot be used as a name", "already defined",
"too many names", "does not fit: memory is full, or a branch cannot reach", "not an opcode the packer takes there",
"not allowed in a macro", "macro without endmacro, or endmacro without macro",
"label already defined in this word", "too many labels in one word",
"FOR nested too deep, NEXT or UNEXT without FOR, or FOR without NEXT",
"FOR ... UNEXT must fit one instruction word and hold no literal", "not something to branch to",
"never defined", "number does not fit a cell", "& needs a word that is already defined",
"write the number, not @p", "a name, a target, a value or a string is missing", "macros nested too deep",
"too many unresolved branches", "not a value", "the source ended with no start", "start of something not a word",
};
#define ROM_ERRORS (sizeof rom_errors / sizeof rom_errors[0])
/* FNV-1a over the ROM, a cell at a time, low byte first, as the dictionary
* hash is (image.c). */
static uint64_t rom_hash(void)
{
const CapsuleDirHeader *dir = capsule_get_directory();
const CapsuleDesc *descs = capsule_get_descriptors();
const CapsuleNameEntry *names = capsule_get_names();
const uint8_t *arena = capsule_get_arena();
const CapsuleDesc *cap;
const uint8_t *p;
CapsuleValidateResult vr;
CapsuleSigResult sr;
v4_node *n = b->n;
uint64_t words, at = 0, steps = 0;
uint64_t h = 0xcbf29ce484222325ULL;
unsigned w, i;
for (w = 0; w < BOOT_ROM_WORDS; w++)
for (i = 0; i < V4_CELL_BITS / 8; i++) {
h ^= (uint64_t)(((v4_ucell)BOOT_ROM[w] >> (8 * i)) & 0xFFu);
h *= 0x00000100000001b3ULL;
}
return h;
}
cap = capsule_find_by_name(dir, descs, names, NUCLEUS_NAME);
if (!cap) { say(b, "V4: capsule " NUCLEUS_NAME " is not in this binary\n"); return 0; }
vr = capsule_validate(cap, arena, dir->arena_size, 1);
if (vr != CAPSULE_VALID) {
say(b, "V4: capsule " NUCLEUS_NAME ": "); say(b, capsule_validate_result_str(vr)); say(b, "\n");
/* The machine starts in its ROM, and the boot is its console: it feeds the
* system's source to the console a blob at a time, each found and checked
* as any capsule is, with a new line after each, and then EOT, until the
* ROM has assembled the system and started it. Then the node is where the
* system waits for a message, and its host reads from the image record
* what only the system knows (v4_image_from_node). If the ROM stops on an
* error, the blob and line are said, and what the error is. */
static int load_system(const v4_boot *b)
{
static const uint8_t *payload[SYSTEM_BLOBS];
static uint32_t length[SYSTEM_BLOBS], first_line[SYSTEM_BLOBS];
static const char newline = '\n', eot = EOT;
v4_node *n = b->n;
uint64_t steps = 0;
uint32_t lines = 0, at = 0;
unsigned i, blob = 0;
int fed_all = 0;
for (i = 0; i < SYSTEM_BLOBS; i++) {
const CapsuleDesc *cap;
uint32_t k;
payload[i] = open_capsule(b, system_blobs[i], &cap);
if (!payload[i]) return 0;
length[i] = (uint32_t)cap->length;
first_line[i] = lines;
for (k = 0; k < length[i]; k++) if (payload[i][k] == '\n') lines++;
lines++; /* the new line after it */
say(b, "PARITY:V4_F18 name="); say(b, system_blobs[i]);
say(b, " capsule_hash="); say_hex(b, cap->content_hash);
say(b, "\n");
}
v4_node_rom_attach(n, BOOT_ROM, BOOT_ROM_WORDS);
n->p = V4_ROM_BASE + (v4_cell)ROM_START;
while (n->p >= V4_ROM_BASE) {
/* the console is given more of the source whenever it has taken
* all it had */
if (!fed_all && n->input_pos == n->input_len) {
if (blob < SYSTEM_BLOBS && at < length[blob]) {
at += v4_node_console_feed(n, payload[blob] + at, length[blob] - at);
} else if (blob < SYSTEM_BLOBS) {
if (v4_node_console_feed(n, &newline, 1)) { blob++; at = 0; }
} else if (v4_node_console_feed(n, &eot, 1)) {
fed_all = 1;
}
}
(void)v4_exec_step_word(n, b->es, b->h);
if (n->stopped || ++steps > ROM_STEP_LIMIT) {
say(b, "V4: the machine's ROM did not assemble the system\n");
return 0;
}
if ((steps & 1023u) == 0 && n->mem[b->im->rom_failed] != 0) {
v4_cell code = n->mem[b->im->rom_failed];
uint32_t line = (uint32_t)n->mem[b->im->rom_errline];
for (i = SYSTEM_BLOBS; i-- > 1 && first_line[i] > line; ) { }
say(b, "V4: "); say(b, system_blobs[i]); say(b, " line "); say_dec(b, line - first_line[i] + 1u); say(b, ": ");
say(b, code > 0 && (unsigned)code < ROM_ERRORS ? rom_errors[code] : "an error the ROM has no words for");
say(b, "\n");
return 0;
}
}
say(b, "PARITY:V4_ROM words="); say_dec(b, BOOT_ROM_WORDS);
say(b, " rom_hash="); say_hex(b, rom_hash());
say(b, " instructions="); say_dec(b, (uint32_t)b->es->anticlock);
say(b, "\n");
if (!v4_image_from_node(n, b->im) || n->p != b->im->idle) {
say(b, "V4: the system the ROM assembled has no image record, or did not start where it says it waits\n");
return 0;
}
sr = capsule_verify_signature(descs, names, capsule_get_signatures(), arena, dir->desc_count, (int)(cap - descs));
if (sr != CAPSULE_SIG_OK) {
say(b, "V4: capsule " NUCLEUS_NAME " signature: "); say(b, capsule_sig_result_str(sr)); say(b, "\n");
if (sr == CAPSULE_SIG_INVALID) return 0;
}
p = capsule_get_payload(cap, arena);
if (!p || cap->length % CELL_BYTES != 0) { say(b, "V4: capsule " NUCLEUS_NAME " is not whole words\n"); return 0; }
words = cap->length / CELL_BYTES;
v4_node_fault_attach(n, b->im->fault_table);
/* until it has taken every word and is where the nucleus waits for a
* message: asleep, no message having come */
/* until it is where the system waits for a message: asleep, no message
* having come */
for (;;) {
if (!boot_step(b)) {
if (at >= words && n->do_op == 8) break;
say(b, "V4: the node did not take the nucleus in\n");
if (n->do_op == 8) break;
say(b, "V4: the system did not come to where it waits\n");
return 0;
}
if (n->stopped || n->asking || ++steps > STEP_LIMIT) {
say(b, "V4: the node did not take the nucleus in\n");
say(b, "V4: the system did not come to where it waits\n");
return 0;
}
if (n->reading && !n->given) {
v4_ucell word = 0;
unsigned i;
if (at >= words) {
say(b, "V4: the node wants more than the nucleus holds\n");
return 0;
}
for (i = 0; i < CELL_BYTES; i++) word |= (v4_ucell)p[at * CELL_BYTES + i] << (8 * i);
v4_node_port_give(n, 0, (v4_cell)word);
at++;
}
}
say(b, "PARITY:V4_NUCLEUS name=" NUCLEUS_NAME);
say(b, " capsule_id="); say_hex(b, cap->capsule_id);
say(b, " capsule_hash="); say_hex(b, cap->content_hash);
say(b, " words="); say_dec(b, word_count(n, b->im));
say(b, "\n");
return 1;
}
@@ -472,15 +567,15 @@ int v4_boot_run(const v4_boot *b)
{
unsigned i;
/* a node is born with nothing in it, and is sent the nucleus */
/* a node is born with nothing in it, and its ROM assembles the system */
if (!v4_image_born(b->n, b->es, b->h, b->im)) {
say(b, "V4: the nucleus is not for this build of the engine\nPARITY:FAIL\nPOST: FAILED\n");
say(b, "V4: the memory map is not for this build of the engine\nPARITY:FAIL\nPOST: FAILED\n");
return 0;
}
/* its console's wire, with nothing on it */
v4_wire_reset(TO_NODE); v4_wire_reset(FROM_NODE);
v4_blocks_init(&boot_blocks, b->im->block_window);
if (!load_nucleus(b)) { say(b, "PARITY:FAIL\nPOST: FAILED\n"); return 0; }
if (!load_system(b)) { say(b, "PARITY:FAIL\nPOST: FAILED\n"); return 0; }
/* the kernel's words, before any capsule that might use one */
for (i = 0; i < b->word_count; i++) {
v4/tests/host_map.h
+20 -14
View File
@@ -5,7 +5,7 @@
* one. Every test_host_*.c uses this one, so that the capsule's variables
* and buffers are in the same place in all of them:
*
* 16 .. the capsule's code, assembled from capsule/ *.v4
* 16 .. the capsule's code, assembled from capsules/v4/sys/ *.f18
* DICT_W .. DICT_END_W dictionary space for what is defined at run time
* top of memory buffers, then variables, as below
*/
@@ -34,13 +34,13 @@
#define RSTACK_REG (TOP - 16) /* RSTACK-DEPTH */
/* each capsule file's scratch cells */
#define PVARS (TOP - 24) /* (P): input.v4, 8 cells */
#define DVARS (TOP - 32) /* (D): dict.v4, 5 cells */
#define CGVARS (TOP - 48) /* (CG): codegen.v4, 14 cells */
#define CVARS (TOP - 62) /* (C): compile.v4, 10 cells */
#define FVARS (TOP - 105) /* (F): forth.v4, 7 cells */
#define PVARS (TOP - 24) /* (P): input.f18, 8 cells */
#define DVARS (TOP - 32) /* (D): dict.f18, 5 cells */
#define CGVARS (TOP - 48) /* (CG): codegen.f18, 14 cells */
#define CVARS (TOP - 62) /* (C): compile.f18, 10 cells */
#define FVARS (TOP - 105) /* (F): forth.f18, 7 cells */
#define SVARS (TOP - 540 - (v4_cell)V4_DATA_DEPTH) /* (S): where PICK and ROLL set stack values aside, one cell for each cell of the stack */
#define WVARS (TOP - 99) /* (W): numout.v4, 3 cells */
#define WVARS (TOP - 99) /* (W): numout.f18, 3 cells */
#define CONTEXT (TOP - 64) /* the vocabulary names are looked up in */
#define CURRENT (TOP - 63) /* the vocabulary new words go into */
#define VOC_LINK (TOP - 50) /* the newest vocabulary */
@@ -57,14 +57,14 @@
#define SBUF_W (TOP - 540) /* 64 cells for the tests' own strings */
#define HBUF_W (SVARS - 16) /* the hold buffer: 16 cells = 64 bytes */
#define HEND ((HBUF_W + 16) * 4)
#define XVARS (HBUF_W - 4) /* (X): words.v4, 4 cells */
#define XVARS (HBUF_W - 4) /* (X): words.f18, 4 cells */
#define QBASE (XVARS - 40) /* the Q words' and DUMP's scratch cells, 39 in all */
#define BVARS (QBASE - 16) /* blocks.v4: 6 cells not used now, then SCR BLK (SRC) (SRC-HOOK) */
#define BVARS (QBASE - 16) /* blocks.f18: 6 cells not used now, then SCR BLK (SRC) (SRC-HOOK) */
#define SCR (BVARS + 6)
#define BLK (BVARS + 7)
#define SRC (BVARS + 8)
#define SRC_HOOK (BVARS + 9)
#define QUIET (BUF0_W - 10) /* 1 while the node does something that is no text's doing: an error then is not told (quit.v4, (RAISED)) */
#define QUIET (BUF0_W - 10) /* 1 while the node does something that is no text's doing: an error then is not told (quit.f18, (RAISED)) */
#define REFUSED (BUF0_W - 7) /* how many of this node's messages it has been told were refused */
#define ACL_HOOK (BUF0_W - 6) /* the xt of the access control recheck word, or 0 */
#define LINE_STATUS (BUF0_W - 9) /* how the last line ended: 0 QUIT, 1 completed, 2 an error */
@@ -76,7 +76,7 @@
#define PRINT_TO (BUF0_W - 20) /* where what the text being served prints is to go: the node, */
#define PRINT_PORT (BUF0_W - 33) /* and the port, by its number, that leads there */
#define DONE_PORT (BUF0_W - 34) /* the port, by its number, that leads back to whoever sent the text being served */
/* WHOLE MESSAGES (MESH.md 7d.4; core.v4). A node keeps no message but the one it is doing: these are what it
/* WHOLE MESSAGES (MESH.md 7d.4; core.f18). A node keeps no message but the one it is doing: these are what it
* builds one in and looks at one with, and where it has got to in going through its wires. */
#define WIRE (PORT + (v4_cell)V4_PORT_WIRE) /* the six addresses after the ports (node.h): the wire an operation is about, */
#define WIRE_A (PORT + (v4_cell)V4_PORT_A) /* what it needs, */
@@ -235,7 +235,7 @@
typedef char host_map_ports_fit[(PORT >= OUT_W + OUT_CELLS && PORT + (v4_cell)V4_PORT_HAVE < OUT_HDR) ? 1 : -1];
/* Nothing printed: a node's variable for it, as at switch-on. */
#define HOST_MESSAGES_EMPTY(n) do { (n)->mem[OUT_PTR] = OUT_W; } while (0)
#define QVARS (BUF0_W - 4) /* (Q): quit.v4, system.v4 and blocks.v4, 4 cells */
#define QVARS (BUF0_W - 4) /* (Q): quit.f18, system.f18 and blocks.f18, 4 cells */
#define WBUF (WBUF_W * 4)
#define TIB (TIB_W * 4)
#define PAD (PAD_W * 4)
@@ -388,19 +388,25 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
unsigned i;
v4_node_reset(n);
HOST_MESSAGES_EMPTY(n); /* nothing has been printed and no message waits (core.v4) */
HOST_MESSAGES_EMPTY(n); /* nothing has been printed and no message waits (core.f18) */
v4_text_begin(tx, n, 16);
#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);
for (i = 0; i < count; i++) {
snprintf(path, sizeof path, "%s/%s", V4_CAPSULE_DIR, files[i]);
snprintf(path, sizeof path, "%s/%s", V4_SYS_DIR, files[i]);
if (!v4_text_assemble_file(tx, path)) {
printf(" %s does not assemble: %s\n", files[i], v4_text_error(tx));
return 0;
}
}
/* the newest entry the source laid down (its HDR-LINK) is the
* assembler's latest: a `header` in a test's own text links to it */
{
v4_cell newest;
if (v4_text_value(tx, "HDR-LINK", &newest)) tx->latest = newest;
}
/* one vocabulary, FORTH, whose head cell is LATEST */
n->mem[CONTEXT] = LATEST;
n->mem[CURRENT] = LATEST;
v4/tests/rom_harness.h
+62
View File
@@ -13,6 +13,7 @@
#include "v4/testcode.h"
#include "host_map.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#if V4_CELL_BITS == 64
@@ -84,9 +85,13 @@ static int rom_in(const v4_node *n, const char *name)
return (long)n->p >= start && (long)n->p < next;
}
static char *rom_system_text(size_t *len);
static int rom_build_system(v4_node *n, long *words);
/* Reset `n`, attach the ROM and the console's receive registers. */
static void rom_boot(v4_node *n)
{
(void)rom_build_system;
(void)host_load; /* host_map.h's loader is not used here */
(void)host_branch_slots;
(void)rom_call; /* not every test uses every helper */
@@ -99,4 +104,61 @@ static void rom_boot(v4_node *n)
v4_node_console_input_attach(n, CONSOLE_RX, CONSOLE_ST);
}
/* THE SYSTEM, AS THE MACHINE BUILDS IT (MACHINE.md section 6, step 1). The
* system's source, capsules/v4/sys (V4_SYS_DIR): the map, the fourteen and
* the end, each followed by a new line, then EOT -- what v4/system/boot.c
* feeds the console. rom_system_text gives it whole, *len its length;
* rom_build_system has `n`, booted with its ROM, assemble it, and runs it to
* its start: 1 if it started, with *words the instruction words it took. */
static const char *const rom_system_files[] = { "core", "input", "dict", "codegen", "compile", "quit", "forth",
"numout", "words", "system", "qmath", "blocks", "log", "acl" };
static char *rom_system_text(size_t *len)
{
size_t total = 0, cap = 1u << 20;
char *text = malloc(cap);
unsigned i;
if (!text) return NULL;
for (i = 0; i < 16; i++) {
char path[512];
FILE *f;
long n;
if (i == 0) snprintf(path, sizeof path, "%s/map-%d.f18", V4_SYS_DIR, V4_CELL_BITS);
else if (i <= 14) snprintf(path, sizeof path, "%s/%s.f18", V4_SYS_DIR, rom_system_files[i - 1]);
else snprintf(path, sizeof path, "%s/end.f18", V4_SYS_DIR);
f = fopen(path, "rb");
if (!f) { printf(" cannot read %s\n", path); free(text); return NULL; }
fseek(f, 0, SEEK_END); n = ftell(f); fseek(f, 0, SEEK_SET);
if (n < 0 || total + (size_t)n + 2 > cap || fread(text + total, 1, (size_t)n, f) != (size_t)n) {
fclose(f); free(text); return NULL;
}
fclose(f);
total += (size_t)n;
text[total++] = '\n'; /* a blob that does not end with a new line still ends a token */
}
text[total++] = 4; /* EOT */
*len = total;
return text;
}
static int rom_build_system(v4_node *n, long *words)
{
size_t total, fed = 0;
char *text = rom_system_text(&total);
long w = 0;
if (!text) return 0;
rom_boot(n);
v4_node_stack_regs_attach(n, DSTACK_REG, RSTACK_REG);
n->p = V4_ROM_BASE + 12; /* entry 12, (ROM): where the machine starts */
while (n->p >= V4_ROM_BASE && w < 400000000L && !n->stopped) {
if (fed < total && n->input_pos == n->input_len) fed += v4_node_console_feed(n, text + fed, (unsigned)(total - fed));
(void)v4_exec_step_word(n, &rom_es, &rom_h);
w++;
if (w % 1000 == 0 && n->mem[ROM_FAILED] != 0) break;
}
free(text);
if (words) *words = w;
return n->p < V4_ROM_BASE && n->mem[ROM_FAILED] == 0;
}
#endif /* V4_TESTS_ROM_HARNESS_H */
v4/tests/test_host_codegen.c
+3 -3
View File
@@ -1,6 +1,6 @@
/* test_host_codegen.c -- the code generator, executed on the host node.
*
* capsule/codegen.v4 packs opcodes, literals and branches into instruction
* capsules/v4/sys/codegen.f18 packs opcodes, literals and branches into instruction
* words at HERE; it is what the compiling words will be built on. It is the
* third thing in this tree that does that job -- after the slot packer in C
* (asm.h) and the text assembler on top of it (text.h) -- and the first that
@@ -107,7 +107,7 @@ static int lay_by_text(void)
return v4_text_assemble(&rtx, src) && v4_text_finish(&rtx);
}
/* By the code generator, on `n`: one call to a word of codegen.v4 for each
/* By the code generator, on `n`: one call to a word of codegen.f18 for each
* item, as the compiling words will make them. */
static int lay_by_generator(void)
{
@@ -179,7 +179,7 @@ int main(void)
CHECK(bslots == 3, "at this node size a branch may sit in slots 0 .. 2: %u", bslots);
{
static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18", "codegen.f18" };
CHECK(host_load(&tx, &n, files, 4), "the capsule assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
v4/tests/test_host_compile.c
+2 -2
View File
@@ -1,7 +1,7 @@
/* test_host_compile.c -- the defining and compiling words, executed on the
* host node.
*
* capsule/compile.v4 and capsule/forth.v4 on top of the earlier layers: for
* capsules/v4/sys/compile.f18 and capsules/v4/sys/forth.f18 on top of the earlier layers: for
* the first time FORTH source text goes in and running code comes out. Each
* test hands lines of source to INTERPRET, which defines words with : and ;
* and the rest, runs them, and leaves results on the stack.
@@ -195,7 +195,7 @@ int main(void)
printf("v4 host compiler tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18", "codegen.f18", "compile.f18", "quit.f18", "forth.f18" };
CHECK(host_load(&tx, &n, files, 7), "the capsule assembles");
}
/* two in-line words of the test's own, to exercise the in-liner: one with
v4/tests/test_host_depth.c
+3 -3
View File
@@ -375,15 +375,15 @@ int main(void)
printf("v4 mesh depth tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "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" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18", "codegen.f18", "compile.f18", "quit.f18", "forth.f18",
"numout.f18", "words.f18", "system.f18", "qmath.f18", "blocks.f18", "log.f18", "acl.f18" };
CHECK(host_load(&tx, &nucleus, files, 14), "the nucleus assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
w_idle = v4_text_word(&tx, "(IDLE)");
w_fault = v4_text_word(&tx, "(FAULTS)");
nucleus.mem[DP] = DICT_W * 4; /* the variables, as at switch-on (tools/mkimage.c) */
nucleus.mem[DP] = DICT_W * 4; /* the variables, as at switch-on (capsules/v4/sys/end.f18) */
nucleus.mem[LATEST] = v4_text_latest(&tx);
nucleus.mem[CFP] = CFS_W;
nucleus.mem[BASE] = 10;
v4/tests/test_host_dict.c
+2 -2
View File
@@ -2,7 +2,7 @@
*
* DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND
* and ', and the entry-field words. The definitions are text,
* capsule/dict.v4, on top of core.v4 and input.v4.
* capsules/v4/sys/dict.f18, on top of core.f18 and input.f18.
*
* v4's dictionary is new: v3's was a C structure and its words handed out
* host pointers. What carries over is what the words mean:
@@ -192,7 +192,7 @@ int main(void)
printf("v4 host dictionary tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "core.v4", "input.v4", "dict.v4" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18" };
CHECK(host_load(&tx, &n, files, 3), "the capsule assembles");
}
capsule_latest = v4_text_latest(&tx);
v4/tests/test_host_input.c
+3 -3
View File
@@ -3,7 +3,7 @@
*
* DECOMPOSITION.md 5.9 and 5.15: TIB >IN SPAN SOURCE BL EXPECT QUERY WORD
* ENCLOSE CONVERT NUMBER and the comment words. The definitions are text,
* capsule/core.v4 and capsule/input.v4, assembled here by the text assembler.
* capsules/v4/sys/core.f18 and capsules/v4/sys/input.f18, assembled here by the text assembler.
*
* These are FORTH-79 words and follow the standard (ruled 2026-10-04) where
* v3 did something else:
@@ -211,7 +211,7 @@ int main(void)
printf("v4 host input tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "core.v4", "input.v4" };
static const char *const files[] = { "core.f18", "input.f18" };
CHECK(host_load(&tx, &n, files, 2), "the capsule assembles");
}
/* the in-line names, as words the test can call */
@@ -263,7 +263,7 @@ int main(void)
}
n.mem[BASE] = 10;
CHECK(v4_node_console_feed(&n, "Z", 1) == 1 && run("KEY", 0, 0, 0, 0) && pop() == 'Z' && clean(), "KEY");
/* a node has no console of its own: what it prints is kept to be sent (core.v4) */
/* a node has no console of its own: what it prints is kept to be sent (core.f18) */
n.mem[OUT_PTR] = OUT_W;
CHECK(run("EMIT", 1, 'q', 0, 0) && clean() && n.mem[OUT_PTR] == OUT_W + 1 && n.mem[OUT_W] == 'q', "EMIT");
CHECK(run("EMIT", 1, 0x141, 0, 0) && clean() && n.mem[OUT_PTR] == OUT_W + 2 && n.mem[OUT_W + 1] == 'A', "EMIT prints the low 8 bits");
v4/tests/test_host_mesh.c
+4 -4
View File
@@ -4,7 +4,7 @@
*
* console --1 [10] 2--2 [11] 3--2 [12]
*
* Each node is the nucleus (v4/capsule/ *.v4) and nothing else. They start
* Each node is the nucleus (capsules/v4/sys/ *.f18) and nothing else. They start
* alike, numbered 0 and knowing no way anywhere; everything they come to
* know they are told by text sent from the console, as whoever wires a node
* tells it. The console is a device on a port and speaks whole messages
@@ -343,15 +343,15 @@ int main(void)
printf("v4 mesh tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "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" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18", "codegen.f18", "compile.f18", "quit.f18", "forth.f18",
"numout.f18", "words.f18", "system.f18", "qmath.f18", "blocks.f18", "log.f18", "acl.f18" };
CHECK(host_load(&tx, &nucleus, files, 14), "the nucleus assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
w_idle = v4_text_word(&tx, "(IDLE)");
w_fault = v4_text_word(&tx, "(FAULTS)");
nucleus.mem[DP] = DICT_W * 4; /* the variables, as at switch-on (tools/mkimage.c) */
nucleus.mem[DP] = DICT_W * 4; /* the variables, as at switch-on (capsules/v4/sys/end.f18) */
nucleus.mem[LATEST] = v4_text_latest(&tx);
nucleus.mem[CFP] = CFS_W;
nucleus.mem[BASE] = 10;
v4/tests/test_host_quit.c
+8 -8
View File
@@ -1,6 +1,6 @@
/* test_host_quit.c -- the prompt, executed on the host node.
*
* capsule/quit.v4 on top of the earlier layers: QUIT, ABORT, ABORT" and ." .
* capsules/v4/sys/quit.f18 on top of the earlier layers: QUIT, ABORT, ABORT" and ." .
* For the first time the node is not handed a line: it is started at QUIT and
* left running, characters are fed to its console, and what it prints is
* read back. Nothing here calls INTERPRET or pokes TIB.
@@ -558,7 +558,7 @@ static const transcript script[] = {
{ "2 BASE ! 5 . DECIMAL\n", "UNKNOWN WORD: '5'\n ERROR\nok> ", 1 },
{ ": T 10 0 DO I . LOOP ; T\n", "0 1 2 3 4 5 6 7 8 9 ok\nok> ", 1 },
{ "DEPTH . 1 2 DEPTH . . .\n", "0 2 2 1 ok\nok> ", 1 },
/* qmath.v4: every result printed by Q.PRINT, which shows all sixteen bits of the fraction */
/* qmath.f18: every result printed by Q.PRINT, which shows all sixteen bits of the fraction */
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.SQRT Q.PRINT\n", "1.00000 ok\nok> ", 1 },
{ "1 Q.FROM-INT 1 Q.FROM-INT Q./ Q.LOG Q.ABS Q.PRINT\n", "0.00000 ok\nok> ", 1 },
@@ -697,7 +697,7 @@ static const transcript script[] = {
{ "Q.0 Q.LOG 65 EMIT\n-1 Q.FROM-INT Q.LOG\n", "Argument out of range\n ERROR\nok> Argument out of range\n ERROR\nok> ", 0 },
{ "7 PAD -1 DUMP 65 EMIT\n.S\n", "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 },
{ "PAD 0 DUMP\n", " ok\nok> ", 1 },
/* acl.v4: the fields of an entry, and the check, as v3 */
/* acl.f18: the fields of an entry, and the check, as v3 */
{ ": FOO 65 EMIT ; ' FOO ACL-MODE@ . ' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ .\n' FOO ACL-PINNED? .\n", "0 0 -1 ok\nok> 0 ok\nok> ", 1 },
{ ": FOO 65 EMIT ; 1 ' FOO ACL-MODE! 77 ' FOO ACL-TTL! ' FOO ACL-MODE@ .\n' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n", "1 ok\nok> 77 A76 ok\nok> ", 1 },
{ ": FOO 65 EMIT ; ' FOO ACL-PIN ' FOO ACL-PINNED? . 5 ' FOO ACL-TTL!\n0 ' FOO ACL-ALLOW! 1 ' FOO ACL-MODE!\n' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ . ' FOO ACL-MODE@ .\n",
@@ -720,7 +720,7 @@ static const transcript script[] = {
{ ": IM 65 EMIT ; IMMEDIATE 3 ' IM ACL-TTL! 0 ' IM ACL-ALLOW! : U IM ;\n", "\033[33mWARN: \033[0mACL: denied 'IM'\n ERROR\nok> ", 0 },
{ ": P1 ; : P2 ; VOCABULARY VV VV DEFINITIONS : P3 ; FORTH DEFINITIONS\n9 ' P1 ACL-TTL! 1 ' P2 ACL-MODE! ' P2 ACL-PIN VV 9 ' P3 ACL-TTL!\nACL-INIT-PRIMITIVES ' P1 ACL-TTL@ . ' P2 ACL-MODE@ . ' P3 ACL-TTL@ . FORTH\n",
" ok\nok> ok\nok> 0 1 0 ok\nok> ", 0 },
/* log.v4: v3's lines, colours and all, without its time of day */
/* log.f18: v3's lines, colours and all, without its time of day */
{ "LOG-LEVEL@ . LOG-ERROR . LOG-WARN . LOG-INFO . LOG-TEST . LOG-DEBUG .\n",
"2 0 1 2 3 4 ok\nok> ", 1 },
{ "LOG-INFO\" hello info\"\nLOG-WARN\" careful\"\nLOG-ERROR\" bad\"\nLOG-DEBUG\" dbg\"\nLOG-TEST\" tst\"\n",
@@ -750,7 +750,7 @@ static const transcript script[] = {
"\033[32mINFO: \033[0m\n ok\nok> ", 1 },
{ ": W LOG-ERROR\" e\" LOG-WARN\" w\" LOG-TEST\" t\" ; W 3 LOG-LEVEL! W\n",
"\033[31mERROR: \033[0me\n\033[33mWARN: \033[0mw\n\033[31mERROR: \033[0me\n\033[33mWARN: \033[0mw\n\033[35mTEST: \033[0mt\n ok\nok> ", 1 },
/* blocks.v4 */
/* blocks.f18 */
{ "20 BLOCK 1024 BLANK 65 20 BLOCK C! UPDATE SAVE-BUFFERS 20 BLOCK C@ .\n",
"65 ok\nok> ", 1 },
{ "20 BLOCK 1024 BLANK 20 BLOCK 16 65 FILL UPDATE 20 LIST\nSCR @ .\n",
@@ -789,7 +789,7 @@ static const transcript script[] = {
{ "7 FORGET DUP 65 EMIT\nFORGET NOSUCH\nDUP . .\n", "Protected word\n ERROR\nok> UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> 7 7 ok\nok> ", 0 },
{ ": S3 S\" \" SWAP DROP . S\" ab\" S\" cde\" TYPE TYPE ; S3\n", "0 cdeab ok\nok> ", 0 },
{ ": T3 ['] NOSUCH ;\n['] DUP\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> [']: compile-only\n ERROR\nok> ", 0 },
/* words.v4 */
/* words.f18 */
{ "1 2 3 4 2SWAP . . . .\n", "2 1 4 3 ok\nok> ", 1 },
{ "1 2 3 4 2OVER . . . . . .\n", "2 1 4 3 2 1 ok\nok> ", 1 },
{ "1 2 3 4 5 6 2ROT . . . . . .\n", "2 1 6 5 4 3 ok\nok> ", 1 },
@@ -918,7 +918,7 @@ int main(void)
CHECK(storage_made(), "the chains behind the storage port are made");
{
static const char *const files[] = { "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" };
static const char *const files[] = { "core.f18", "input.f18", "dict.f18", "codegen.f18", "compile.f18", "quit.f18", "forth.f18", "numout.f18", "words.f18", "system.f18", "qmath.f18", "blocks.f18", "log.f18", "acl.f18" };
CHECK(host_load(&tx, &n, files, 14), "the capsule assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
@@ -927,7 +927,7 @@ int main(void)
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
w_idle = v4_text_word(&tx, "(IDLE)");
w_key = v4_text_word(&tx, "KEY");
w_key_end = v4_text_word(&tx, "CR"); /* the word after KEY in core.v4 */
w_key_end = v4_text_word(&tx, "CR"); /* the word after KEY in core.f18 */
w_fault = v4_text_word(&tx, "(FAULTS)");
capsule_latest = v4_text_latest(&tx);
CHECK(w_key_end > w_key && w_key_end - w_key <= 12, "KEY is the few words before CR");
v4/tests/test_host_rom_nucleus.c
+31 -94
View File
@@ -1,13 +1,13 @@
/* test_host_rom_nucleus.c -- the proof: the ROM rebuilds today's nucleus, word for word.
/* test_host_rom_nucleus.c -- the proof: the ROM assembles the system as text.c does, word for word.
*
* Plan Task 8; MACHINE.md section 6, step 1. Node A is built as
* v4/tools/mkimage.c builds the nucleus: text.c assembles v4/capsule/ *.v4,
* then the switch-on state is set in C. Node B is the machine with its ROM,
* fed the system's blobs -- capsules/v4/sys/map-<width>.f18, the fourteen
* .f18 files made from the .v4 ones, and end.f18 -- through the console.
* When the ROM starts the system, every word of B's RAM must be A's, except
* the ROM's own state area and the image record (which A does not have, and
* which must hold A's addresses). It also reports what the assembly cost:
* Plan Task 8 and 9; MACHINE.md section 6, step 1. The system's source is
* capsules/v4/sys: map-<width>.f18, the fourteen .f18 files and end.f18.
* Node A is that source assembled off the node by text.c, the oracle (it
* speaks the ROM's language: constant, set, here, #, ", store, start).
* Node B is the machine with its ROM, fed the same source 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 (which A does not have), and B must
* start where A's start says. It also reports what the assembly cost:
* instructions retired and seconds (Captain Bob: watch the startup cost).
*/
#include "rom_harness.h"
@@ -20,118 +20,55 @@ static int failures = 0, checks = 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 */
/* node A: text.c assembles the system's source, map first and end last */
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;
char path[512];
unsigned i;
v4_node_reset(&a);
v4_text_begin(&tx, &a, ROM_ORIGIN);
for (i = 0; i < 16; i++) {
if (i == 0) snprintf(path, sizeof path, "%s/map-%d.f18", V4_SYS_DIR, V4_CELL_BITS);
else if (i <= 14) snprintf(path, sizeof path, "%s/%s.f18", V4_SYS_DIR, rom_system_files[i - 1]);
else snprintf(path, sizeof path, "%s/end.f18", V4_SYS_DIR);
if (!v4_text_assemble_file(&tx, path)) return 0;
}
return v4_text_start(&tx) >= 0;
}
/* the ROM's own cells, and the image record: not compared */
/* the ROM's own cells: 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;
|| (w >= BUF0_W - 122 && w < BUF0_W - 119);
}
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)");
CHECK(build_a(), "text.c assembles the system's source to its start: %s", v4_text_error(&tx));
idle_a = v4_text_start(&tx);
CHECK(idle_a == v4_text_word(&tx, "(IDLE)"), "the system starts at (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,
CHECK(rom_build_system(&b, &words), "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);
t1 = clock();
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.p == idle_a, "it starts where text.c's start says: %ld, text.c'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");
"the image record holds text.c'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]);
CHECK(0, "RAM word %ld: text.c %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");
v4/tests/test_host_unit.c
+14 -28
View File
@@ -7,8 +7,12 @@
* kernel --0 | / \ | square; the corners across from each
* [13]---[14] other are not wired
*
* Hera is born empty and is given the nucleus through the port her requests
* go to, as the boot gives it (v4/system/boot.c). She is told who she is,
* The host builds the system as the machine does: a node with its ROM
* assembles capsules/v4/sys (MACHINE.md section 6, step 1; tests/
* rom_harness.h). That system, assembled, is the nucleus capsule: a node
* that is born is given assembled code, never the source (Captain Bob,
* 2026-10-15). Hera is born empty and is given it through the port her
* requests go to. She is told who she is,
* given the words that ask for nodes (v4/include/v4/manage.h), FORTH-79,
* POST, and her own capsule, capsules/v4/hera.4th. Then she is told
* `10 UNIT`, and everything after that is hers: she asks for four nodes,
@@ -16,7 +20,7 @@
* joins them and then FORTH-79 and POST a line at a time, and joins them.
*
* What stands in here for the host: the capsules are read from the files
* the build bakes in, and the nucleus is assembled as mkimage assembles it.
* the build bakes in.
*
* STORAGE (MESH.md section 8, acceptance 3). Every node asks its kernel
* for its blocks, on its port 0, and the kernel's block subsystem
@@ -38,14 +42,13 @@
#include <stdlib.h>
#include <string.h>
#include "host_map.h"
#include "rom_harness.h"
static int failures = 0, checks = 0;
#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0)
#define PLACES 10u
static v4_text tx;
static v4_node nucleus; /* the nucleus, assembled: what the capsule of F18 code is written from */
static v4_node nucleus; /* the system, as the ROM assembled it: what the capsule of F18 code is written from */
static v4_cell w_idle, w_fault;
static v4_fabric_node pool[PLACES];
static int pool_used[PLACES];
@@ -369,28 +372,11 @@ int main(void)
return 0;
}
CHECK(storage_made(), "the kernel's blocks are there before any node is");
{
static const char *const files[] = { "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" };
CHECK(host_load(&tx, &nucleus, files, 14), "the nucleus assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
CHECK(rom_build_system(&nucleus, 0), "the host's machine assembles the system with its ROM");
if (failures) { printf(" %d checks, %d failures\n", checks, failures); return 1; }
w_idle = v4_text_word(&tx, "(IDLE)");
w_fault = v4_text_word(&tx, "(FAULTS)");
nucleus.mem[DP] = DICT_W * 4; /* the variables, as at switch-on (tools/mkimage.c) */
nucleus.mem[LATEST] = v4_text_latest(&tx);
nucleus.mem[CFP] = CFS_W;
nucleus.mem[BASE] = 10;
nucleus.mem[FENCE] = DICT_W;
nucleus.mem[BOOT_CELLS] = nucleus.mem[DP];
nucleus.mem[BOOT_CELLS + 1] = nucleus.mem[LATEST];
nucleus.mem[LOG_LEVEL] = 2;
nucleus.mem[CONTEXT] = LATEST;
nucleus.mem[CURRENT] = LATEST;
nucleus.mem[SRC] = TIB;
nucleus.mem[LINE_STATUS] = 1;
HOST_MESSAGES_EMPTY(&nucleus);
w_idle = nucleus.mem[ROM_IMG]; /* the image record (capsules/v4/sys/end.f18) */
w_fault = nucleus.mem[ROM_IMG + 1];
CHECK(nucleus.p == w_idle, "and it has started where it waits");
(void)v4_capsule_write(&nucleus, w_idle, f18_put, 0);
CHECK(f18_count > 1000 && f18_count < sizeof f18 / sizeof f18[0], "the nucleus is a capsule of F18 code: %u cells", f18_count);
memset(&im, 0, sizeof im);
@@ -437,7 +423,7 @@ int main(void)
CHECK(hera->mem[DP] == before[DP] && hera->mem[LATEST] == before[LATEST], "HERE and LATEST are where they were before POST");
for (k = 0; k < here; k++) if (hera->mem[k] != before[k]) { if (first < 0) first = k; changed++; }
/* What differs is the TTL in the entry of each word POST had interpreted: a count of uses left before
* the word's access is checked again, which every use counts down (compile.v4, (ACL?)), as in v3. */
* the word's access is checked again, which every use counts down (compile.f18, (ACL?)), as in v3. */
printf(" after POST and COLD: %ld of the %ld cells below HERE differ from before POST (the first at %ld); dict_hash %s\n",
(long)changed, (long)here, (long)first, v4_image_dict_hash(hera, &im) == hash ? "the same" : "differs");
}
v4/tests/test_text.c
+31 -1
View File
@@ -424,7 +424,7 @@ int main(void)
CHECK(refused(": T &VAR ;", "already defined", 1), "and be a word");
CHECK(refused(": &X 1 ;", "cannot be used as a name", 1), "a name cannot begin with &");
/* headers: a dictionary entry in front of a word (capsule/dict.v4) */
/* headers: a dictionary entry in front of a word (capsules/v4/sys/dict.f18) */
CHECK(ok("header DUP : (DUP) dup + ;"), "a header assembles: %s", v4_text_error(&tx));
{
v4_cell xt = v4_text_word(&tx, "(DUP)");
@@ -521,6 +521,36 @@ int main(void)
"#, and \", are reserved");
}
/* ---- `set`, `here`, `store` and `start`: the rest of the ROM's language ---- */
{
v4_cell v = 0;
CHECK(ok("set V 3 set V 4 #, V") && nb.mem[ORIGIN] == 4 && v4_text_value(&tx, "V", &v) && v == 4,
"a set variable may be set again; the newest value is its value: %s", v4_text_error(&tx));
CHECK(ok("set V 7 : T V ;") && result("T", 0, 0, 0) == 7, "a set variable in code is a literal");
CHECK(ok("constant K 2 set V K+1 #, V") && nb.mem[ORIGIN] == 3, "set takes a VALUE");
CHECK(ok(": T ; set H here #, H set H here #, H") && nb.mem[ORIGIN + 1] == ORIGIN + 1 && nb.mem[ORIGIN + 2] == ORIGIN + 2,
"here is the next word address, the word before ended");
CHECK(ok(": T dup set H here ; #, H") && nb.mem[ORIGIN + 2] == ORIGIN + 1, "here inside a word ends the instruction word");
CHECK(ok("set V 1 #, V+1") == 0, "CONST+N is for constants only");
CHECK(refused("constant K 1 set K 2", "already defined", 1), "set over a constant is refused");
CHECK(refused("set V 1 constant V 2", "already defined", 1), "a constant over a set variable is refused");
CHECK(refused("set V", "set without a value", 1), "set needs a value");
CHECK(refused(": T here ;", "here is only a value", 1), "here alone is not something to assemble");
CHECK(ok("constant A 300 store A 5 store A+1 &T : T ;") == 0, "store's &NAME needs a word already defined");
CHECK(ok(": T ; constant A 300 store A 5 store A+1 &T") && nb.mem[300] == 5 && nb.mem[301] == ORIGIN,
"store puts a VALUE anywhere in RAM");
CHECK(refused("store -1 5", "address out of range", 1), "store outside RAM is refused");
CHECK(refused("store 5", "store without a value", 1), "store needs a value");
CHECK(ok(": A ; : B ; start B") && v4_text_start(&tx) == ORIGIN + 1, "start names the word the system starts at");
CHECK(ok(": A ;") && v4_text_start(&tx) == -1, "no start: -1");
CHECK(refused(": A C ; start A", "never defined", 1), "at start every branch has its target");
CHECK(refused("constant K 1 start K", "start of something not a word", 1), "start of a constant is refused");
CHECK(refused(": A ; start A : B ;", "text after start", 1), "nothing comes after start");
CHECK(refused(": set ;", "cannot be used as a name", 1) && refused(": here ;", "cannot be used as a name", 1)
&& refused(": store ;", "cannot be used as a name", 1) && refused(": start ;", "cannot be used as a name", 1),
"set, here, store and start are reserved");
}
CHECK(v4_node_guards_intact(&na) && v4_node_guards_intact(&nb), "guards intact");
printf(" %d checks, %d failures\n", checks, failures);
v4/tools/hosted.c
+7 -5
View File
@@ -1,7 +1,7 @@
/* hosted.c -- StarForth v4 as a Linux program: the nucleus image on the
* golden model, its capsules loaded as the system comes up (v4/include/v4/
* boot.h, the same boot the bare-metal kernel runs), the console on stdin
* and stdout.
/* hosted.c -- StarForth v4 as a Linux program: the golden model with its
* ROM, which assembles the system from its source, and its capsules loaded
* as the system comes up (v4/include/v4/boot.h, the same boot the
* bare-metal kernel runs), the console on stdin and stdout.
*
* It runs until its input ends. Blocks are kept in memory and are gone
* when it stops.
@@ -14,6 +14,7 @@
static v4_node n;
static v4_exec_state es;
static v4_heat h;
static v4_image im;
/* STORAGE. The node asks its kernel for its blocks (v4/blocks.h), and the
* kernel's block subsystem has them (docs/v4.0.0/MESH.md section 8). A
@@ -58,7 +59,8 @@ int main(void)
static char line[1026];
v4_boot boot;
boot.n = &n; boot.es = &es; boot.h = &h; boot.im = &v4_capsule_image;
im = v4_map_image;
boot.n = &n; boot.es = &es; boot.h = &h; boot.im = &im;
boot.out = console_out; boot.key = console_key;
boot.words = kernel_words; boot.word_count = sizeof kernel_words / sizeof kernel_words[0]; boot.serve = serve;
sf_time_init();
v4/tools/mkimage.c
-122
View File
@@ -1,122 +0,0 @@
/* mkimage.c -- build the capsule image (include/v4/image.h).
*
* mkimage DESCRIPTION.c CAPSULE.f18
*
* Runs on the build machine. It assembles capsule/ *.v4 -- the nucleus,
* docs/v4.0.0/NUCLEUS.md -- onto a host node with the memory map of
* tests/host_map.h. It runs nothing. It writes the nucleus as a capsule
* of F18 code (v4/include/v4/capsule.h) -- what is sent to an empty node's
* port to make it a StarForth node -- and the addresses a host needs, as a
* C file (v4/include/v4/image.h). No FORTH source is compiled here: what
* is not in the nucleus is loaded from capsules when the system boots.
*
* The image is the same on every machine it is built on: nothing in it
* depends on the build machine but the cell width this tool was compiled
* for.
*/
#include "v4/image.h"
#include "v4/capsule.h"
#include "v4/text.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "../tests/host_map.h"
static v4_node n;
static v4_text tx;
static v4_cell w_key, w_key_end;
static void die(const char *what, const char *detail)
{
fprintf(stderr, "mkimage: %s%s%s\n", what, detail ? ": " : "", detail ? detail : "");
exit(1);
}
/* one word of the capsule, to the file */
static void put_word(void *self, v4_cell word)
{
v4_ucell u = (v4_ucell)word;
unsigned i;
for (i = 0; i < V4_CELL_BITS / 8; i++) fputc((int)((u >> (8 * i)) & 0xFFu), (FILE *)self);
}
/* every entry from xt back: no access control fields set */
static void clear_acl(v4_cell xt)
{
for (; xt != 0; xt = n.mem[xt - 1]) n.mem[xt - 3] &= 31;
}
int main(int argc, char **argv)
{
static const char *const files[] = { "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" };
FILE *out;
v4_cell k, idle, faults, voc;
unsigned count = 0;
if (argc != 3) die("usage: mkimage DESCRIPTION.c CAPSULE.f18", NULL);
if (!host_load(&tx, &n, files, (unsigned)(sizeof files / sizeof files[0]))) die("the capsule does not assemble", NULL);
if (!v4_text_finish(&tx)) die("not everything is defined", v4_text_error(&tx));
if (v4_text_here(&tx) >= DICT_W) die("the capsule's code runs into the dictionary space", NULL);
idle = v4_text_word(&tx, "(IDLE)");
faults = v4_text_word(&tx, "(FAULTS)");
w_key = v4_text_word(&tx, "KEY");
w_key_end = v4_text_word(&tx, "CR");
/* the variables, as at switch-on */
n.mem[DP] = DICT_W * 4;
n.mem[LATEST] = v4_text_latest(&tx);
n.mem[STATE] = 0;
n.mem[CFP] = CFS_W;
n.mem[BASE] = 10;
n.mem[FENCE] = DICT_W;
n.mem[LOG_LEVEL] = 2;
n.mem[CONTEXT] = LATEST;
n.mem[CURRENT] = LATEST;
n.mem[SRC] = TIB;
/* The nucleus is the system as COLD finds it: COLD comes back to here,
* and FORGET will not go below it. What the capsules add at boot
* (v4/system/boot.c) is above it. */
n.mem[BOOT_CELLS] = n.mem[DP];
n.mem[BOOT_CELLS + 1] = n.mem[LATEST];
n.mem[FENCE] = (n.mem[DP] + 3) / 4;
/* and nothing of the building is left behind: the terminal is the input,
* no block is in a buffer, no word has an access control field set */
n.mem[NODE_ERROR] = 0;
n.mem[BLK] = 0; n.mem[SCR] = 0; n.mem[SRC] = TIB; n.mem[SRC_HOOK] = 0;
for (k = BVARS; k < BVARS + 6; k++) n.mem[k] = 0;
for (k = BUF0_W; k < BUF0_W + (v4_cell)(V4_BLOCK_SLOTS * V4_BLOCK_CELLS); k++) n.mem[k] = 0;
for (k = TIB_W; k < TIB_W + 260; k++) n.mem[k] = 0;
for (k = WBUF_W; k < WBUF_W + WBUF_CELLS; k++) n.mem[k] = 0;
for (k = PAD_W; k < PAD_W + 21; k++) n.mem[k] = 0;
n.mem[TO_IN] = 0; n.mem[SPAN] = 0;
clear_acl(n.mem[LATEST]);
for (voc = n.mem[VOC_LINK]; voc != 0; voc = n.mem[voc + 1]) clear_acl(n.mem[voc]);
if (!v4_node_guards_intact(&n)) die("the node's guards are damaged", NULL);
n.mem[LINE_STATUS] = 1; /* nothing has ended badly */
HOST_MESSAGES_EMPTY(&n); /* nothing has been printed, no message waits */
/* the nucleus as a capsule of F18 code: the words a neighbour writes to
* an empty node's port, each in V4_CELL_BITS / 8 bytes, low byte first */
out = fopen(argv[2], "wb");
if (!out) die("cannot write", argv[2]);
count = v4_capsule_write(&n, idle, put_word, out);
if (fclose(out) != 0) die("cannot write", argv[2]);
out = fopen(argv[1], "w");
if (!out) die("cannot write", argv[1]);
fprintf(out, "/* Generated by v4/tools/mkimage.c from v4/capsule -- do not edit. */\n#include \"v4/image.h\"\n\n");
fprintf(out, "const v4_image v4_capsule_image = {\n %uu, %uu, %uu, %uu,\n",
(unsigned)V4_CELL_BITS, (unsigned)V4_NODE_WORDS, (unsigned)V4_DATA_RING, (unsigned)V4_RET_RING);
fprintf(out, " %ld,\n %ld, %ld,\n %ld, %ld,\n", (long)idle, (long)faults, (long)PORT, (long)w_key, (long)w_key_end);
fprintf(out, " %ld, %ld, %ld,\n %ld, %ld,\n %ld,\n %ld, %ld,\n %ld, %ld,\n %ld\n};\n", (long)CONSOLE_TX, (long)CONSOLE_RX, (long)CONSOLE_ST,
(long)DSTACK_REG, (long)RSTACK_REG, (long)NODE_ERROR, (long)DP, (long)LATEST,
(long)BOOT_CELLS, (long)FENCE, (long)BUF0_W);
if (fclose(out) != 0) die("cannot write", argv[1]);
fprintf(stderr, "mkimage: a capsule of %u words, dictionary to word %ld, %d-bit cells -> %s, %s\n", count, (long)((n.mem[DP] + 3) / 4), V4_CELL_BITS, argv[2], argv[1]);
return 0;
}
v4/tools/mkmap.c
+20
View File
@@ -2,6 +2,7 @@
*
* mkmap > rom-map-<width>.f18
* mkmap sys > capsules/v4/sys/map-<width>.f18
* mkmap image > v4_map_<width>.c
*
* 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
@@ -33,11 +34,30 @@ static int system_map(void)
return 0;
}
/* `mkmap image`: the system as its host knows it before it is built
* (include/v4/image.h, v4_map_image): what the build was for, the map's
* addresses, and where the image record and the ROM's error are. What only
* the assembled system knows -- where it waits, its fault table, KEY -- is
* -1 here; v4_image_from_node reads it from the image record. */
static int image_description(void)
{
printf("/* Generated by v4/tools/mkmap.c (mkmap image) from v4/tests/host_map.h -- do not edit. */\n");
printf("#include \"v4/image.h\"\n\nconst v4_image v4_map_image = {\n");
printf(" %uu, %uu, %uu, %uu,\n", (unsigned)V4_CELL_BITS, (unsigned)V4_NODE_WORDS, (unsigned)V4_DATA_RING, (unsigned)V4_RET_RING);
printf(" -1,\n -1, %ld,\n -1, -1,\n", (long)PORT);
printf(" %ld, %ld, %ld,\n %ld, %ld,\n %ld,\n %ld, %ld,\n %ld, %ld,\n %ld,\n",
(long)CONSOLE_TX, (long)CONSOLE_RX, (long)CONSOLE_ST, (long)DSTACK_REG, (long)RSTACK_REG,
(long)NODE_ERROR, (long)DP, (long)LATEST, (long)BOOT_CELLS, (long)FENCE, (long)BUF0_W);
printf(" %ld, %ld, %ld\n};\n", (long)ROM_IMG, (long)ROM_FAILED, (long)ROM_ERRLINE);
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();
if (argc == 2 && argv[1][0] == 'i') return image_description();
printf("\\ Generated by v4/tools/mkmap.c from v4/tests/host_map.h -- do not edit.\n");
constant("CONSOLE-RX", (long)CONSOLE_RX);
constant("CONSOLE-STATUS", (long)CONSOLE_ST);
v4/tools/v4tof18.py
-110
View File
@@ -1,110 +0,0 @@
#!/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()