rajames/LithosAnanke
1
1
Fork 0
Code Issues 81 Pull Requests 1 Actions 1 Packages Projects 1 Releases 6 Activity

feat(v4): word accounts at call -- the word ID in the header, the kernel's records, the Stadium charged per tick (#189)

Browse Source 
ENGINE step 4 Phase 2 (plan docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md). Rulings,
Captain Bob 2026-11-13: "ID field in the header"; "Per heartbeat tick"; the ACL "All of it in Phase 4".

- The word ID, at xt-4 before the flags (ENGINE.md 3b). The system's words are numbered as they are
  assembled, by a new directive, #id, (and #ids, the count), in the C assembler (text.c) and in the
  machine ROM's (capsules/v4/rom), which counts in the system's own (NEXT-ID). (HEADER) numbers later
  words; FORGET gives back the IDs it frees, always the newest; COLD resets to (BOOT-ID); (SEAL) records
  it. All 313 system headers carry the cell.
- The kernel's records (v4/mesh.h): (TELL-DEFINED) and (TELL-FORGOTTEN), requests -19/-20 on port 0,
  which the kernel puts in (WORD-DEFINED)/(WORD-FORGOTTEN) when it seals a node, and reads the system's
  own words once. A bit per address marks a word's xt (calls into the ROM or headerless code are not
  words); at call, the bit test and a count. v4_mesh_charge hands the owner the calls since.
- The Stadium: stadium_words_charge -- N calls as N of stadium_word_dispatch's dispatches, shared by calls
  when the reservoir is short; sk_v4.c charges every node's words at the tick beside its opcodes, and
  stadium_word_forget before an ID is used again.
- Tests first: test_text.c, test_host_dict.c, test_host_quit.c (numbering, FORGET, COLD),
  test_mesh_boot.c (44 checks), kernel/tests/test_stadium_words.c; qemu_session.py: Hera's words
  admitted after POST.
- amd64: Stadium words: promotions=141 after POST, CONSERVED; POST 539/539; word_count=377;
  dict_hash 0xa854ba15b437d288 (the new cell); the boot 142 s against Phase 1's 153 s.
- v4 test, test-32: all pass; v4-checks: 80 programs under the sanitizers, 0 failures; the hosted
  builds alike. docs/reference/v4-dictionary.tsv: the two new words; FABRIC-3 XLVIII.24.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_017RzZgrf7V7Zk2iczBXDRbm
This commit is contained in:
Claude
2026-11-13 19:12:44 +00:00
parent d64ad4a1c3
commit e8e7ec8b9f
44 changed files with 1060 additions and 349 deletions
Download Patch File Download Diff File Expand all files Collapse all files
capsules/v4/rom/dir.f18
+17 -4
View File
@@ -11,8 +11,12 @@
\ store ADDR VALUE ADDR := VALUE, anywhere in RAM
\ start NAME the end: every branch must have its target; the
\ tables the ROM used are cleared; then NAME runs
\ #id, the next word ID, as a cell of data; the count goes
\ on (#189, Phase 2: a dictionary entry's word ID)
\ A VALUE is a number, a constant, a set variable, CONST+N, here (the next
\ word address) or &NAME of a word already defined.
\ word address), #ids (how many word IDs so far) or &NAME of a word already
\ defined. The count is kept in the system's (NEXT-ID), which is 0 when the
\ machine starts, as all RAM is.
\ ( -- v 1 | 0 0 ) the token as a VALUE; "not a value" if it is none
: (VALUE)
@@ -20,7 +24,8 @@
-if NUMOK drop drop ERR-BIG (FAIL) 0 0 ;
NUMOK: drop 1 ;
NN: drop drop
&(RESERVED) (WALK) 8 xor if HR drop
&(RESERVED) (WALK) dup 8 xor if HR2 drop
14 xor if IDV drop
0 (CHAR@) 38 xor if AMPV drop
(FIND) if NOSYM
dup 2 + a! @ 2 xor if CV drop
@@ -31,7 +36,8 @@
(CONST+N) if BAD0 ;
BAD0: drop drop
BAD: ERR-VALUE (FAIL) 0 0 ;
HR: drop (LABEL) 1 ;
HR2: drop drop (LABEL) 1 ;
IDV: drop NEXT-ID-W a! @ 1 ;
AMPV: drop (TOKN) a! @ -1 + if ONEV drop
(TOK-SAVE) 1 (MLEN) a! @ -1 + (TOK-SUB)
(FIND) if BADA
@@ -68,8 +74,15 @@
BADV: drop drop ;
MISS: drop jump (MISSING)
\ here alone is not something to assemble: only a VALUE
\ here alone is not something to assemble: only a VALUE; and #ids
: (H-HERE) ERR-TARGET jump (FAIL)
: (H-IDS) ERR-TARGET jump (FAIL)
\ #id,: the next word ID, and the count goes on
: (H-ID)
(IN-MACRO?) if OK drop ;
OK: drop
(LABEL) drop NEXT-ID-W a! @ dup 1 + ! jump (EMIT)
: (H-CELL)
(IN-MACRO?) if OK drop ;
capsules/v4/rom/sym.f18
+1 -1
View File
@@ -51,7 +51,7 @@
: (RESERVED)
", : ", macro ", endmacro ", FOR ", NEXT ", UNEXT
", constant ", set ", here ", #, ", ", ", store
", start
", start ", #id, ", #ids
#, 0
\ ( -- op | -1 ) which opcode the token names
capsules/v4/rom/word.f18
+1 -1
View File
@@ -338,7 +338,7 @@
jump (H-FOR) jump (H-NEXT) jump (H-UNEXT)
jump (H-CONSTANT) jump (H-SET) jump (H-HERE)
jump (H-CELL) jump (H-STRING) jump (H-STORE)
jump (H-START)
jump (H-START) jump (H-ID) jump (H-IDS)
\ : NAME end the word before, and begin NAME at the next instruction word
: (H-COLON)
capsules/v4/sys/acl.f18
+13 -13
View File
@@ -18,25 +18,25 @@
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
: (PINNED) -3 + a! @ 64 and ;
set HDR-NFA here ", ACL-HOOK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
set HDR-NFA here ", ACL-HOOK #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
set HDR-NFA here ", ACL-MODE@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-MODE@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
set HDR-NFA here ", ACL-TTL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-TTL@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
set HDR-NFA here ", ACL-ALLOW@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-ALLOW@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
set HDR-NFA here ", ACL-PINNED? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-PINNED? #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
set HDR-NFA here ", ACL-PIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-PIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
set HDR-NFA here ", ACL-MODE! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-MODE! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-MODE! ( mode xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop 255 and 8* @ -65281 and + ! ;
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-TTL! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-TTL! ( n xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop
@@ -44,7 +44,7 @@ set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
POS: dup -65536 and if SMALL drop drop 65535 jump SET
SMALL: drop
SET: 8* 8* @ 65535 and + ! ;
set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-ALLOW! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-ALLOW! ( flag xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop if DENY drop @ -33 and ! ;
@@ -52,7 +52,7 @@ set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
\ is 0 and it is allowed. This is the one word that unpins.
set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-INHERIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-INHERIT
(ACL-XT) SWAP (ACL-XT) \ dst src
-3 + a! @ $FF00 and \ dst mode
@@ -67,7 +67,7 @@ set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK he
NXT: -1 + a! @ jump L
DONE: drop ;
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-INIT-PRIMITIVES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-INIT-PRIMITIVES
(LATEST) a! @ (ACL-INIT)
VOC-LINK a! @
@@ -76,8 +76,8 @@ set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR
\ ( xt -- heat ) how often the word has been used. The node's heat
\ counters are not readable from a programme yet (D-6): 0.
set HDR-NFA here ", ACL-HEAT@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-HEAT@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-HEAT@ (ACL-XT) drop 0 ;
\ ( xt -- n ) a number for the word that never changes: its address
set HDR-NFA here ", ACL-WORD-ID #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-WORD-ID #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-WORD-ID (ACL-XT) ;
capsules/v4/sys/blocks.f18
+12 -12
View File
@@ -25,8 +25,8 @@
\ SCR word address of the variable: the block LIST showed last
\ 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 ;
set HDR-NFA here ", SCR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SCR' SCR ;
set HDR-NFA here ", BLK #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BLK' BLK ;
\ ( status -- ) a request that did not work is an error
: (B-ERR)
@@ -41,27 +41,27 @@ set HDR-NFA here ", BLK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL
\ ( n -- baddr ) FORTH-79: the address of a buffer assigned to block n.
\ What the buffer holds is not read from storage.
set HDR-NFA here ", BUFFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BUFFER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BUFFER BUFFER# (PORT) b! !b jump (B-GOT)
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
\ read from storage if it is not already in one.
set HDR-NFA here ", BLOCK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BLOCK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BLOCK BLOCK# (PORT) b! !b jump (B-GOT)
\ FORTH-79: mark the block most recently asked for as changed, so that it is
\ written before its buffer is used for another.
set HDR-NFA here ", UPDATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UPDATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
\ FORTH-79: write every block that has been UPDATEd.
set HDR-NFA here ", SAVE-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SAVE-BUFFERS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
\ As v3: the same.
set HDR-NFA here ", FLUSH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FLUSH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FLUSH jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
set HDR-NFA here ", EMPTY-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EMPTY-BUFFERS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EMPTY-BUFFERS EMPTY-BUFFERS# (PORT) b! !b ;
\ ---- LIST ----------------------------------------------------------------------
@@ -69,7 +69,7 @@ set HDR-NFA here ", EMPTY-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK
\ characters, each after its number, and an empty line. SCR is left holding n. A character
\ that is not printable is shown as a blank. (Q)+0 is the line, (Q)+1 the
\ column, (Q)+2 the block's number.
set HDR-NFA here ", LIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LIST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LIST
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
(Q)+2 a! @ dup SCR a! !
@@ -101,7 +101,7 @@ set HDR-NFA here ", LIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
TERM: drop ;
\ ( n -- ) FORTH-79: interpret block n, then go on with what follows.
set HDR-NFA here ", LOAD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOAD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOAD
-if POS jump BAD
POS: if BAD
@@ -114,13 +114,13 @@ set HDR-NFA here ", LOAD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) go on with the next block. Only in a block being loaded: at the
\ terminal it is an error (code 14).
set HDR-NFA here ", --> #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", --> #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NEXT-BLOCK
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
TERM: drop NODE-ERROR b! 14 !b ;
\ ( first last -- ) as v3: LOAD each block from first to last.
set HDR-NFA here ", THRU #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", THRU #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: THRU
push
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
capsules/v4/sys/compile.f18
+35 -35
View File
@@ -149,7 +149,7 @@ macro ROT push SWAP pop SWAP endmacro
\ ( -- ) print the word WORD has just left
: (.WORD) WBUF COUNT jump TYPE
set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXECUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ It calls the word, so that the hook at `call` sees it (#189, ENGINE.md 6,
\ ruled 2026-10-20): a `call xt` instruction word -- `call`, opcode 3, in slot
\ 0, the address in the 27 bits below it -- is put in (EXEC) with a ; after
@@ -193,7 +193,7 @@ set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ on the stack, or compiled as a literal. What is neither, or a compile-only
\ word met while interpreting, abandons the line, with v3's message:
\ UNKNOWN WORD: 'xxx' xxx: compile-only
set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", INTERPRET #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: INTERPRET
: (IL) 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
@@ -225,25 +225,25 @@ set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ---- state ---------------------------------------------------------------------
set HDR-NFA here ", [ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LEFT-BRACKET 0 STATE a! ! ;
set HDR-NFA here ", ] #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ] #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: RIGHT-BRACKET -1 STATE a! ! ;
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
set HDR-NFA here ", LITERAL #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LITERAL #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ;
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
\ compiling, compiled as a literal
set HDR-NFA here ", ' #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ' #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TICK (') jump LITERAL
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
\ which v3 has as another name for LITERAL.
set HDR-NFA here ", ['] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ['] #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-TICK (') jump (LIT,)
set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [LITERAL] #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-LITERAL jump LITERAL
\ ---- colon definitions -----------------------------------------------------------
@@ -251,7 +251,7 @@ set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: start a definition; it cannot be found until ; ends it. The
\ CONTEXT vocabulary is set to the CURRENT one.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", : #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COLON
CURRENT a! @ CONTEXT a! !
LATEST (C)+2 a! !
@@ -261,7 +261,7 @@ set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
NONE: drop jump (ABANDON) \ no entry: the rest of the line is not a definition
\ FORTH-79: compile the return, let the word be found, stop compiling
set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ; #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEMICOLON
0 (OP,)
LATEST (FLAGS) a! @ -3 and !
@@ -276,27 +276,27 @@ set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a
\ node. Not FORTH-79 and not in v3, where such a word is registered from C.
\ The constant (PORT) is the port's word address.
set HDR-NFA here ", KERNEL-WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", KERNEL-WORD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KERNEL-WORD
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
jump SEMICOLON
\ FORTH-79: return from the definition at this point
set HDR-NFA here ", EXIT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXIT #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXIT 0 jump (OP,)
set HDR-NFA here ", IMMEDIATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IMMEDIATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
set HDR-NFA here ", COMPILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COMPILE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COMPILE
32 WORD (LOOKUP) if MISSING
(LIT,) &(COMPILE,) jump (CALL,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate
set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [COMPILE] #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-COMPILE
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
@@ -324,16 +324,16 @@ set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK her
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
set HDR-NFA here ", CREATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CREATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
\ programme; here it is 0.
set HDR-NFA here ", VARIABLE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VARIABLE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
\ ( n -- ) FORTH-79: an entry whose word leaves n
set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CONSTANT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ;
\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become
@@ -342,7 +342,7 @@ set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ call to the code after it and leaves DEFINER; that code starts with pop,
\ which fetches the parameter field address the call left.
: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0
set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DOES> #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOES> &(DOES) (CALL,) 25 jump (OP,)
\ ---- control structures (5.18, section 2) ---------------------------------------------
@@ -362,15 +362,15 @@ set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ Native if leaves the flag, so both ways out of it drop it (section 2):
\ IF a THEN if L1 drop a jump L2 L1: drop L2:
\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2:
set HDR-NFA here ", IF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF
set HDR-NFA here ", ELSE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ELSE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ELSE
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF \ the jump over the else part
(C)+6 a! @ (HERE!) 23 (OP,)
2 jump >CF
set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", THEN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: THEN
CF> dup -1 + if PLAIN
drop 2 (PAIR) CF> jump (HERE!)
@@ -386,19 +386,19 @@ set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop
\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0
\ The control-flow stack holds Ld, L0 and 3.
set HDR-NFA here ", BEGIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BEGIN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BEGIN
2 (BRANCH>) (C)+6 a! !
(LABEL) >CF 23 (OP,)
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
3 jump >CF
set HDR-NFA here ", UNTIL #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UNTIL #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,)
set HDR-NFA here ", AGAIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", AGAIN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ;
set HDR-NFA here ", WHILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WHILE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF
set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", REPEAT #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: REPEAT
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
CF> 3 (PAIR) CF> (JUMP,) CF> drop
@@ -412,16 +412,16 @@ set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ value for, with END after it. The control-flow stack holds the jumps to
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
: (of) over xor ;
set HDR-NFA here ", CASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CASE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CASE 0 >CF 7 jump >CF
set HDR-NFA here ", OF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", OF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: OF
CF> 7 (PAIR)
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
8 jump >CF
set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENDOF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDOF
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
CF> (C)+7 a! ! \ how many jumps to END so far
@@ -429,7 +429,7 @@ set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(C)+7 a! @ 1 + >CF
(C)+6 a! @ (HERE!) \ N:
7 jump >CF
set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENDCASE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDCASE
CF> 7 (PAIR) CF> (C)+7 a! !
23 (OP,)
@@ -477,11 +477,11 @@ set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(C)+6 a! @ jump (HERE!)
PLAIN: drop ;
set HDR-NFA here ", DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DO #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF
set HDR-NFA here ", ?DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ?DO #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
set HDR-NFA here ", LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOOP #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
set HDR-NFA here ", +LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", +LOOP #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
capsules/v4/sys/core.f18
+12 -12
View File
@@ -32,14 +32,14 @@ macro NEGATE inv 1 + endmacro
macro NIP push drop pop endmacro
\ ---- section 4: multiply ------------------------------------------------
set HDR-NFA here ", UM* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UM* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UM* ROM-UM* push ; \ ( u1 u2 -- ulo uhi ) the ROM's entry 0 (MACHINE.md 2.2)
\ ---- section 5.7: doubles ------------------------------------------------
set HDR-NFA here ", D+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D+ ROM-D+ push ; \ ( d1 d2 -- d3 ) the ROM's entry 2
set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DNEGATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DNEGATE ROM-DNEGATE push ; \ ( d -- -d ) the ROM's entry 3
\ ---- section 5.3: bytes --------------------------------------------------
@@ -50,7 +50,7 @@ set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
@@ -59,7 +59,7 @@ set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
@@ -69,7 +69,7 @@ set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CMOVE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CMOVE ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push
@@ -421,7 +421,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EMIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EMIT ( c -- )
255 and a push push \ A, and then the character, to the return stack
(OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT
@@ -430,18 +430,18 @@ set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on
a (OUT)+256 xor if FULL drop pop a! ;
FULL: drop (FLUSH-OUT) pop a! ;
set HDR-NFA here ", KEY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", KEY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
set HDR-NFA here ", CR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CR ( -- ) 10 jump EMIT
set HDR-NFA here ", SPACE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SPACE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACE ( -- ) 32 jump EMIT
set HDR-NFA here ", COUNT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COUNT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
set HDR-NFA here ", TYPE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", TYPE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TYPE ( baddr u -- )
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
capsules/v4/sys/dict.f18
+36 -23
View File
@@ -10,6 +10,10 @@
\
\ name the count byte, then the characters, four bytes to a cell,
\ padded with zeros to a whole cell
\ xt - 4 the word ID: what the kernel's record of the word is kept by
\ (ENGINE.md 3b; #189 Phase 2, Captain Bob 2026-11-13: "ID field in
\ the header"). The next is in (NEXT-ID); FORGET gives back the
\ IDs of what it removes, which are always the newest
\ 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
@@ -63,15 +67,15 @@ macro OR over inv and xor endmacro
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
HIGH: drop DP b! !b -1 ;
set HDR-NFA here ", HERE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HERE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
set HDR-NFA here ", ALIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ALIGN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
set HDR-NFA here ", ALLOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ALLOT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
set HDR-NFA here ", , #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", , #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: , ( x -- )
a!
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
@@ -79,50 +83,50 @@ set HDR-NFA here ", , #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
drop drop NODE-ERROR b! 5 !b ;
ROOM: drop dup 4 + !b \ DP is past it
4/ b! a !b ;
set HDR-NFA here ", C, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C, #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C, ( c -- )
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
set HDR-NFA here ", 2, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2, #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
set HDR-NFA here ", LATEST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LATEST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
set HDR-NFA here ", >LINK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >LINK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >LINK ( xt -- addr ) -1 + ;
set HDR-NFA here ", LFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LFA ( xt -- addr ) jump >LINK
set HDR-NFA here ", LINK> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LINK> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LINK> ( addr -- xt ) a! @ ;
set HDR-NFA here ", >NAME #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >NAME #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
set HDR-NFA here ", NFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NFA ( xt -- baddr ) jump >NAME
set HDR-NFA here ", NAME> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
set HDR-NFA here ", CFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NAME> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 4 + ;
set HDR-NFA here ", CFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CFA ( xt -- xt ) ;
set HDR-NFA here ", PFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
set HDR-NFA here ", >BODY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >BODY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >BODY ( xt -- addr ) jump PFA
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
set HDR-NFA here ", TRAVERSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", TRAVERSE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
set HDR-NFA here ", SMUDGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SMUDGE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HIDDEN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
\ ---- telling the kernel (docs/v4.0.0/ENGINE.md 3b) ------------------------------
@@ -145,14 +149,22 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(WORD-FORGOTTEN) b! @b if NONE push ;
NONE: drop drop ;
\ ( xt -- ) and ( w -- ) the words a kernel that keeps records puts in (WORD-DEFINED) and
\ (WORD-FORGOTTEN): requests -19 and -20 to the kernel on the node's port 0, which takes the xt or
\ the word address off the stack (v4/mesh.h; #189, Phase 2). A host that keeps none leaves both 0.
set HDR-NFA here ", (TELL-DEFINED) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (TELL-DEFINED) -19 (PORT) b! !b ;
set HDR-NFA here ", (TELL-FORGOTTEN) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (TELL-FORGOTTEN) -20 (PORT) b! !b ;
\ ---- 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 + ;
\ cells and four more
: (NEED) (D)+3 a! @ 4 + -4 and 16 + ;
\ ( 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
@@ -175,6 +187,7 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop
(NEXT-ID) a! @ dup 1 + ! , \ its word ID, and the next
0 , (D) a! @ , LATEST ,
HERE CURRENT a! @ a! !
jump (DEFINED)
@@ -216,7 +229,7 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
set HDR-NFA here ", FIND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FIND #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FIND 32 WORD jump (LOOKUP)
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
capsules/v4/sys/end.f18
+3
View File
@@ -22,6 +22,9 @@ store (SRC) TIB
\ what COLD comes back to, and the lowest FORGET goes: the nucleus as it is
store (BOOT) DBASE
store (BOOT)+1 HDR-LINK
\ the word IDs: the system's are 0 .. #ids - 1, numbered as assembled (#189, Phase 2)
store (NEXT-ID) #ids
store (BOOT-ID) #ids
store FENCE DICT-W
\ nothing has ended badly; nothing has been printed
store (LINE-STATUS) 1
capsules/v4/sys/forth.f18
+57 -57
View File
@@ -9,15 +9,15 @@
\ this file.
\ ---- stack ----
set HDR-NFA here ", DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
set HDR-NFA here ", DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DROP drop ;
set HDR-NFA here ", OVER #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OVER over ;
set HDR-NFA here ", SWAP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SWAP' SWAP ;
set HDR-NFA here ", ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ROT' ROT ;
set HDR-NFA here ", -ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : -ROT SWAP push SWAP pop ;
set HDR-NFA here ", ?DUP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ?DUP if Z dup ; Z: ;
set HDR-NFA here ", 2DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DUP over over ;
set HDR-NFA here ", 2DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DROP drop drop ;
set HDR-NFA here ", DUP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
set HDR-NFA here ", DROP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DROP drop ;
set HDR-NFA here ", OVER #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OVER over ;
set HDR-NFA here ", SWAP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SWAP' SWAP ;
set HDR-NFA here ", ROT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ROT' ROT ;
set HDR-NFA here ", -ROT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : -ROT SWAP push SWAP pop ;
set HDR-NFA here ", ?DUP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ?DUP if Z dup ; Z: ;
set HDR-NFA here ", 2DUP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DUP over over ;
set HDR-NFA here ", 2DROP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DROP drop drop ;
\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
@@ -28,7 +28,7 @@ set HDR-NFA here ", 2DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here :
\ anything while n is still there, and never more than one cell after.
\ FORTH-79: how many values were on the stack before DEPTH
set HDR-NFA here ", DEPTH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEPTH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEPTH DSTACK-DEPTH b! @b ;
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
@@ -60,7 +60,7 @@ set HDR-NFA here ", DEPTH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n -- x ) FORTH-79: a copy of the n-th value, not counting n itself.
\ 1 PICK is DUP, 2 PICK is OVER. n less than one is an error.
set HDR-NFA here ", PICK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PICK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PICK
-if POS jump BAD
POS: if BAD
@@ -72,7 +72,7 @@ set HDR-NFA here ", PICK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n -- ) FORTH-79: the n-th value, not counting n itself, is taken out
\ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n
\ less than one is an error.
set HDR-NFA here ", ROLL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ROLL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ROLL
-if POS jump BAD
POS: if BAD
@@ -82,36 +82,36 @@ set HDR-NFA here ", ROLL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
BAD: drop $4C4C4F52 jump (INDEX)
\ ---- return stack: in line, and only inside a definition ----
set HDR-NFA here ", >R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >R push ;
set HDR-NFA here ", R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R> pop ;
set HDR-NFA here ", R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R@ pop dup push ;
set HDR-NFA here ", I #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : I pop dup push ;
set HDR-NFA here ", J #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : J pop pop pop dup push a! push push a ;
set HDR-NFA here ", LEAVE #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
set HDR-NFA here ", UNLOOP #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
set HDR-NFA here ", >R #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >R push ;
set HDR-NFA here ", R> #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R> pop ;
set HDR-NFA here ", R@ #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R@ pop dup push ;
set HDR-NFA here ", I #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : I pop dup push ;
set HDR-NFA here ", J #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : J pop pop pop dup push a! push push a ;
set HDR-NFA here ", LEAVE #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
set HDR-NFA here ", UNLOOP #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
\ ---- memory ----
set HDR-NFA here ", @ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FETCH a! @ ;
set HDR-NFA here ", ! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STORE a! ! ;
set HDR-NFA here ", +! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
set HDR-NFA here ", CELLS #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
set HDR-NFA here ", @ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FETCH a! @ ;
set HDR-NFA here ", ! #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STORE a! ! ;
set HDR-NFA here ", +! #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
set HDR-NFA here ", CELLS #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
\ ---- arithmetic ----
set HDR-NFA here ", + #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
set HDR-NFA here ", - #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : MINUS - ;
set HDR-NFA here ", + #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
set HDR-NFA here ", - #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : MINUS - ;
\ The low cell of the product, by N steps of +* with nothing but the count on
\ the return stack. UM* drop gives the same cell but needs two more return
\ entries, which a word inside two DO loops does not have (D-2). The low
\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach
\ the bit that moves into A, and the loop ends first.
set HDR-NFA here ", * #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", NEGATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
set HDR-NFA here ", 1+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1+ 1 + ;
set HDR-NFA here ", 1- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1- -1 + ;
set HDR-NFA here ", 2+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2+ 2 + ;
set HDR-NFA here ", 2- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2- -2 + ;
set HDR-NFA here ", 2* #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO* 2* ;
set HDR-NFA here ", 2/ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO/ 2/ ;
set HDR-NFA here ", * #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", NEGATE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
set HDR-NFA here ", 1+ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1+ 1 + ;
set HDR-NFA here ", 1- #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1- -1 + ;
set HDR-NFA here ", 2+ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2+ 2 + ;
set HDR-NFA here ", 2- #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2- -2 + ;
set HDR-NFA here ", 2* #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO* 2* ;
set HDR-NFA here ", 2/ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO/ 2/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
@@ -163,11 +163,11 @@ set HDR-NFA here ", 2/ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO
(F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
set HDR-NFA here ", S>D #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", S>D #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
set HDR-NFA here ", M* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M* ( n1 n2 -- d )
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop jump DNEGATE P: drop ;
@@ -181,49 +181,49 @@ set HDR-NFA here ", M* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(F) a! @ -if P drop DNEGATE jump Q P: drop Q:
(F)+2 a! @ jump SM/REM
set HDR-NFA here ", /MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", /MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: drop drop 0 $444F4D2F jump (DIV0)
set HDR-NFA here ", / #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", / #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: drop drop 0 $2F jump (DIV0)
set HDR-NFA here ", MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: drop drop 0 $444F4D jump (DIV0)
set HDR-NFA here ", */MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", */MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
set HDR-NFA here ", */ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", */ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: drop drop drop 0 $2F2A jump (DIV0)
set HDR-NFA here ", M/MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M/MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
\ ---- logic and comparison ----
set HDR-NFA here ", AND #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
set HDR-NFA here ", XOR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : XOR xor ;
set HDR-NFA here ", OR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OR' OR ;
set HDR-NFA here ", 0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0= if L1 drop 0 ; L1: drop -1 ;
set HDR-NFA here ", 0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0< -if L1 drop -1 ; L1: drop 0 ;
set HDR-NFA here ", NOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOT jump 0=
set HDR-NFA here ", = #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : EQUALS xor jump 0=
set HDR-NFA here ", < #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
set HDR-NFA here ", AND #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
set HDR-NFA here ", XOR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : XOR xor ;
set HDR-NFA here ", OR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OR' OR ;
set HDR-NFA here ", 0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0= if L1 drop 0 ; L1: drop -1 ;
set HDR-NFA here ", 0< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0< -if L1 drop -1 ; L1: drop 0 ;
set HDR-NFA here ", NOT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOT jump 0=
set HDR-NFA here ", = #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : EQUALS xor jump 0=
set HDR-NFA here ", < #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
over over xor -if SAME drop drop jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", > #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : GREATER SWAP jump LESS
set HDR-NFA here ", > #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : GREATER SWAP jump LESS
\ ---- in-line addresses and constants ----
set HDR-NFA here ", BL #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL' BL ;
set HDR-NFA here ", TIB #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TIB' TIB ;
set HDR-NFA here ", >IN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >IN' >IN ;
set HDR-NFA here ", SPAN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SPAN' SPAN ;
set HDR-NFA here ", BASE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BASE' BASE ;
set HDR-NFA here ", PAD #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PAD' PAD ;
set HDR-NFA here ", STATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
set HDR-NFA here ", BL #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL' BL ;
set HDR-NFA here ", TIB #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TIB' TIB ;
set HDR-NFA here ", >IN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >IN' >IN ;
set HDR-NFA here ", SPAN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SPAN' SPAN ;
set HDR-NFA here ", BASE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BASE' BASE ;
set HDR-NFA here ", PAD #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PAD' PAD ;
set HDR-NFA here ", STATE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
capsules/v4/sys/input.f18
+9 -9
View File
@@ -27,7 +27,7 @@
macro BL 32 endmacro
\ ( -- baddr u ) the input buffer and how much of it is in use
set HDR-NFA here ", SOURCE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SOURCE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ;
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
@@ -40,7 +40,7 @@ set HDR-NFA here ", SOURCE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ on the stack beneath it, so it works in (P) -- (P)+0 where the next
\ character goes, (P)+1 how many more may come, (P)+2 where the first went --
\ and has at most three cells of its own on the data stack (D-2).
set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXPECT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXPECT
-if NN drop drop ; \ n < 0
NN: if ZERO
@@ -57,7 +57,7 @@ set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ZERO: drop drop ;
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
set HDR-NFA here ", QUERY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", QUERY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
\ ---- WORD ------------------------------------------------------------------
@@ -122,7 +122,7 @@ macro (STEP) (P)+6 a! @ 1 + ! endmacro
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
(P)+6 a! @ >IN a! ! WBUF ;
set HDR-NFA here ", WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WORD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WORD
(WORD-SET)
SK: (LEFT) -if SKE drop (CH) if SKS drop jump (WORD-TAKE) \ past delimiters
@@ -146,7 +146,7 @@ set HDR-NFA here ", WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr c -- baddr n1 n2 n3 ) in the zero-terminated string at baddr:
\ n1 the offset of the first character that is not c, n2 the offset of the
\ first c after it, n3 the offset of the first character after that run of c.
set HDR-NFA here ", ENCLOSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENCLOSE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENCLOSE
255 and (P) a! ! dup (P)+1 a! !
0 (ESKIP) dup (ESCAN) dup (ESKIP) ;
@@ -167,7 +167,7 @@ set HDR-NFA here ", ENCLOSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ it is multiplied by BASE, until one is not a digit; baddr2 is its address.
\ (P)+2 holds the digit while the double is multiplied and (P)+5 the address,
\ so nothing waits on the return stack across the calls.
set HDR-NFA here ", CONVERT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CONVERT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CONVERT
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
-if DIG drop (P)+5 a! @ ;
@@ -201,16 +201,16 @@ set HDR-NFA here ", CONVERT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ERR0: 0 0 0 ;
\ ( baddr -- d ) FORTH-79. What is not a number gives 0 and sets NODE-ERROR.
set HDR-NFA here ", NUMBER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NUMBER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NUMBER
(NUMBER?) if BAD drop ;
BAD: drop NODE-ERROR b! 2 !b ;
\ ---- comments (5.15) -------------------------------------------------------
\ PAREN skips to the closing parenthesis; BACKSLASH skips the rest of the line.
set HDR-NFA here ", ( #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ( #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PAREN 41 WORD drop ;
set HDR-NFA here ", \ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", \ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BACKSLASH
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
capsules/v4/sys/log.f18
+18 -18
View File
@@ -16,16 +16,16 @@
\ Constants the loader supplies:
\ (LOG-LEVEL) word address of the variable: 2, LOG-INFO, at switch-on
set HDR-NFA here ", LOG-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR 0 ;
set HDR-NFA here ", LOG-WARN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN 1 ;
set HDR-NFA here ", LOG-INFO #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO 2 ;
set HDR-NFA here ", LOG-TEST #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST 3 ;
set HDR-NFA here ", LOG-DEBUG #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG 4 ;
set HDR-NFA here ", LOG-ERROR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR 0 ;
set HDR-NFA here ", LOG-WARN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN 1 ;
set HDR-NFA here ", LOG-INFO #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO 2 ;
set HDR-NFA here ", LOG-TEST #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST 3 ;
set HDR-NFA here ", LOG-DEBUG #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG 4 ;
set HDR-NFA here ", LOG-LEVEL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOG-LEVEL@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
set HDR-NFA here ", LOG-LEVEL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOG-LEVEL! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOG-LEVEL!
-if POS drop 0 jump SET
POS: dup -5 + -if BIG drop jump SET
@@ -45,15 +45,15 @@ set HDR-NFA here ", LOG-LEVEL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
P4: drop $34335B1B (EMIT4) $6D (EMIT4) $55424544 (EMIT4) $203A47 (EMIT4) $6D305B1B (EMIT4) jump OUT
OUT: TYPE jump CR
set HDR-NFA here ", LOG-ERROR-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
set HDR-NFA here ", LOG-WARN-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
set HDR-NFA here ", LOG-INFO-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
set HDR-NFA here ", LOG-TEST-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
set HDR-NFA here ", LOG-DEBUG-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
set HDR-NFA here ", LOG-ERROR-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
set HDR-NFA here ", LOG-WARN-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
set HDR-NFA here ", LOG-INFO-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
set HDR-NFA here ", LOG-TEST-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
set HDR-NFA here ", LOG-DEBUG-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
\ ( level -- ) the run time of LOG-xxx" : the text is after the call, as
\ for ." ; log it at that level and go on after it.
set HDR-NFA here ", (LOG") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (LOG") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (LOG")
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
COUNT ROT jump (LOG)
@@ -65,8 +65,8 @@ set HDR-NFA here ", (LOG") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
STATE a! @ if NOW
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT (Q)+3 a! @ jump (LOG)
set HDR-NFA here ", LOG-ERROR" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-WARN" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-INFO" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-TEST" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-DEBUG" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-ERROR" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-WARN" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-INFO" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-TEST" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-DEBUG" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
capsules/v4/sys/map-32.f18
+2
View File
@@ -28,6 +28,8 @@ constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (NEXT-ID) 15746
constant (BOOT-ID) 15747
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
capsules/v4/sys/map-64.f18
+2
View File
@@ -28,6 +28,8 @@ constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (NEXT-ID) 15746
constant (BOOT-ID) 15747
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
capsules/v4/sys/numout.f18
+19 -19
View File
@@ -21,34 +21,34 @@ macro (-ROT) SWAP push SWAP pop endmacro
: UM/MOD ROM-UM/MOD push ; \ ( ulo uhi ud -- urem uquot )
\ ---- pictured output ----
set HDR-NFA here ", <# #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <# #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <# ( -- ) HEND HLD b! !b ;
set HDR-NFA here ", HOLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HOLD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HOLD ( c -- )
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
OKC: drop HLD b! @b -HFLOOR + -if ROOM
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
ROOM: drop HLD b! @b -1 + dup !b jump C!
set HDR-NFA here ", SIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SIGN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
set HDR-NFA here ", # #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", # #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: # ( ud1 -- ud2 )
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
(BASE) UM/MOD (-ROT) \ qlo qhi rem
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
set HDR-NFA here ", #S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", #S #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
set HDR-NFA here ", #> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", #> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
set HDR-NFA here ", SPACES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SPACES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
set HDR-NFA here ", DECIMAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DECIMAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DECIMAL 10 BASE a! ! ;
set HDR-NFA here ", HEX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HEX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HEX 16 BASE a! ! ;
set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", OCTAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: OCTAL 8 BASE a! ! ;
\ ---- numbers ----
@@ -69,28 +69,28 @@ set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (D.BODY) ( d width -- )
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
set HDR-NFA here ", .R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", .R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
set HDR-NFA here ", . #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", . #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
set HDR-NFA here ", U.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U.R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
set HDR-NFA here ", U. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U. #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
set HDR-NFA here ", D.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D.R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
set HDR-NFA here ", D. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D. #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
set HDR-NFA here ", ? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ? #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUESTION a! @ jump DOT
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line. The stack is
\ left as it was. It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", .S #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-S
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
DEPTH (W)+2 b! !b
@@ -105,7 +105,7 @@ set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ Everything it keeps between words is in (DP): the saved BASE, the address,
\ the count and the column. ADDR-DIGITS is two for each byte of a cell.
: (DB) ( -- c ) (DP)+1 b! @b (DP)+3 b! @b + jump C@
set HDR-NFA here ", DUMP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DUMP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DUMP
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: (DP)+2 b! !b (DP)+1 b! !b
capsules/v4/sys/qmath.f18
+23 -23
View File
@@ -24,38 +24,38 @@ macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
: (QERR12) NODE-ERROR b! 12 !b ;
\ ---- conversion and constants ----
set HDR-NFA here ", Q.FROM-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.FROM-INT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
set HDR-NFA here ", Q.TO-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.TO-INT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", Q.1 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.1 65536 0 ;
set HDR-NFA here ", Q.0 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0 0 0 ;
set HDR-NFA here ", Q.SCALE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
set HDR-NFA here ", Q.1 #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.1 65536 0 ;
set HDR-NFA here ", Q.0 #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0 0 0 ;
set HDR-NFA here ", Q.SCALE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
\ ---- the double words under other names ----
set HDR-NFA here ", Q.+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.+ jump D+
set HDR-NFA here ", Q.- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.- jump D-
set HDR-NFA here ", Q.ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.ABS jump DABS
set HDR-NFA here ", Q.NEG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.NEG jump DNEGATE
set HDR-NFA here ", Q.= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.= jump D=
set HDR-NFA here ", Q.< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.< jump D<
set HDR-NFA here ", Q.> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.> 2SWAP jump D<
set HDR-NFA here ", Q.0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0= jump D0=
set HDR-NFA here ", Q.MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MAX jump DMAX
set HDR-NFA here ", Q.MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
set HDR-NFA here ", Q.+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.+ jump D+
set HDR-NFA here ", Q.- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.- jump D-
set HDR-NFA here ", Q.ABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.ABS jump DABS
set HDR-NFA here ", Q.NEG #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.NEG jump DNEGATE
set HDR-NFA here ", Q.= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.= jump D=
set HDR-NFA here ", Q.< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.< jump D<
set HDR-NFA here ", Q.> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.> 2SWAP jump D<
set HDR-NFA here ", Q.0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0= jump D0=
set HDR-NFA here ", Q.MAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MAX jump DMAX
set HDR-NFA here ", Q.MIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
\ ---- multiply ----
set HDR-NFA here ", Q.* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.* ROM-Q.* push ; \ ( a b -- c ) the ROM's entry 4 (MACHINE.md 2.2)
\ ---- divide ----
\ D2*C and (UQ/), Q./'s core, are the ROM's (capsules/v4/rom/math.f18).
set HDR-NFA here ", Q./ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q./ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q./ ROM-Q./ push ; \ ( a b -- q ) the ROM's entry 5
\ ---- e to the x ----
set HDR-NFA here ", Q.EXP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.EXP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.EXP ( q -- e )
over over OR if ONE drop
dup (QE)+6 b! !b -if L1 DNEGATE L1:
@@ -80,7 +80,7 @@ set HDR-NFA here ", Q.EXP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ONE: drop drop drop 65536 0 ;
\ ---- square root ----
set HDR-NFA here ", Q.SQRT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.SQRT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.SQRT ( q -- r )
dup -if POS drop drop drop 0 0 jump (QERR12)
POS: drop over over OR if ZERO drop
@@ -100,7 +100,7 @@ set HDR-NFA here ", Q.SQRT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ONE: drop ;
\ ---- natural logarithm ----
set HDR-NFA here ", Q.LOG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.LOG #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.LOG ( x -- ln x )
dup -if POS drop jump ERR
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
@@ -159,13 +159,13 @@ set HDR-NFA here ", Q.LOG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
END: (QT)+3 b! @b (QT) b! @b -if PR drop inv 1 + jump SD PR: drop
SD: dup -if SP drop -1 ; SP: drop 0 ;
set HDR-NFA here ", Q.SIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.SIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.SIN ( x -- sin x )
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
dup (QT)+2 b! !b dup (QT)+3 b! !b
0 over 0 Q.* drop (QT)+1 b! !b
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
set HDR-NFA here ", Q.COS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.COS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.COS ( x -- cos x )
(Q.REDUCE) -if A1 inv 1 + A1:
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
@@ -174,7 +174,7 @@ set HDR-NFA here ", Q.COS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ---- printing ----
\ The integer part, a point, five digits, a blank; always in decimal.
set HDR-NFA here ", Q.PRINT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.PRINT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.PRINT ( q -- )
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
BASE b! @b (QP) b! !b 10 BASE b! !b
capsules/v4/sys/quit.f18
+28 -27
View File
@@ -200,7 +200,7 @@ macro R-CLEAR RSTACK-DEPTH b! a !b endmacro
\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel.
\ ( node port -- ) the port, by its number, leads toward that node
set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ROUTE
(ROUTE#) a! @ -16 + if FULL drop
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
@@ -212,20 +212,20 @@ set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 0: none, or a device. Whoever wires the node tells it, and tells it again
\ when the wiring changes. It is how a node knows who its centre is, the
\ one node whose GONE it believes: (CENTRE).
set HDR-NFA here ", NEIGHBOUR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NEIGHBOUR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NEIGHBOUR
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( port -- ) the port, by its number, leads toward every node not told of
set HDR-NFA here ", DEFAULT-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFAULT-ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
\ ( node -- ) forget the way to that node, if one is known: what is for it
\ then goes by the way for every node not told of, if there is one. The
\ last way in the table takes its place.
set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NO-ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NO-ROUTE
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
@@ -253,11 +253,11 @@ set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n node -- ) tell the node that node n is gone. It acts on that only
\ if this node is its centre: it forgets the way to n, and if it is waiting
\ for n's answer the wait ends.
set HDR-NFA here ", GONE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", GONE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NO-ROUTES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
\ ( baddr u node port -- ) send the node u characters of text to
@@ -299,7 +299,7 @@ set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr u node -- ) send the node u characters of text to interpret,
\ by the way this node knows to it. What it prints there goes to that
\ node's console. With no way to the node it is error 12.
set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEND #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEND
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
GO: jump (SEND-ON)
@@ -307,7 +307,7 @@ set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr u node port -- ) the same by a port this node names, by its
\ number, whatever ways it knows: for a neighbour that has no number of
\ its own yet, to which text is sent as to node 0.
set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEND-ON #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEND-ON
dup -if POS jump BAD
POS: -PORTS + -if BAD drop jump (SEND-ON)
@@ -359,7 +359,7 @@ set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ does not keep it awake.
\ 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
set HDR-NFA here ", AWAIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: AWAIT
(ONE) a! ! (ROOM) \ if this faults, no one is waited for:
(ONE) a! @ (AWAIT-FROM) a! ! 0 (A-SELF) a! ! \ (AWAIT-FROM) is set only when the stack has been tried
@@ -392,7 +392,7 @@ set HDR-NFA here ", AWAIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ the neighbour has taken it. This is how a node is sent a capsule of F18
\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a
\ message, to a node that is executing from its ports.
set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PORT! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PORT!
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
@@ -401,11 +401,12 @@ 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.f18, (BOOT) and FENCE).
set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (SEAL) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (SEAL)
DP a! @ (BOOT) a! !
(LATEST) a! @ (BOOT)+1 a! !
DP a! @ 3 + 2/ 2/ FENCE a! ! ;
DP a! @ 3 + 2/ 2/ FENCE a! !
(NEXT-ID) a! @ (BOOT-ID) 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.
@@ -413,22 +414,22 @@ set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 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.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) ;
set HDR-NFA here ", (LOST) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ;
set HDR-NFA here ", (REFUSED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ;
set HDR-NFA here ", (WORD-DEFINED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ;
set HDR-NFA here ", (WORD-FORGOTTEN) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
set HDR-NFA here ", NODE-ERROR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NODE-ERROR' NODE-ERROR ;
set HDR-NFA here ", (ME) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (ME)' (ME) ;
set HDR-NFA here ", (CONSOLE) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (CONSOLE)' (CONSOLE) ;
set HDR-NFA here ", (LOST) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ;
set HDR-NFA here ", (REFUSED) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ;
set HDR-NFA here ", (WORD-DEFINED) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ;
set HDR-NFA here ", (WORD-FORGOTTEN) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
set HDR-NFA here ", QUIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", QUIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
\ FORTH-79: clear the data and return stacks, set execution mode, return
\ control to the terminal. As v3, the line it stops ends with " ok".
\ Both are emptied before anything is called: ABORT may be run with the
\ return stack full.
set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABORT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
\ ---- faults (D-14, D-16) -------------------------------------------------------
@@ -531,7 +532,7 @@ set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ It takes the return address off before it calls anything and keeps the
\ count there instead, so a word that prints text goes no deeper than one
\ that calls any other word.
set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (.") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (.")
pop 4* dup C@ \ baddr n
L: if DONE
@@ -540,7 +541,7 @@ set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
\ it is compiled into runs, if compiling.
set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ." #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
@@ -550,7 +551,7 @@ set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the
\ string after the call, start a new line and ABORT; otherwise go on after
\ the string.
set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (ABORT") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (ABORT")
if NO
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
@@ -558,7 +559,7 @@ set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if
\ the flag is not zero, print the text and ABORT.
set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABORT" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABORT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
@@ -569,7 +570,7 @@ set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (S") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
@@ -578,7 +579,7 @@ set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
set HDR-NFA here ", S" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", S" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
capsules/v4/sys/system.f18
+23 -21
View File
@@ -11,37 +11,37 @@
\ HEAT-OP ANTICLOCK word addresses of HEAT-OP[0] and ANTICLOCK, the heat
\ registers (DECOMPOSITION.md section 7): read-only
set HDR-NFA here ", FENCE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FENCE' FENCE ;
set HDR-NFA here ", FENCE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FENCE' FENCE ;
\ ---- the heat registers (DECOMPOSITION.md section 7; #189) -----------------------
\ Captain Bob, 2026-11-12: "Add HEAT-OP". The node counts every instruction it
\ retires, by opcode, and the anti-clock ticks once for each; these read them.
\ ( op -- n ) how many times opcode op has retired; op is taken mod 32
set HDR-NFA here ", HEAT-OP@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HEAT-OP@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HEAT-OP@ 31 and HEAT-OP + b! @b ;
\ ( -- n ) the anti-clock: one tick per instruction retired
set HDR-NFA here ", ANTICLOCK@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ANTICLOCK@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ANTICLOCK@ ANTICLOCK b! @b ;
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
\ A vocabulary is two cells: its head -- the xt of its newest entry, or 0 --
\ and the address of the vocabulary defined before it, or 0. VOC-LINK holds
\ the newest one's address. FORTH's head is (LATEST) and it is in no chain.
set HDR-NFA here ", CONTEXT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CONTEXT' CONTEXT ;
set HDR-NFA here ", CURRENT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
set HDR-NFA here ", CONTEXT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CONTEXT' CONTEXT ;
set HDR-NFA here ", CURRENT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
set HDR-NFA here ", FORTH #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FORTH #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FORTH (LATEST) CONTEXT a! ! ;
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
set HDR-NFA here ", DEFINITIONS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFINITIONS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFINITIONS CONTEXT a! @ CURRENT a! ! ;
\ VOCABULARY xxx FORTH-79: xxx is a new, empty list of words; executing
\ xxx makes it the CONTEXT vocabulary. When a search of it finds nothing,
\ FORTH is searched.
: (DOVOC) pop CONTEXT a! ! ;
set HDR-NFA here ", VOCABULARY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VOCABULARY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VOCABULARY
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
0 , VOC-LINK a! @ , HERE -2 + VOC-LINK a! ! ;
@@ -53,7 +53,7 @@ set HDR-NFA here ", VOCABULARY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
F: drop drop $54524F46 (EMIT4) $48 (EMIT4) ;
\ ( -- ) as v3's, but true: where names are looked for, and where new ones go
set HDR-NFA here ", ORDER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ORDER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ORDER
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
CONTEXT a! @ dup (.VOC) SPACE
@@ -66,7 +66,7 @@ set HDR-NFA here ", ORDER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) the names in the CONTEXT vocabulary, the newest first, a blank after
\ each, a new line whenever one has passed column 64. Hidden entries -- a
\ definition under way -- are not shown. (Q)+0 is the column.
set HDR-NFA here ", WORDS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WORDS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WORDS
0 (Q) a! !
CONTEXT a! @ a! @
@@ -80,7 +80,7 @@ set HDR-NFA here ", WORDS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
WRAP: drop CR 0 (Q) a! !
NXT: -1 + a! @ jump L
DONE: drop jump CR
set HDR-NFA here ", VLIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VLIST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VLIST jump WORDS
\ ( cell -- ) take off a vocabulary's list every entry at or above the
@@ -97,7 +97,7 @@ set HDR-NFA here ", VLIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ goes is no longer CONTEXT or CURRENT: FORTH is. A word that is not there
\ is an error, and so is one below FENCE, which is where the capsule's own
\ words are (code 10, "Protected word").
set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FORGET #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FORGET
32 WORD (LOOKUP) if MISSING
-2 + a! @ \ where its name starts
@@ -116,7 +116,8 @@ 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.f18)
TOLD: (Q) a! @ 4* NAME> -4 + a! @ (NEXT-ID) a! ! \ their IDs are free again: the newest are
(Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.f18)
MISSING: drop (UNKNOWN) drop ;
\ ---- the system as a whole -------------------------------------------------------
@@ -125,21 +126,21 @@ set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: execute to be sure a FORTH-79 system is there. It is: nothing
\ happens. (v3's prints two lines and leaves a flag.)
set HDR-NFA here ", 79-STANDARD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 79-STANDARD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 79-STANDARD ;
\ ( -- ) which system this is, and its cell width
set HDR-NFA here ", VERSION #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VERSION #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VERSION
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
N-1 1 + 0 U-DOT-R $7469622D (EMIT4) CR ;
\ ( -- ) clear the screen and put the cursor at the top, as v3: ESC [2J ESC [H
set HDR-NFA here ", PAGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PAGE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PAGE 27 EMIT 91 EMIT 50 EMIT 74 EMIT 27 EMIT 91 EMIT 72 jump EMIT
\ ( -- ) as v3's message, and then ABORT: both stacks emptied, the prompt
set HDR-NFA here ", WARM #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WARM #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WARM
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $72206D65 (EMIT4) $61747365 (EMIT4) $64657472 (EMIT4) $2E (EMIT4) CR
@@ -148,11 +149,12 @@ set HDR-NFA here ", WARM #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) the system as it was when the capsule had just been loaded:
\ everything defined since is gone, there is one vocabulary, numbers are
\ decimal, the block buffers are empty. Then as WARM.
set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COLD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COLD
(BOOT) a! @ DP a! !
(BOOT)+1 a! @ (LATEST) a! !
(BOOT) a! @ 2/ 2/ FENCE a! !
(BOOT-ID) a! @ (NEXT-ID) 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.f18)
@@ -167,15 +169,15 @@ set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (DODEFER)
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
UNSET: drop NODE-ERROR b! 15 !b ;
set HDR-NFA here ", DEFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
: (is!) a! ! ;
: (defer@) a! @ ;
set HDR-NFA here ", IS #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IS #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IS
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
NOW: drop jump (is!)
set HDR-NFA here ", DEFER@ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFER@ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER@
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
NOW: drop jump (defer@)
capsules/v4/sys/words.f18
+49 -49
View File
@@ -11,57 +11,57 @@
\ (X) word address of four cells of scratch for COMPARE and SEARCH
\ ---- stack ----
set HDR-NFA here ", 2SWAP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2SWAP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
set HDR-NFA here ", 2OVER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2OVER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
set HDR-NFA here ", 2ROT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2ROT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
set HDR-NFA here ", 2>R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2>R SWAP push push ;
set HDR-NFA here ", 2R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R> pop pop SWAP ;
set HDR-NFA here ", 2R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R@ pop pop over over push push SWAP ;
set HDR-NFA here ", NOP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOP' nop ;
set HDR-NFA here ", TRUE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TRUE -1 ;
set HDR-NFA here ", FALSE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FALSE 0 ;
set HDR-NFA here ", INVERT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
set HDR-NFA here ", 2>R #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2>R SWAP push push ;
set HDR-NFA here ", 2R> #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R> pop pop SWAP ;
set HDR-NFA here ", 2R@ #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R@ pop pop over over push push SWAP ;
set HDR-NFA here ", NOP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOP' nop ;
set HDR-NFA here ", TRUE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TRUE -1 ;
set HDR-NFA here ", FALSE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FALSE 0 ;
set HDR-NFA here ", INVERT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
\ ---- memory ----
set HDR-NFA here ", 2@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2@ ( addr -- lo hi ) a! @+ @ ;
set HDR-NFA here ", 2! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
set HDR-NFA here ", -! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", -! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -! ( n addr -- ) a! NEGATE @ + ! ;
\ ---- comparison ----
set HDR-NFA here ", 0<> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 0<> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0<> if Z drop -1 ; Z: ;
set HDR-NFA here ", 0> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 0> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
set HDR-NFA here ", <> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <> xor jump 0<>
set HDR-NFA here ", <= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <= GREATER jump 0=
set HDR-NFA here ", >= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >= LESS jump 0=
set HDR-NFA here ", U< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U< over over xor -if SAME drop NIP jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", U> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U> SWAP jump U<
set HDR-NFA here ", ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABS -if P inv 1 + P: ;
set HDR-NFA here ", MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
set HDR-NFA here ", MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
set HDR-NFA here ", WITHIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WITHIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WITHIN ( n low high -- flag ) push over pop LESS push LESS inv pop and ;
\ ---- shifts ----
\ As v3, a count that is negative or as large as the cell is wide is an
\ error (code 9, "Shift count out of range").
set HDR-NFA here ", LSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LSHIFT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LSHIFT ( x n -- x' )
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
@@ -69,7 +69,7 @@ set HDR-NFA here ", LSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
set HDR-NFA here ", RSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", RSHIFT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: RSHIFT ( x n -- x' ) \ zeros come in at the top
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
@@ -79,23 +79,23 @@ set HDR-NFA here ", RSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
BAD: drop drop NODE-ERROR b! 9 !b ;
\ ---- doubles and mixed ----
set HDR-NFA here ", D- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D- DNEGATE jump D+
set HDR-NFA here ", DABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DABS -if P jump DNEGATE P: ;
set HDR-NFA here ", D0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0= OR jump 0=
set HDR-NFA here ", D0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D0< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0< push drop pop jump 0<
set HDR-NFA here ", D= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D= D- jump D0=
set HDR-NFA here ", D2* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D2* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
set HDR-NFA here ", D2/ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D2/ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2/ push a! 0 pop +* push drop a pop ;
set HDR-NFA here ", M+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M+ S>D jump D+
set HDR-NFA here ", M- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M- S>D DNEGATE jump D+
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
@@ -110,18 +110,18 @@ set HDR-NFA here ", M- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
LS: drop push inv pop + inv
S2: -if N2 drop -1 jump D2 N2: drop 0
D2: pop pop ROT ;
set HDR-NFA here ", D< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D< (D<) push drop drop drop drop pop ;
set HDR-NFA here ", DMAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DMAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
set HDR-NFA here ", DMIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DMIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
\ ---- strings and memory ----
set HDR-NFA here ", ?TERMINAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ?TERMINAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
set HDR-NFA here ", CMOVE> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CMOVE> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CMOVE> ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE -1 + push
@@ -131,31 +131,31 @@ set HDR-NFA here ", CMOVE> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop drop drop ;
\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
set HDR-NFA here ", MOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MOVE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MOVE ( addr1 addr2 n -- )
-if OK drop drop drop ;
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
set HDR-NFA here ", FILL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FILL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FILL ( baddr u c -- )
SWAP push SWAP pop \ c baddr u
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push over over C! 1 + pop -1 + jump OK
DONE: drop drop drop ;
set HDR-NFA here ", ERASE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ERASE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ERASE ( baddr u -- ) 0 jump FILL
set HDR-NFA here ", BLANK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BLANK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BLANK ( baddr u -- ) 32 jump FILL
set HDR-NFA here ", -TRAILING #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", -TRAILING #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -TRAILING ( baddr u -- baddr u' )
-if L drop 0 ;
L: if DONE over over + -1 + C@ -32 + if SP drop ;
SP: drop -1 + jump L
DONE: ;
set HDR-NFA here ", COMPARE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COMPARE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COMPARE ( a1 u1 a2 u2 -- n )
-if A drop 0 A: (X)+1 b! !b
SWAP -if B drop 0 B: dup (X) b! !b
@@ -173,7 +173,7 @@ set HDR-NFA here ", COMPARE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
NN: if ZZ drop 1 ;
ZZ: ;
set HDR-NFA here ", SEARCH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEARCH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
-if A drop 0 A: (X)+1 b! !b (X) b! !b
-if B drop 0 B: dup (X)+3 b! !b over (X)+2 b! !b
@@ -186,14 +186,14 @@ set HDR-NFA here ", SEARCH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
SAME: drop 1 + push 1 + pop pop -1 + jump I
MATCH: drop drop drop -1 ;
set HDR-NFA here ", SCAN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SCAN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SCAN ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if FOUND
drop push 1 + pop -1 + jump L
FOUND: drop
DONE: pop drop ;
set HDR-NFA here ", SKIP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SKIP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SKIP ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if SAME drop jump DONE
docs/fabric/FABRIC-3.md
+23
View File
@@ -6646,3 +6646,26 @@ and memorize frequently so we can pick up where we left off").
it `6 7 * .`, it answers 42; `11 KILL`; the Stadium CONSERVED after.
- **Next:** Phase 2, the word accounts at `call` -- the kernel's record per word, fed by the hook
(A1); then Phase 7, the loops on those records. And retiring v3 as a boot target (#156).
### 24. #189 Phase 2: the word accounts at `call` (2026-11-13)
- **Rulings** (plan `2026-11-13-engine-step4-phase2-word-accounts.md`): the word ID is "ID field in
the header"; words are charged "Per heartbeat tick", as the opcodes are; the ACL is "All of it in
Phase 4".
- **The ID** sits at xt−4, before the flags. The system's words are numbered as they are assembled,
by a new directive, `#id,`, in both assemblers: the C one, and the machine ROM's, which counts in
the system's own `(NEXT-ID)`, zero when the machine starts. `(HEADER)` numbers later words. FORGET
removes the newest entries, so it frees the highest IDs; it sets `(NEXT-ID)` back, and they are
used again, as v3 recycles its word IDs. COLD goes back to the system's count.
- **The records.** The node tells the kernel of each entry made and gone (`ENGINE.md` 3b): two system
words, `(TELL-DEFINED)` and `(TELL-FORGOTTEN)`, send requests −19 and −20 on port 0. The kernel
puts them in `(WORD-DEFINED)`/`(WORD-FORGOTTEN)` when it seals a node, and reads the system's own
words once. One bit per address marks a word's xt, since calls to the ROM and to headerless code
are not words. At `call`, the bit is tested and the record counts one. Once a tick, the calls since
are charged to the Stadium (`stadium_words_charge`: N dispatches at once, shared by calls when the
reservoir runs short). FORGET makes the Stadium forget the patron before its ID is used again.
- **Seen on amd64:** after POST, `Stadium words: promotions=141`, CONSERVED; POST 539/539;
`word_count=377` (the two telling words); `dict_hash` changed once, for the new cell. The boot took
142 s against Phase 1's 153 s: no measurable cost.
- **Next:** Phase 7, the loops on these records (decay, the rolling window, pipelining, inference,
L8).
docs/reference/v4-dictionary.tsv
+2
View File
@@ -18,6 +18,8 @@
(REFUSED) ( -- addr ) Variable: a count of the messages that came back to this node, refused.
(S") ( -- baddr u ) The run time of S": leave the address and length of the string compiled after the call.
(SEAL) ( -- ) What is in the dictionary now is the system: COLD returns to it and FORGET will not go below it.
(TELL-DEFINED) ( xt -- ) Tells the kernel that an entry has been made, with its code at xt (request -19 on port 0). The kernel puts it in (WORD-DEFINED) when it seals a node.
(TELL-FORGOTTEN) ( w -- ) Tells the kernel that every entry from word address w up has gone (request -20 on port 0). The kernel puts it in (WORD-FORGOTTEN) when it seals a node.
(UD) ( -- addr ) Variable: U/MOD's divisor while it divides (forth79.4th).
(WORD-DEFINED) ( -- addr ) Variable: the hook told when an entry is made, with the xt its code will be at.
(WORD-FORGOTTEN) ( -- addr ) Variable: the hook told when entries are forgotten, with the word address they went from.
Can't render this file because it contains an unexpected character in line 10 and column 3.
docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md
+137
View File
@@ -0,0 +1,137 @@
# ENGINE Step 4, Phase 2: word accounts at `call` -- Plan
> **For agentic workers:** steps use checkbox (`- [ ]`) syntax. One QEMU at a time, in the foreground,
> every boot under `timeout 570` (`.claude/CLAUDE.md`, `.claude/memory/rules.md`); every log and CSV
> is committed. Test first: each change starts with a failing test.
**Goal (#189):** the kernel keeps a record for each word on each node, joined to the word by the word
ID in its header (`ENGINE.md` 3b, ruled 2026-10-05: "A is good"). Each `call` to a word counts on its
record (`execution_heat`), and the Stadium's word layer is fed from the records, so that the Stadium
holds a node's words as it holds v3's (`V3-PARITY.md` §1 row 3, in part).
**Parent plan:** `2026-10-20-engine-step4-node-in-the-vms-place.md`, Phase 2; after Phase 1
(`2026-11-13-engine-step4-phase1-v4-in-the-kernels-boot.md`, accepted 2026-11-13, protocol PASS on
046ce0be). Q4 (RULED 2026-10-20, as recommended): the kernel keeps, per node and word ID, a record with
`DictEntry`'s account fields; `stadium_word_dispatch` takes a VM ID and a word ID.
## Rulings (Captain Bob, 2026-11-13)
1. **The word ID is a field in the header** -- not a kernel table keyed by address, and not every call
target. (Matches 3b: "its word ID in its header".)
2. **Charged per heartbeat tick**, as the opcodes are (Phase 1, Q2): a call only counts; once a tick
the words called since are charged to the Stadium.
3. **The ACL is all Phase 4**: no ACL fields or countdown in Phase 2.
## The design
**An entry gains one cell, its word ID, before its flags.** Today (`dict.f18`):
name | xt-3 flags | xt-2 the name's address | xt-1 the link | xt the code
becomes
name | xt-4 word ID | xt-3 flags | xt-2 the name's address | xt-1 the link | xt the code
Every offset from the xt stays as it is; only the name moves one cell further from the code (`NAME>`,
`TRAVERSE`, `(NEED)`: 12 bytes become 16).
**Who numbers the words.**
- The system's words are numbered by the assembler, in the order they are assembled, from 0, with a
new directive `#id,`: it lays down the next number and counts on. The 313 assembled headers
(`... #, 0 #, HDR-NFA #, HDR-LINK ...`) gain `#id,` before their flags. The count is stored in
a new variable, `(NEXT-ID)`.
- A word defined later is numbered by `(HEADER)`, from `(NEXT-ID)`.
- FORGET takes away the newest entries, so the IDs it frees are the highest: it sets `(NEXT-ID)`
back to the first gone entry's ID, and they are used again, as v3 recycles its word IDs. COLD sets
it back to the system's count.
- The same numbering on every node and at either cell width; no kernel needed (the hosted product
numbers alike). `dict_hash` changes once, for the new cell; `word_count` does not.
**How the kernel knows a called address is a word.** Many calls are to ROM routines and headerless
code (189 of the system's definitions have no header), whose cell at xt-4 is not an ID. So the kernel
keeps, per node, one bit for each address of its memory: set for a word's xt. Its records are kept by
word ID. Both come from what the node tells it (3b, already in the system and unwired):
`(WORD-DEFINED)` (`dict.f18`), at `(HEADER)`, gives the xt; `(WORD-FORGOTTEN)`, at FORGET and COLD,
gives the word address from which entries went. The kernel attaches them with requests on port 0
(`kernel_take`). The system's own words, already in a node when it is sealed, are read once by
walking the dictionary from `LATEST`.
**At `call`** (Part A's hook, `v4_exec_state.on_call`): if the target's bit is set, the record of the
ID at target-4 counts one: `execution_heat`, and its calls since the last charge. A bit test and an
increment: nothing else at `call`.
**At the heartbeat tick** (where the opcodes are charged, `sk_v4_charge_opcodes`): for each node, the
words called since are charged to the Stadium under the node's key -- new
`stadium_words_charge(vm, word_id, calls, tick)`, which is `stadium_word_dispatch` for that many calls
at once: cooling by the ticks since, a quantum a call, the reservoir's third left, and when the calls
want more than there is, a share in proportion to the calls (as `stadium_ops_charge`, #189).
**When words go:** FORGET and COLD drop the records and bits of the entries gone, and
`stadium_word_forget` each (v3's coherence on recycling). A kill already evicts every resident of the
node's quota (`stadium_return_quota`); the records go with the node.
## Tasks
### Task 1: `#id,` in the assembler
- [x] Test first (`v4/tests/test_text.c`): `#id,` lays down 0, 1, 2 in order; a symbol gives the count.
- [x] `v4/src/text.c`: the directive and the counter (reset per text).
### Task 2: the header's word-ID cell
- [x] Tests first: the host dictionary tests (`test_host_dict.c`): a word's ID at xt-4; a word defined
at the prompt gets the next ID; FORGET gives its IDs back; COLD resets; `NAME>` and `TRAVERSE`
across the new cell.
- [x] `capsules/v4/sys/*.f18`: `#id,` in the 313 headers; `dict.f18`: `(NEED)`, `(HEADER)`, `NAME>`,
`TRAVERSE`, `(NEXT-ID)`; `system.f18`: FORGET and COLD; `map-32.f18`/`map-64.f18` and `mkmap.c`:
`(NEXT-ID)`'s address.
- [x] `make -C v4 test test-32`; the POST expectations and the hosted products updated for the new
`dict_hash` (word_count 375 unchanged).
### Task 3: the kernel's records
- [x] Test first (`v4/tests/test_mesh_boot.c`, and a kernel host test): after the boot every system
word has a record and a bit; `: SQ DUP * ;` makes one more; `3 SQ` counts SQ once; FORGET SQ
drops it; a call to a headerless routine counts nothing.
- [x] `v4/system/mesh.c`: the requests behind `(WORD-DEFINED)`/`(WORD-FORGOTTEN)`, the walk at seal,
the bits and records per place, the hook at `call`. Records sized by `(NEXT-ID)`, in the owner's
memory.
### Task 4: the Stadium charge per tick
- [x] Test first (`kernel/tests/test_stadium_words.c`): `stadium_words_charge` for N calls equals N
dispatches when there is enough; shares by calls when there is not; conservation.
- [x] `kernel/src/vm/stadium_words.c`: `stadium_words_charge`; `kernel/src/v4/sk_v4.c`: charge every
node's words at the tick, beside its opcodes; `stadium_word_forget` on FORGET.
- [x] `scripts/qemu_session.py`: after POST, "Stadium words: N resident" with N > 0, and conservation
CONSERVED; a word defined at the prompt and called becomes resident.
### Task 5: acceptance
- [x] The boot's time before and after (Review focus 3), in the commit message.
- [ ] The full protocol; `docs/v4.0.0/ENGINE.md`, this plan, `FABRIC-3.md` XLVIII.24.
## As built (2026-11-13)
- Tasks 1-4 done, test first: `test_text.c` (`#id,`, `#ids`, the header's ID), `test_host_dict.c` and
`test_host_quit.c` (the layout, numbering, FORGET giving IDs back, COLD), `test_mesh_boot.c` (44
checks: records, calls at the prompt, in definitions and through `EXECUTE`, the charge, FORGET,
every word on Hera kept, a born node's own), `kernel/tests/test_stadium_words.c` (the charge equal
to that many dispatches; cooling; the floor; conservation).
- The ROM's assembler counts in the system's `(NEXT-ID)`, zero when the machine starts, so no ROM
variable was added.
- The telling words are `(TELL-DEFINED)` and `(TELL-FORGOTTEN)`, requests −19 and −20; the kernel
puts them in the hook variables when it seals a node, so the hosted product, which keeps no
records, never tells.
- amd64: `Stadium words: promotions=141` after POST, CONSERVED; `word_count=377`; the boot 142 s
(Phase 1: 153 s).
## Review focus
1. **A headerless call is not a word:** only an xt the node told of has its bit.
2. **Recycling:** an ID freed by FORGET and used again starts from nothing in the Stadium
(`stadium_word_forget` before the reuse).
3. **Cost at `call`:** a bit test and an increment; the boot's time under TCG recorded before and after.
4. **The 32-bit build:** the same IDs and the same counts at 32-bit cells.
5. **The Stadium's bound:** its word layer holds word IDs below `DICTIONARY_SIZE` (1024); the system
has 375 words. An ID above it is counted on its record but not admitted; reported if reached.
## What this phase does not do
The ACL (Phase 4, ruled). Decay, the rolling window, pipelining, inference, L8 on the records
(Phase 7). The transition metrics (Phase 7, with the loops that read them).
experiments/bare_metal/runs/doe-amd64-20261113-182316.csv
View File
kernel/include/starkernel/vm/stadium_words.h
+13
View File
@@ -130,6 +130,19 @@ void stadium_word_dispatch(VMUuid vm_id, uint32_t word_id, uint64_t heartbeat_ti
*/
void stadium_word_forget(VMUuid vm_id, uint32_t word_id);
/*
* stadium_words_charge - a v4 node's words, charged once a heartbeat tick (#189, plan
* 2026-11-13-engine-step4-phase2, Task 4; Captain Bob, 2026-11-13: "Per heartbeat tick"). For each of
* the `count` words, calls[k] calls of word ids[k] since the last charge are calls[k] of
* stadium_word_dispatch()'s dispatches at `heartbeat_ticks`: a resident word cools by the ticks since,
* once; a word not resident is admitted as Option B admits it; each call pulls
* STADIUM_WORD_HEAT_QUANTUM, never leaving the reservoir below a third. When the calls want more than
* that leaves, it is shared among the words in proportion to their calls -- not taken by whichever
* word is charged first (as stadium_ops_charge). Conservation holds.
*/
void stadium_words_charge(VMUuid vm_id, const uint32_t *ids, const uint64_t *calls, uint32_t count,
uint64_t heartbeat_ticks);
/*
* stadium_words_resident_heat - Sum of heat held by vm_id's own
* word-execution residents only (item 4.1's cells, tracked in this file's
kernel/src/v4/sk_v4.c
+45
View File
@@ -72,6 +72,32 @@ static v4_fabric_node sk_v4_nucleus, sk_v4_hera;
static v4_image sk_v4_image;
static v4_cell sk_v4_keyed[SK_V4_PLACES]; /* by place: the number its Stadium quota is keyed by; 0: none */
/* The words' accounts (#189, Phase 2; v4/mesh.h): each node's records, kept by word ID, and the bit for each
* address that is a word's xt -- from the kernel's heap at the boot -- and a tick's charge gathered. */
static uint32_t sk_v4_charge_ids[V4_MESH_WORD_IDS];
static uint64_t sk_v4_charge_calls[V4_MESH_WORD_IDS];
static uint32_t sk_v4_charge_n;
static void sk_v4_charge_one(void *ctx, v4_cell id, v4_uheat_t calls)
{
(void)ctx;
if (sk_v4_charge_n < V4_MESH_WORD_IDS) {
sk_v4_charge_ids[sk_v4_charge_n] = (uint32_t)id;
sk_v4_charge_calls[sk_v4_charge_n] = (uint64_t)calls;
sk_v4_charge_n++;
}
}
/* a word has gone: its ID will be used again, so the Stadium forgets its patron first (v3's coherence) */
static void sk_v4_forgot(void *self, unsigned place, v4_cell id)
{
(void)self;
#ifdef STARFORTH_ENABLE_VM
if (place < SK_V4_PLACES && sk_v4_keyed[place] != 0)
stadium_word_forget(stadium_node_key((uint32_t)sk_v4_keyed[place]), (uint32_t)id);
#else
(void)place; (void)id;
#endif
}
static v4_fabric_node *sk_v4_room(void *self)
{
v4_fabric_node *x = (v4_fabric_node *)kmalloc(sizeof *x);
@@ -142,6 +168,11 @@ void sk_v4_charge_opcodes(void)
sk_v4_keyed[k] = number;
}
stadium_ops_charge(stadium_node_key((uint32_t)number), x->h.op, now);
/* and its words, by their calls since (#189, Phase 2: "Per heartbeat tick") */
sk_v4_charge_n = 0;
v4_mesh_charge(&sk_v4_mesh, k, sk_v4_charge_one, 0);
if (sk_v4_charge_n)
stadium_words_charge(stadium_node_key((uint32_t)number), sk_v4_charge_ids, sk_v4_charge_calls, sk_v4_charge_n, now);
}
#endif
}
@@ -264,6 +295,20 @@ void sk_v4_boot(void (*chain)(void), const BootDisk *boot_disk)
sk_v4_mesh.nucleus = &sk_v4_nucleus; sk_v4_mesh.hera = &sk_v4_hera;
sk_v4_mesh.room = sk_v4_room; sk_v4_mesh.unroom = sk_v4_unroom;
sk_v4_mesh.born = 0; sk_v4_mesh.gone = sk_v4_gone; sk_v4_mesh.parity = sk_v4_parity;
sk_v4_mesh.accounts = (v4_mesh_account *)kmalloc((size_t)SK_V4_PLACES * V4_MESH_WORD_IDS * sizeof(v4_mesh_account));
sk_v4_mesh.is_word = (unsigned char *)kmalloc((size_t)SK_V4_PLACES * (V4_NODE_WORDS / 8u));
if (!sk_v4_mesh.accounts || !sk_v4_mesh.is_word) { /* no records kept: the words are not charged */
if (sk_v4_mesh.accounts) kfree(sk_v4_mesh.accounts);
if (sk_v4_mesh.is_word) kfree(sk_v4_mesh.is_word);
sk_v4_mesh.accounts = 0; sk_v4_mesh.is_word = 0;
console_println("StarForth v4: no room for the words' accounts; words are not charged");
} else { /* none kept yet: all zero */
unsigned char *z = (unsigned char *)sk_v4_mesh.accounts;
size_t i, n = (size_t)SK_V4_PLACES * V4_MESH_WORD_IDS * sizeof(v4_mesh_account);
for (i = 0; i < n; i++) z[i] = 0;
for (i = 0; i < (size_t)SK_V4_PLACES * (V4_NODE_WORDS / 8u); i++) sk_v4_mesh.is_word[i] = 0;
}
sk_v4_mesh.forgot = sk_v4_forgot;
sk_v4_mesh.out = sk_v4_out; sk_v4_mesh.key = sk_v4_key;
sk_v4_mesh.words = sk_v4_words; sk_v4_mesh.word_count = sizeof sk_v4_words / sizeof sk_v4_words[0];
sk_v4_mesh.serve = sk_v4_serve;
kernel/src/vm/stadium_words.c
+68
View File
@@ -263,6 +263,74 @@ void stadium_word_dispatch(VMUuid vm_id, uint32_t word_id, uint64_t heartbeat_ti
}
}
void stadium_words_charge(VMUuid vm_id, const uint32_t *ids, const uint64_t *calls, uint32_t count,
uint64_t heartbeat_ticks) {
int slot;
uint32_t k;
uint64_t total = 0, want, pullable, avail, floor = Q48_ONE / 3;
unsigned shift = 0;
const uint64_t q = (uint64_t)STADIUM_WORD_HEAT_QUANTUM;
if (!words_initialized || !ids || !calls) return;
slot = stadium_quota_slot_for_vm(vm_id);
if (slot < 0) return;
/* First: every resident word charged now cools by the ticks since its own last, once, as its first
* dispatch would; and the calls in all. */
for (k = 0; k < count; k++) {
size_t cell;
if (calls[k] == 0 || ids[k] == WORD_ID_INVALID || ids[k] >= DICTIONARY_SIZE) continue;
total = (total + calls[k] < total) ? UINT64_MAX : total + calls[k];
cell = resolve_resident_cell(slot, ids[k]);
if (cell != STADIUM_CELL_NONE) {
StadiumPatronHeader *h = &stadium_cells()[cell].header;
uint64_t elapsed = heartbeat_ticks - word_slots[slot][ids[k]].last_decay_tick;
if (elapsed > 0) {
uint64_t cooled = ((h->heat * (uint64_t)STADIUM_WORD_COOL_RATE_Q48) >> 16) * elapsed;
if (cooled > h->heat) cooled = h->heat;
if (cooled > 0) { h->heat -= cooled; stadium_reservoir_push(vm_id, cooled); }
word_slots[slot][ids[k]].last_decay_tick = heartbeat_ticks;
}
}
}
if (total == 0) return;
/* Then: a quantum a call, or, when they want more than the floor leaves, a share by calls. */
avail = stadium_reservoir_peek(vm_id);
pullable = avail > floor ? avail - floor : 0;
want = total > UINT64_MAX / q ? UINT64_MAX : total * q;
while ((total >> shift) >= ((uint64_t)1 << 32)) shift++; /* pullable * share fits 64 bits */
for (k = 0; k < count; k++) {
uint64_t give;
size_t cell;
if (calls[k] == 0 || ids[k] == WORD_ID_INVALID || ids[k] >= DICTIONARY_SIZE) continue;
give = want <= pullable ? calls[k] * q
: (total >> shift) ? pullable * (calls[k] >> shift) / (total >> shift) : 0;
give = word_dispatch_pull(vm_id, give);
cell = resolve_resident_cell(slot, ids[k]);
if (cell != STADIUM_CELL_NONE) { stadium_cells()[cell].header.heat += give; continue; }
{
StadiumPatronHeader candidate;
uint8_t *raw = (uint8_t *)&candidate;
size_t i, idx;
for (i = 0; i < sizeof(candidate); i++) raw[i] = 0;
candidate.identity = (uint64_t)ids[k];
candidate.heat = give;
candidate.ttl = 0;
candidate.link = 0;
candidate.contains = STADIUM_CONTAINS_NONE;
candidate.mass = 1;
candidate.flags = 0;
candidate.behaviour = (uint8_t)STADIUM_BEHAVIOUR_COOL;
idx = stadium_admit(vm_id, &candidate);
if (idx == STADIUM_CELL_NONE) { stadium_reservoir_push(vm_id, give); continue; }
word_slots[slot][ids[k]].cell_index = idx;
word_slots[slot][ids[k]].last_decay_tick = heartbeat_ticks;
stat_promotions[slot]++;
}
}
}
void stadium_word_forget(VMUuid vm_id, uint32_t word_id) {
int slot;
size_t cell;
kernel/tests/Makefile
+3 -1
View File
@@ -19,9 +19,11 @@ CC ?= cc
CFLAGS := -std=c99 -Wall -Wextra -Werror -O2 -g -I$(HERE) -I$(ROOT)/kernel/include \
-I$(ROOT)/kernel/include/starkernel -I$(ROOT)/v3/include
TESTS := test_gpt test_usb_config test_sk_v4_stop test_sk_v4_slots test_sk_v4_mint test_sk_v4_identity test_heartbeat_export test_ssm_jacquard test_physics_l2 test_stadium_node test_stadium_ops
TESTS := test_gpt test_usb_config test_sk_v4_stop test_sk_v4_slots test_sk_v4_mint test_sk_v4_identity test_heartbeat_export test_ssm_jacquard test_physics_l2 test_stadium_node test_stadium_ops test_stadium_words
SRC_test_stadium_ops := $(ROOT)/kernel/src/vm/stadium_ops.c $(ROOT)/kernel/src/vm/stadium.c $(ROOT)/kernel/src/vm/session.c $(ROOT)/kernel/src/capsule/vm_uuid.c
EXTRA_test_stadium_ops := -D__STARKERNEL__
SRC_test_stadium_words := $(ROOT)/kernel/src/vm/stadium_words.c $(ROOT)/kernel/src/vm/stadium.c $(ROOT)/kernel/src/vm/session.c $(ROOT)/kernel/src/capsule/vm_uuid.c
EXTRA_test_stadium_words := -D__STARKERNEL__
SRC_test_stadium_node := $(ROOT)/kernel/src/vm/stadium.c $(ROOT)/kernel/src/vm/session.c $(ROOT)/kernel/src/capsule/vm_uuid.c
EXTRA_test_stadium_node := -D__STARKERNEL__
SRC_test_physics_l2 := $(ROOT)/v3/src/physics_execution_hooks.c
kernel/tests/test_stadium_words.c
+90
View File
@@ -0,0 +1,90 @@
/* SPDX-License-Identifier: LicenseRef-Starship-1.0
* Copyright (c) 2023-2026 Robert A. James
*/
/* test_stadium_words.c -- stadium_words_charge on the host (#189, plan 2026-11-13-engine-step4-phase2,
* Task 4): a v4 node's words charged to the Stadium once a heartbeat tick (Captain Bob, 2026-11-13: "Per
* heartbeat tick"). N calls of a word are N of stadium_word_dispatch's dispatches -- the same quantum,
* the same floor left in the reservoir, the same cooling by the ticks since -- and when the words
* called want more than there is, what there is is shared by their calls, not taken by whichever is
* charged first. Conservation holds throughout.
*/
#include "harness.h"
#include "starkernel/vm/stadium.h"
#include "starkernel/vm/stadium_words.h"
#include "starkernel/session.h"
#include "starkernel/vm_uuid.h"
#include "starkernel/kmalloc.h"
#include "starkernel/q48_16.h"
#include "starforth_config.h"
#include <stdarg.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
void *kmalloc(size_t size) { return calloc(1, size); }
void kfree(void *ptr) { free(ptr); }
kmalloc_stats_t kmalloc_get_stats(void)
{
kmalloc_stats_t s;
memset(&s, 0, sizeof s);
s.free_bytes = 512u * 1024u * 1024u;
return s;
}
void log_message(int level, const char *fmt, ...) { (void)level; (void)fmt; }
void sk_hal_panic(const char *message) { printf("PANIC: %s\n", message); exit(2); }
int blk_flush(uint32_t block_num) { (void)block_num; return 0; }
int main(void)
{
VMUuid a = stadium_node_key(10);
uint64_t q = (uint64_t)STADIUM_WORD_HEAT_QUANTUM, r0, pullable;
uint32_t ids[3];
uint64_t calls[3];
CHECK(stadium_boot_init_for(a) == 0 && session_boot_init() == 0 && stadium_birth_node(a, "Hera") == 0,
"a Stadium with the node born in it");
stadium_words_init();
/* the same as that many dispatches: word 7 charged five calls, word 8 dispatched five times */
ids[0] = 7; calls[0] = 5;
r0 = stadium_reservoir_peek(a);
stadium_words_charge(a, ids, calls, 1, 2);
CHECK(stadium_reservoir_peek(a) == r0 - 5u * q && stadium_words_resident_heat(a) == 5u * q,
"five calls of word 7 pull five quanta, and it holds them: %llu", (unsigned long long)(r0 - stadium_reservoir_peek(a)));
{
unsigned k;
r0 = stadium_reservoir_peek(a);
for (k = 0; k < 5; k++) stadium_word_dispatch(a, 8, 2);
CHECK(stadium_reservoir_peek(a) == r0 - 5u * q && stadium_words_resident_heat(a) == 10u * q,
"the same as five dispatches of a word");
}
CHECK(stadium_conserved(a), "conservation holds");
/* a resident word cools by the ticks since, once, then takes its calls: as its dispatches would */
{
uint64_t before = stadium_words_resident_heat(a);
ids[0] = 7; calls[0] = 2;
stadium_words_charge(a, ids, calls, 1, 12);
ids[0] = 8; calls[0] = 1;
stadium_word_dispatch(a, 8, 12); stadium_word_dispatch(a, 8, 12);
CHECK(stadium_words_resident_heat(a) < before + 4u * q, "ten ticks on, both cooled before they took their calls");
CHECK(stadium_conserved(a), "conservation holds");
}
/* no calls, nothing */
ids[0] = 9; calls[0] = 0;
r0 = stadium_reservoir_peek(a);
stadium_words_charge(a, ids, calls, 1, 3);
CHECK(stadium_reservoir_peek(a) == r0, "a word with no calls is not charged");
/* more wanted than there is: shared by calls, the floor left */
pullable = stadium_reservoir_peek(a) - Q48_ONE / 3;
ids[0] = 20; calls[0] = 3 * (pullable / q);
ids[1] = 21; calls[1] = 1 * (pullable / q);
stadium_words_charge(a, ids, calls, 2, 4);
CHECK(stadium_reservoir_peek(a) >= Q48_ONE / 3 && stadium_reservoir_peek(a) - Q48_ONE / 3 < 4u,
"the reservoir is left at its third");
CHECK(stadium_conserved(a), "conservation holds when the calls want more than there is");
return DONE();
}
logs/20261113-182316/amd64/README.md
+1
View File
@@ -0,0 +1 @@
Development boot, not acceptance evidence (2026-11-13): the amd64 boot that checked #189 Phase 2 on bare metal. Every session check passed (RESULT: PASS), including "the Stadium: Hera's words admitted after POST" (Stadium words: promotions=141, CONSERVED). POST 539/539, word_count=377. The boot took 142 s (Phase 1: 153 s). The protocol run is the evidence.
logs/20261113-182316/amd64/qemu-amd64-20261113-182316.log
LFS
BIN
View File
Binary file not shown.

Some files were not shown because too many files have changed in this diff Show More