From e8e7ec8b9fbbb97666af880a467893f9d722ddb5 Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 13 Nov 2026 19:12:44 +0000 Subject: [PATCH] feat(v4): word accounts at call -- the word ID in the header, the kernel's records, the Stadium charged per tick (#189) 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 Claude-Session: https://claude.ai/code/session_017RzZgrf7V7Zk2iczBXDRbm --- capsules/v4/rom/dir.f18 | 21 ++- capsules/v4/rom/sym.f18 | 2 +- capsules/v4/rom/word.f18 | 2 +- capsules/v4/sys/acl.f18 | 26 ++-- capsules/v4/sys/blocks.f18 | 24 +-- capsules/v4/sys/compile.f18 | 70 ++++----- capsules/v4/sys/core.f18 | 24 +-- capsules/v4/sys/dict.f18 | 59 +++++--- capsules/v4/sys/end.f18 | 3 + capsules/v4/sys/forth.f18 | 114 +++++++-------- capsules/v4/sys/input.f18 | 18 +-- capsules/v4/sys/log.f18 | 36 ++--- capsules/v4/sys/map-32.f18 | 2 + capsules/v4/sys/map-64.f18 | 2 + capsules/v4/sys/numout.f18 | 38 ++--- capsules/v4/sys/qmath.f18 | 46 +++--- capsules/v4/sys/quit.f18 | 55 +++---- capsules/v4/sys/system.f18 | 44 +++--- capsules/v4/sys/words.f18 | 98 ++++++------- docs/fabric/FABRIC-3.md | 23 +++ docs/reference/v4-dictionary.tsv | 2 + ...11-13-engine-step4-phase2-word-accounts.md | 137 ++++++++++++++++++ .../runs/doe-amd64-20261113-182316.csv | 0 kernel/include/starkernel/vm/stadium_words.h | 13 ++ kernel/src/v4/sk_v4.c | 45 ++++++ kernel/src/vm/stadium_words.c | 68 +++++++++ kernel/tests/Makefile | 4 +- kernel/tests/test_stadium_words.c | 90 ++++++++++++ logs/20261113-182316/amd64/README.md | 1 + .../amd64/qemu-amd64-20261113-182316.log | 3 + .../v4-checks/v4-checks-20261113-183851.log | 3 + scripts/qemu_session.py | 4 + v4/include/v4/image.h | 8 + v4/include/v4/mesh.h | 28 ++++ v4/include/v4/text.h | 1 + v4/src/image.c | 1 + v4/src/text.c | 17 ++- v4/system/mesh.c | 128 ++++++++++++++++ v4/tests/host_map.h | 7 + v4/tests/test_host_dict.c | 24 +-- v4/tests/test_host_quit.c | 17 ++- v4/tests/test_mesh_boot.c | 66 +++++++++ v4/tests/test_text.c | 29 +++- v4/tools/mkmap.c | 6 +- 44 files changed, 1060 insertions(+), 349 deletions(-) create mode 100644 docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md create mode 100644 experiments/bare_metal/runs/doe-amd64-20261113-182316.csv create mode 100644 kernel/tests/test_stadium_words.c create mode 100644 logs/20261113-182316/amd64/README.md create mode 100644 logs/20261113-182316/amd64/qemu-amd64-20261113-182316.log create mode 100644 logs/20261113-183851/v4-checks/v4-checks-20261113-183851.log diff --git a/capsules/v4/rom/dir.f18 b/capsules/v4/rom/dir.f18 index 37776625..4fc9330e 100644 --- a/capsules/v4/rom/dir.f18 +++ b/capsules/v4/rom/dir.f18 @@ -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 ; diff --git a/capsules/v4/rom/sym.f18 b/capsules/v4/rom/sym.f18 index 2193e8c4..0845428a 100644 --- a/capsules/v4/rom/sym.f18 +++ b/capsules/v4/rom/sym.f18 @@ -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 diff --git a/capsules/v4/rom/word.f18 b/capsules/v4/rom/word.f18 index c4f4e18f..9df19b8c 100644 --- a/capsules/v4/rom/word.f18 +++ b/capsules/v4/rom/word.f18 @@ -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) diff --git a/capsules/v4/sys/acl.f18 b/capsules/v4/sys/acl.f18 index 65e11120..f2db167d 100644 --- a/capsules/v4/sys/acl.f18 +++ b/capsules/v4/sys/acl.f18 @@ -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) ; diff --git a/capsules/v4/sys/blocks.f18 b/capsules/v4/sys/blocks.f18 index 2bf8be65..e2d63090 100644 --- a/capsules/v4/sys/blocks.f18 +++ b/capsules/v4/sys/blocks.f18 @@ -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 diff --git a/capsules/v4/sys/compile.f18 b/capsules/v4/sys/compile.f18 index 26d00aed..96f6fe66 100644 --- a/capsules/v4/sys/compile.f18 +++ b/capsules/v4/sys/compile.f18 @@ -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) diff --git a/capsules/v4/sys/core.f18 b/capsules/v4/sys/core.f18 index cb8aeb91..9ac0f3b3 100644 --- a/capsules/v4/sys/core.f18 +++ b/capsules/v4/sys/core.f18 @@ -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 diff --git a/capsules/v4/sys/dict.f18 b/capsules/v4/sys/dict.f18 index 5c3e3165..f005ecce 100644 --- a/capsules/v4/sys/dict.f18 +++ b/capsules/v4/sys/dict.f18 @@ -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 diff --git a/capsules/v4/sys/end.f18 b/capsules/v4/sys/end.f18 index 27b07514..ee86982b 100644 --- a/capsules/v4/sys/end.f18 +++ b/capsules/v4/sys/end.f18 @@ -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 diff --git a/capsules/v4/sys/forth.f18 b/capsules/v4/sys/forth.f18 index 8c98d4c6..a51b3517 100644 --- a/capsules/v4/sys/forth.f18 +++ b/capsules/v4/sys/forth.f18 @@ -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 ; diff --git a/capsules/v4/sys/input.f18 b/capsules/v4/sys/input.f18 index ed782c49..668d9df1 100644 --- a/capsules/v4/sys/input.f18 +++ b/capsules/v4/sys/input.f18 @@ -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 + ! ; diff --git a/capsules/v4/sys/log.f18 b/capsules/v4/sys/log.f18 index e4065878..7e5931ea 100644 --- a/capsules/v4/sys/log.f18 +++ b/capsules/v4/sys/log.f18 @@ -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) diff --git a/capsules/v4/sys/map-32.f18 b/capsules/v4/sys/map-32.f18 index 2e1288ce..ebf98cde 100644 --- a/capsules/v4/sys/map-32.f18 +++ b/capsules/v4/sys/map-32.f18 @@ -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 diff --git a/capsules/v4/sys/map-64.f18 b/capsules/v4/sys/map-64.f18 index a25fac24..9bea1e82 100644 --- a/capsules/v4/sys/map-64.f18 +++ b/capsules/v4/sys/map-64.f18 @@ -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 diff --git a/capsules/v4/sys/numout.f18 b/capsules/v4/sys/numout.f18 index 614b0920..a3a53066 100644 --- a/capsules/v4/sys/numout.f18 +++ b/capsules/v4/sys/numout.f18 @@ -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 diff --git a/capsules/v4/sys/qmath.f18 b/capsules/v4/sys/qmath.f18 index a7a2688c..70162ff5 100644 --- a/capsules/v4/sys/qmath.f18 +++ b/capsules/v4/sys/qmath.f18 @@ -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 diff --git a/capsules/v4/sys/quit.f18 b/capsules/v4/sys/quit.f18 index 0388b68b..a263d413 100644 --- a/capsules/v4/sys/quit.f18 +++ b/capsules/v4/sys/quit.f18 @@ -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 diff --git a/capsules/v4/sys/system.f18 b/capsules/v4/sys/system.f18 index d2760a82..5d755bc1 100644 --- a/capsules/v4/sys/system.f18 +++ b/capsules/v4/sys/system.f18 @@ -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@) diff --git a/capsules/v4/sys/words.f18 b/capsules/v4/sys/words.f18 index 08a8abdb..1753f238 100644 --- a/capsules/v4/sys/words.f18 +++ b/capsules/v4/sys/words.f18 @@ -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 diff --git a/docs/fabric/FABRIC-3.md b/docs/fabric/FABRIC-3.md index 51178b76..c29d0523 100644 --- a/docs/fabric/FABRIC-3.md +++ b/docs/fabric/FABRIC-3.md @@ -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). diff --git a/docs/reference/v4-dictionary.tsv b/docs/reference/v4-dictionary.tsv index f7b0fb63..b1ecc138 100644 --- a/docs/reference/v4-dictionary.tsv +++ b/docs/reference/v4-dictionary.tsv @@ -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. diff --git a/docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md b/docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md new file mode 100644 index 00000000..c9c2e506 --- /dev/null +++ b/docs/v4.0.0/plans/2026-11-13-engine-step4-phase2-word-accounts.md @@ -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). diff --git a/experiments/bare_metal/runs/doe-amd64-20261113-182316.csv b/experiments/bare_metal/runs/doe-amd64-20261113-182316.csv new file mode 100644 index 00000000..e69de29b diff --git a/kernel/include/starkernel/vm/stadium_words.h b/kernel/include/starkernel/vm/stadium_words.h index cc31f6b3..2f3e2a03 100644 --- a/kernel/include/starkernel/vm/stadium_words.h +++ b/kernel/include/starkernel/vm/stadium_words.h @@ -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 diff --git a/kernel/src/v4/sk_v4.c b/kernel/src/v4/sk_v4.c index c527bfb2..f448ee91 100644 --- a/kernel/src/v4/sk_v4.c +++ b/kernel/src/v4/sk_v4.c @@ -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; diff --git a/kernel/src/vm/stadium_words.c b/kernel/src/vm/stadium_words.c index 39fe75c8..465d1053 100644 --- a/kernel/src/vm/stadium_words.c +++ b/kernel/src/vm/stadium_words.c @@ -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; diff --git a/kernel/tests/Makefile b/kernel/tests/Makefile index 18d67824..0415166e 100644 --- a/kernel/tests/Makefile +++ b/kernel/tests/Makefile @@ -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 diff --git a/kernel/tests/test_stadium_words.c b/kernel/tests/test_stadium_words.c new file mode 100644 index 00000000..622b66d4 --- /dev/null +++ b/kernel/tests/test_stadium_words.c @@ -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 +#include +#include +#include + +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(); +} diff --git a/logs/20261113-182316/amd64/README.md b/logs/20261113-182316/amd64/README.md new file mode 100644 index 00000000..baf8d290 --- /dev/null +++ b/logs/20261113-182316/amd64/README.md @@ -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. diff --git a/logs/20261113-182316/amd64/qemu-amd64-20261113-182316.log b/logs/20261113-182316/amd64/qemu-amd64-20261113-182316.log new file mode 100644 index 00000000..8c0cd406 --- /dev/null +++ b/logs/20261113-182316/amd64/qemu-amd64-20261113-182316.log @@ -0,0 +1,3 @@ +version https://git-lfs.github.com/spec/v1 +oid sha256:bc5a5aa7db21f455123bd6591e3ff8a415ae271f92ff699720ccb98f5ec182d0 +size 9470 diff --git a/logs/20261113-183851/v4-checks/v4-checks-20261113-183851.log b/logs/20261113-183851/v4-checks/v4-checks-20261113-183851.log new file mode 100644 index 00000000..153d3b82 --- /dev/null +++ b/logs/20261113-183851/v4-checks/v4-checks-20261113-183851.log @@ -0,0 +1,3 @@ +version https://git-lfs.github.com/spec/v1 +oid sha256:411b196327f5f2ab7dfae752b052d9b440d5fa5356608760d37ad50f9cb907e0 +size 149926 diff --git a/scripts/qemu_session.py b/scripts/qemu_session.py index 218e7a8e..2a8fad0a 100755 --- a/scripts/qemu_session.py +++ b/scripts/qemu_session.py @@ -485,6 +485,10 @@ def physics(): check("the Stadium: its cells allocated", re.search(r"Stadium: \d+ cells", text()) is not None) check("the Stadium: conservation CONSERVED", wait_for(r"Stadium conservation: CONSERVED", 120)) check("the heartbeat: ticking", wait_for(r"Heartbeat: [1-9]\d* ticks", 120)) + # Phase 2 (#189): Hera's words are in the Stadium -- every call to a word counted on the kernel's record + # of it, joined by the word ID in its header, and charged after POST (Captain Bob, 2026-11-13) + check("the Stadium: Hera's words admitted after POST", + re.search(r"Stadium words: promotions=[1-9]\d*", text()) is not None) def registry(): diff --git a/v4/include/v4/image.h b/v4/include/v4/image.h index 613f67c5..370c5ca9 100644 --- a/v4/include/v4/image.h +++ b/v4/include/v4/image.h @@ -63,6 +63,14 @@ typedef struct { * (v4_image_seal). */ v4_cell boot_cells, fence; + /* the word IDs (#189, Phase 2): (NEXT-ID), the ID the next entry is given, and (BOOT-ID), what + * it was when the system was complete, which COLD comes back to (v4_image_seal sets it) */ + v4_cell next_id, boot_id; + + /* (WORD-DEFINED) and (WORD-FORGOTTEN): the xts of the words a node runs when an entry is made + * and when entries go, or 0 (dict.f18); a kernel that keeps records puts its own there */ + v4_cell word_defined, word_forgotten; + /* the block window: the word address of the slots the kernel copies * blocks into (v4/blocks.h) */ v4_cell block_window; diff --git a/v4/include/v4/mesh.h b/v4/include/v4/mesh.h index 6ca532b1..715f1afa 100644 --- a/v4/include/v4/mesh.h +++ b/v4/include/v4/mesh.h @@ -43,6 +43,21 @@ #define V4_MESH_CONSOLE 1 /* the console's number as a sender, and her port to it */ #define V4_MESH_NUCLEUS_CELLS (2u * V4_NODE_WORDS + 64u) +/* A WORD'S ACCOUNTS (#189, Phase 2; ENGINE.md 3b): the kernel's record of a word on a node, joined to + * it by the word ID in its header. The node tells the kernel of each entry made and of entries gone + * (dict.f18, (TELL-DEFINED) and (TELL-FORGOTTEN): requests V4_REQ_WORD_DEFINED and _FORGOTTEN on port + * 0); the kernel reads the system's own once, when the node is sealed. At every `call` to a word + * its record counts one: `calls` (v3's execution_heat) and `since`, which the owner takes and clears + * when it charges the Stadium (v4_mesh_charge; Captain Bob, 2026-11-13: "Per heartbeat tick"). */ +#define V4_MESH_WORD_IDS 1024u /* word IDs a record is kept for: v3's DICTIONARY_SIZE, the Stadium's bound */ +#define V4_REQ_WORD_DEFINED (-19) +#define V4_REQ_WORD_FORGOTTEN (-20) +typedef struct { + v4_uheat_t calls; /* every call since the word was defined */ + v4_uheat_t since; /* calls since the owner last charged them */ + v4_cell xt; /* the word's xt; 0: no word has this ID */ +} v4_mesh_account; + typedef struct v4_mesh v4_mesh; struct v4_mesh { /* ---- the owner's: set before v4_mesh_boot ---- */ @@ -72,6 +87,12 @@ struct v4_mesh { const char *const *capsules; unsigned capsule_count; v4_image *im; /* the map's description (v4_map_image), which the boot completes */ + /* the words' accounts: `capacity` x V4_MESH_WORD_IDS records, and `capacity` x V4_NODE_WORDS / 8 + * bytes, a bit for each address of a node: set for a word's xt (0: none kept) */ + v4_mesh_account *accounts; + unsigned char *is_word; + /* a word has gone, its ID free for the next: the owner forgets what it keeps by it (may be 0) */ + void (*forgot)(void *self, unsigned place, v4_cell id); void *self; /* ---- the mesh's own ---- */ @@ -106,6 +127,13 @@ int v4_mesh_tell(v4_mesh *ms, v4_cell node, const char *text, unsigned len); unsigned v4_mesh_step(v4_mesh *ms); int v4_mesh_busy(const v4_mesh *ms); +/* A word's record on the node in `place`, by its xt: 0 if that is not a word's xt. */ +const v4_mesh_account *v4_mesh_account_at(const v4_mesh *ms, unsigned place, v4_cell xt); + +/* For each word on the node in `place` called since the last charge: `each(ctx, id, calls)`, and its + * count since is cleared. */ +void v4_mesh_charge(v4_mesh *ms, unsigned place, void (*each)(void *ctx, v4_cell id, v4_uheat_t calls), void *ctx); + /* The node numbered `number`, or 0. */ v4_fabric_node *v4_mesh_node(const v4_mesh *ms, v4_cell number); diff --git a/v4/include/v4/text.h b/v4/include/v4/text.h index bb5e3982..5f8758dc 100644 --- a/v4/include/v4/text.h +++ b/v4/include/v4/text.h @@ -142,6 +142,7 @@ typedef struct { v4_cell latest; /* xt of the newest header, 0 if none */ v4_cell start; /* the word `start` named, -1 if none yet */ int header_pending; /* a header waits for its `:` */ + v4_cell next_id; /* the next word ID a header is given (#189, Phase 2) */ unsigned line; int failed; diff --git a/v4/src/image.c b/v4/src/image.c index ff59a6e6..f6a073e8 100644 --- a/v4/src/image.c +++ b/v4/src/image.c @@ -51,6 +51,7 @@ void v4_image_seal(v4_node *n, const v4_image *im) n->mem[im->boot_cells] = n->mem[im->dp]; n->mem[im->boot_cells + 1] = n->mem[im->latest]; n->mem[im->fence] = (n->mem[im->dp] + 3) / 4; + n->mem[im->boot_id] = n->mem[im->next_id]; } /* FNV-1a over the node's memory below HERE, a cell at a time, low byte diff --git a/v4/src/text.c b/v4/src/text.c index de2246c3..7e17c57b 100644 --- a/v4/src/text.c +++ b/v4/src/text.c @@ -70,6 +70,7 @@ static int is_reserved(const char *s) || strcmp(s, "FOR") == 0 || strcmp(s, "NEXT") == 0 || strcmp(s, "UNEXT") == 0 || strcmp(s, "header") == 0 || strcmp(s, "constant") == 0 || strcmp(s, "#,") == 0 || strcmp(s, "\",") == 0 || strcmp(s, "set") == 0 || strcmp(s, "here") == 0 + || strcmp(s, "#id,") == 0 || strcmp(s, "#ids") == 0 || strcmp(s, "store") == 0 || strcmp(s, "start") == 0 || flag_of(s) != 0; } @@ -197,7 +198,7 @@ static void lay_name(v4_text *t, const char *name) * out, in front of the word the next `:` starts: * the name: its count byte, then its characters, four bytes to a cell, * zero-padded to a whole cell - * flags, the name's word address, the link to the entry before + * its word ID (the next, #189 Phase 2), flags, the name's word address, the link to the entry before * and the code follows. */ static void header(v4_text *t, reader *r) { @@ -213,6 +214,7 @@ static void header(v4_text *t, reader *r) end_word(t); nfa = v4_asm_label(&t->as); lay_name(t, name); + put_cell(t, t->next_id++); put_cell(t, 0); put_cell(t, nfa); put_cell(t, t->latest); @@ -378,6 +380,7 @@ static int value_of(v4_text *t, const char *tok, v4_cell *out) const v4_text_symbol *s; int big; if (strcmp(tok, "here") == 0) { *out = v4_asm_label(&t->as); return 1; } + if (strcmp(tok, "#ids") == 0) { *out = t->next_id; return 1; } /* how many word IDs so far */ if (number_of(tok, out, &big)) { if (big) { fail(t, "number does not fit a cell", tok); return 0; } return 1; @@ -423,6 +426,15 @@ static void cell_directive(v4_text *t, reader *r) check_asm(t, "#,"); } +/* `#id,`: the next word ID, as a cell of data; the count goes on (#189, Phase 2). */ +static void id_directive(v4_text *t, reader *r) +{ + if (r->depth != 1) { fail(t, "not allowed in a macro", "#id,"); return; } + (void)v4_asm_label(&t->as); + put_cell(t, t->next_id++); + check_asm(t, "#id,"); +} + /* `", TOKEN`: TOKEN, whatever its characters, as a counted string. */ static void string_directive(v4_text *t, reader *r) { @@ -505,6 +517,8 @@ static void one_token(v4_text *t, reader *r, const char *tok) if (strcmp(tok, "macro") == 0) { define_macro(t, r); return; } if (strcmp(tok, "constant") == 0) { constant_directive(t, r); return; } if (strcmp(tok, "#,") == 0) { cell_directive(t, r); return; } + if (strcmp(tok, "#id,") == 0) { id_directive(t, r); return; } + if (strcmp(tok, "#ids") == 0) { fail(t, "#ids is only a value", NULL); return; } if (strcmp(tok, "\",") == 0) { string_directive(t, r); return; } if (strcmp(tok, "set") == 0) { set_directive(t, r); return; } if (strcmp(tok, "store") == 0) { store_directive(t, r); return; } @@ -630,6 +644,7 @@ void v4_text_begin(v4_text *t, v4_node *n, v4_cell origin) t->latest = 0; t->start = -1; t->header_pending = 0; + t->next_id = 0; } void v4_text_constant(v4_text *t, const char *name, v4_cell value) diff --git a/v4/system/mesh.c b/v4/system/mesh.c index 53e51146..962734f3 100644 --- a/v4/system/mesh.c +++ b/v4/system/mesh.c @@ -122,9 +122,14 @@ static int line_cb(void *self, unsigned asker, char *text) if (asker >= MAX_PLACES || the->reading_nucleus[asker]) return -1; return next_line(&reads[asker], text, V4_MANAGE_LINE); } +static void words_attach(unsigned place, v4_fabric_node *x); static void parity_cb(void *self, unsigned place, v4_cell number, const v4_node *n) { (void)self; + { + v4_fabric_node *x = v4_fabric_node_at(&the->f, place); + if (x && &x->n == n) words_attach(place, x); /* it has its system: its words are kept from now */ + } if (the->parity) the->parity(the->self, place, number, n); } @@ -132,12 +137,129 @@ static void parity_cb(void *self, unsigned place, v4_cell number, const v4_node static unsigned place_of_device(const void *self) { return (unsigned)((const v4_device *)self - the->kernel); } +/* ---- the words' accounts (#189, Phase 2; mesh.h) ----------------------------------------------------- */ + +#define WORD_BITS_BYTES ((unsigned)V4_NODE_WORDS / 8u) + +static unsigned char *bits_of(unsigned place) { return the->is_word + (unsigned long)place * WORD_BITS_BYTES; } +static v4_mesh_account *accounts_of(unsigned place) { return the->accounts + (unsigned long)place * V4_MESH_WORD_IDS; } +static int is_word(unsigned place, v4_cell a) +{ + return a > 4 && a < (v4_cell)V4_NODE_WORDS && (bits_of(place)[a >> 3] >> (a & 7)) & 1u; +} + +/* an entry has been made, its code at xt: it has a record from now */ +static void word_made(unsigned place, const v4_node *n, v4_cell xt) +{ + v4_cell id; + if (!the->accounts || xt <= 4 || xt >= (v4_cell)V4_NODE_WORDS) return; + bits_of(place)[xt >> 3] |= (unsigned char)(1u << (xt & 7)); + id = n->mem[xt - 4]; + if (id >= 0 && id < (v4_cell)V4_MESH_WORD_IDS) { + v4_mesh_account *a = &accounts_of(place)[id]; + a->calls = 0; a->since = 0; a->xt = xt; + } +} + +/* every entry from word address w up has gone: their records go, and the owner forgets their IDs */ +static void words_gone(unsigned place, const v4_node *n, v4_cell w) +{ + v4_cell a; + if (!the->accounts) return; + if (w < 5) w = 5; + for (a = w; a < (v4_cell)V4_NODE_WORDS; a++) { + v4_cell id; + if (!is_word(place, a)) continue; + bits_of(place)[a >> 3] &= (unsigned char)~(1u << (a & 7)); + id = n->mem[a - 4]; + if (id >= 0 && id < (v4_cell)V4_MESH_WORD_IDS && accounts_of(place)[id].xt == a) { + v4_mesh_account *r = &accounts_of(place)[id]; + r->calls = 0; r->since = 0; r->xt = 0; + if (the->forgot) the->forgot(the->self, place, id); + } + } +} + +/* at `call` (exec.h): a word's record counts one; any other target, nothing */ +static void on_call(void *ctx, v4_node *n, v4_cell target) +{ + unsigned place = place_of_device(ctx); + v4_cell id; + if (!is_word(place, target)) return; + id = n->mem[target - 4]; + if (id >= 0 && id < (v4_cell)V4_MESH_WORD_IDS) { accounts_of(place)[id].calls++; accounts_of(place)[id].since++; } +} + +/* is the entry at xt named `name`? (dict.f18: the name's word address at xt-2, its count byte, then its + * characters, four to a cell, low byte first) */ +static int named(const v4_node *n, v4_cell xt, const char *name) +{ + v4_cell nfa = n->mem[xt - 2]; + unsigned len = 0, i; + while (name[len]) len++; + if (nfa < 0 || nfa >= xt) return 0; + for (i = 0; i <= len; i++) { + v4_ucell c = (v4_ucell)n->mem[nfa + (v4_cell)((i) / 4u)]; + unsigned char b = (unsigned char)((c >> (8u * (i % 4u))) & 0xFFu); + if (i == 0 ? b != len : b != (unsigned char)name[i - 1]) return 0; + } + return 1; +} + +/* the node in `place` is sealed: its words as they are now each have a record, and from now on it + * tells of entries made and gone, and every call to a word counts */ +static void words_attach(unsigned place, v4_fabric_node *x) +{ + const v4_image *im = the->im; + v4_cell xt, told = 0, gone = 0; + unsigned k; + if (!the->accounts || !the->is_word) return; + for (k = 0; k < WORD_BITS_BYTES; k++) bits_of(place)[k] = 0; + for (k = 0; k < V4_MESH_WORD_IDS; k++) { accounts_of(place)[k].calls = 0; accounts_of(place)[k].since = 0; accounts_of(place)[k].xt = 0; } + for (xt = x->n.mem[im->latest], k = 0; xt > 4 && xt < (v4_cell)V4_NODE_WORDS && k < V4_NODE_WORDS; xt = x->n.mem[xt - 1], k++) { + word_made(place, &x->n, xt); + if (!told && named(&x->n, xt, "(TELL-DEFINED)")) told = xt; + if (!gone && named(&x->n, xt, "(TELL-FORGOTTEN)")) gone = xt; + } + if (told && gone) { + x->n.mem[im->word_defined] = told; + x->n.mem[im->word_forgotten] = gone; + } + x->es.on_call = on_call; + x->es.on_call_ctx = &the->kernel[place]; +} + +const v4_mesh_account *v4_mesh_account_at(const v4_mesh *ms, unsigned place, v4_cell xt) +{ + v4_fabric_node *x = v4_fabric_node_at(&ms->f, place); + v4_cell id; + the = (v4_mesh *)ms; + if (!x || !ms->accounts || place >= ms->capacity || !is_word(place, xt)) return 0; + id = x->n.mem[xt - 4]; + if (id < 0 || id >= (v4_cell)V4_MESH_WORD_IDS || ms->accounts[(unsigned long)place * V4_MESH_WORD_IDS + (unsigned long)id].xt != xt) return 0; + return &ms->accounts[(unsigned long)place * V4_MESH_WORD_IDS + (unsigned long)id]; +} + +void v4_mesh_charge(v4_mesh *ms, unsigned place, void (*each)(void *ctx, v4_cell id, v4_uheat_t calls), void *ctx) +{ + unsigned k; + if (!ms->accounts || place >= ms->capacity) return; + for (k = 0; k < V4_MESH_WORD_IDS; k++) { + v4_mesh_account *a = &ms->accounts[(unsigned long)place * V4_MESH_WORD_IDS + k]; + if (a->since == 0) continue; + each(ctx, (v4_cell)k, a->since); + a->since = 0; + } +} + static int kernel_take(void *self, v4_cell value) /* a request */ { unsigned place = place_of_device(self); v4_fabric_node *x = v4_fabric_node_at(&the->f, place); if (!x) return 1; if (v4_blocks_serve(&the->blocks[place], &x->n, value)) return 1; + if (value == V4_REQ_WORD_DEFINED) { word_made(place, &x->n, v4_dstack_pop(&x->n.ds)); return 1; } + if (value == V4_REQ_WORD_FORGOTTEN) { words_gone(place, &x->n, v4_dstack_pop(&x->n.ds)); return 1; } if (place == the->hera_place && the->serve && value >= 1 && value <= (v4_cell)the->word_count) { the->serve(&x->n, (unsigned)value); return 1; @@ -198,6 +320,11 @@ static void gone_cb(void *self, unsigned place, v4_fabric_node *was) { (void)self; if (place < MAX_PLACES) { the->reading_nucleus[place] = 0; reads[place].p = reads[place].end = 0; } + if (the->accounts && place < the->capacity) { /* its words' records go with it */ + unsigned k; + for (k = 0; k < WORD_BITS_BYTES; k++) bits_of(place)[k] = 0; + for (k = 0; k < V4_MESH_WORD_IDS; k++) { accounts_of(place)[k].calls = 0; accounts_of(place)[k].since = 0; accounts_of(place)[k].xt = 0; } + } if (the->gone) the->gone(the->self, place); if (the->unroom) the->unroom(the->self, was); } @@ -432,6 +559,7 @@ static int boot(v4_mesh *ms) if (!load(ms, "v4:forth79.4th")) return 0; for (i = 0; i < ms->capsule_count; i++) if (!load(ms, ms->capsules[i])) return 0; v4_image_seal(&h->n, ms->im); + words_attach(ms->hera_place, h); /* her words' accounts, from now (#189, Phase 2) */ /* POST, run on her as the kernel's, through her console; then she is put back as sealed */ { diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index 4d7f8b0b..57a175c1 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -212,6 +212,8 @@ enum { V4_ROM_ERRORS(ROM_ERR_ENUM_) ROM_ERR_END_ }; #define WORD_FORGOTTEN (BUF0_W - 12) /* the xt of the word that is told when entries go, or 0 */ #define LOG_LEVEL (BUF0_W - 5) /* the level at or below which a message is printed */ #define BOOT_CELLS (BVARS + 14) /* (BOOT): DP and LATEST as the loader left them, 2 cells */ +#define NEXT_ID (BVARS + 10) /* (NEXT-ID): the word ID the next entry is given (#189, Phase 2) */ +#define BOOT_ID (BVARS + 11) /* (BOOT-ID): (NEXT-ID) as the loader left it, which COLD comes back to */ #define BUF0_W (BVARS - (v4_cell)(V4_BLOCK_SLOTS * V4_BLOCK_CELLS)) /* the block window: the kernel's slots, 256 cells each (v4/blocks.h) */ /* The ports and the addresses after them, through V4_PORT_HAVE (node.h, MESH.md 7d.3), are not memory and must be where * no variable is: after the output buffer, which ends at BUF0_W - 144, and before OUT_HDR, the first variable above it. @@ -285,6 +287,8 @@ static unsigned host_branch_slots(void) X("(W)", WVARS) \ X("(X)", XVARS) \ X("(BOOT)", BOOT_CELLS) \ + X("(NEXT-ID)", NEXT_ID) \ + X("(BOOT-ID)", BOOT_ID) \ X("(LOG-LEVEL)", LOG_LEVEL) \ X("(ACL-HOOK)", ACL_HOOK) \ X("SCR", SCR) \ @@ -430,6 +434,9 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned n->mem[VOC_LINK] = 0; /* and the text interpreted is the terminal's */ n->mem[SRC] = TIB; + /* the word IDs the source's headers took (#id,), as end.f18 stores them on the machine (#189, Phase 2) */ + n->mem[NEXT_ID] = tx->next_id; + n->mem[BOOT_ID] = tx->next_id; return 1; } diff --git a/v4/tests/test_host_dict.c b/v4/tests/test_host_dict.c index da8c10f2..ed2a6b23 100644 --- a/v4/tests/test_host_dict.c +++ b/v4/tests/test_host_dict.c @@ -133,7 +133,7 @@ static int entry_is(v4_cell xt, const char *want, v4_cell link, v4_cell flags) v4_cell nfa; if (len > 31) len = 31; cells = (len + 4) / 4; - nfa = xt - 3 - (v4_cell)cells; + nfa = xt - 4 - (v4_cell)cells; /* the name, then its word ID (#189, Phase 2), flags, NFA, link */ if (n.mem[xt - 1] != link || n.mem[xt - 2] != nfa || n.mem[xt - 3] != flags) return 0; if (byte_at(nfa * 4) != len) return 0; for (i = 0; i < len; i++) if (byte_at(nfa * 4 + 1 + (v4_cell)i) != (unsigned char)want[i]) return 0; @@ -258,21 +258,21 @@ int main(void) empty_dictionary(); CHECK(get("LATEST", 0, 0) == 0, "LATEST is 0 in an empty dictionary"); a = define("ALPHA"); - CHECK(a == DICT_W + 2 + 3 && !err(), "an entry's xt follows its name and three cells: %ld", (long)a); + CHECK(a == DICT_W + 2 + 4 && !err(), "an entry's xt follows its name and four cells: %ld", (long)a); CHECK(entry_is(a, "ALPHA", 0, 0), "the first entry: name, no flags, link 0"); CHECK(get("LATEST", 0, 0) == a && get("HERE", 0, 0) == a, "LATEST is its xt, and its code starts at HERE"); CHECK(run(",", 1, 1001, 0) && clean(), "some code"); b = define("B"); - CHECK(b == a + 1 + 1 + 3 && entry_is(b, "B", a, 0), "the second entry links to the first"); + CHECK(b == a + 1 + 1 + 4 && entry_is(b, "B", a, 0), "the second entry links to the first"); (void)run(",", 1, 1002, 0); c = define("GAMMA-DELTA"); - CHECK(c == b + 1 + 3 + 3 && entry_is(c, "GAMMA-DELTA", b, 0), "an eleven-character name takes three cells"); + CHECK(c == b + 1 + 3 + 4 && entry_is(c, "GAMMA-DELTA", b, 0), "an eleven-character name takes three cells"); CHECK(get("LATEST", 0, 0) == c, "LATEST is the newest"); /* the field words, all from the xt */ CHECK(get(">LINK", 1, c) == c - 1 && get("LFA", 1, c) == c - 1, ">LINK and LFA are the link's address"); CHECK(get("LINK>", 1, c - 1) == b && get("LINK>", 1, b - 1) == a && get("LINK>", 1, a - 1) == 0, "LINK> follows it, to 0 at the end"); - CHECK(get(">NAME", 1, c) == (c - 6) * 4 && get("NFA", 1, c) == (c - 6) * 4, ">NAME and NFA are the name's byte address"); + CHECK(get(">NAME", 1, c) == (c - 7) * 4 && get("NFA", 1, c) == (c - 7) * 4, ">NAME and NFA are the name's byte address"); CHECK(byte_at(get(">NAME", 1, b)) == 1 && byte_at(get(">NAME", 1, b) + 1) == 'B', "which is its count byte, then its characters"); CHECK(get("NAME>", 1, get(">NAME", 1, a)) == a && get("NAME>", 1, get(">NAME", 1, b)) == b && get("NAME>", 1, get(">NAME", 1, c)) == c, "NAME> goes back to the xt"); CHECK(get("CFA", 1, c) == c, "CFA is the xt itself, as v3"); @@ -306,15 +306,15 @@ int main(void) memset(long31, 'q', 31); long31[31] = 0; memset(long40, 'q', 40); long40[40] = 0; a = define(long31); - CHECK(a == DICT_W + 8 + 3 && entry_is(a, long31, 0, 0), "a 31-character name is kept whole"); + CHECK(a == DICT_W + 8 + 4 && entry_is(a, long31, 0, 0), "a 31-character name is kept whole"); b = define(long40); - CHECK(b != 0 && entry_is(b, long31, a, 0) && b - a == 8 + 3, "a 40-character name is cut to 31"); + CHECK(b != 0 && entry_is(b, long31, a, 0) && b - a == 8 + 4, "a 40-character name is cut to 31"); } empty_dictionary(); - n.mem[DP] = (DICT_END_W - 4) * 4; - CHECK(define("ABCD") == 0 && err() && n.mem[LATEST] == 0 && n.mem[DP] == (DICT_END_W - 4) * 4 && n.mem[DICT_END_W - 4] == GUARD, - "an entry that does not fit makes nothing, moves nothing, and sets NODE-ERROR"); n.mem[DP] = (DICT_END_W - 5) * 4; + CHECK(define("ABCD") == 0 && err() && n.mem[LATEST] == 0 && n.mem[DP] == (DICT_END_W - 5) * 4 && n.mem[DICT_END_W - 5] == GUARD, + "an entry that does not fit makes nothing, moves nothing, and sets NODE-ERROR"); + n.mem[DP] = (DICT_END_W - 6) * 4; CHECK(define("ABCD") == DICT_END_W && !err() && n.mem[DICT_END_W] == GUARD, "one that just fits is made"); /* ---- FIND ---- */ @@ -376,9 +376,9 @@ int main(void) /* the same name through (HEADER): the same cells */ made = define("FIRST-HEADER"); CHECK(made != 0 && n.mem[made - 3] == n.mem[xa - 3] && made - n.mem[made - 2] == xa - n.mem[xa - 2], "an entry made by (HEADER) has the same shape"); - for (i = 0; i < (unsigned)(xa - 3 - n.mem[xa - 2]); i++) + for (i = 0; i < (unsigned)(xa - 4 - n.mem[xa - 2]); i++) if (n.mem[n.mem[xa - 2] + (v4_cell)i] != n.mem[n.mem[made - 2] + (v4_cell)i]) break; - CHECK(i == (unsigned)(xa - 3 - n.mem[xa - 2]), "and the same name cells"); + CHECK(i == (unsigned)(xa - 4 - n.mem[xa - 2]), "and the same name cells"); CHECK(n.mem[made - 1] == xp && find("FIRST-HEADER") == made && find("B") == xb, "new entries link on to the assembler's"); } diff --git a/v4/tests/test_host_quit.c b/v4/tests/test_host_quit.c index 8d3a1e6e..27055438 100644 --- a/v4/tests/test_host_quit.c +++ b/v4/tests/test_host_quit.c @@ -65,7 +65,7 @@ static v4_node n; static v4_exec_state es; static v4_heat h; static v4_text tx; -static v4_cell w_key, w_key_end, w_fault, capsule_latest; +static v4_cell w_key, w_key_end, w_fault, capsule_latest, capsule_ids; static v4_cell w_idle; /* (IDLE): where the node waits for a message */ static char out[V4_CONSOLE_CAP + 1]; @@ -327,6 +327,8 @@ static void boot_with(unsigned depth) n.mem[VOC_LINK] = 0; n.mem[SRC] = TIB; for (v4_cell k = BVARS; k < BVARS + 14; k++) if (k != SRC) n.mem[k] = 0; /* empty buffers, SCR and BLK 0, no hook */ + n.mem[NEXT_ID] = capsule_ids; /* the next word ID is the first after the capsule's */ + n.mem[BOOT_ID] = capsule_ids; memset(ram, 0, sizeof ram); memset(common_dev, 0, sizeof common_dev); v4_blocks_init(&kblocks, BUF0_W); v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST); @@ -934,6 +936,7 @@ int main(void) w_key_end = v4_text_word(&tx, "CR"); /* the word after KEY in core.f18 */ w_fault = v4_text_word(&tx, "(FAULTS)"); capsule_latest = v4_text_latest(&tx); + capsule_ids = tx.next_id; /* the word IDs the capsule's headers took (#189, Phase 2) */ CHECK(w_key_end > w_key && w_key_end - w_key <= 12, "KEY is the few words before CR"); /* ---- switch-on ---- */ @@ -1766,24 +1769,36 @@ int main(void) n.mem[BOOT_CELLS] = n.mem[DP]; /* and all of it is the system, which COLD keeps */ n.mem[BOOT_CELLS + 1] = n.mem[LATEST]; n.mem[FENCE] = (n.mem[DP] + 3) / 4; + n.mem[BOOT_ID] = n.mem[NEXT_ID]; { unsigned before = known_n; + v4_cell id0 = n.mem[NEXT_ID], c1; CHECK(kernel_agrees() && before == 3, "the kernel starts knowing the words that are there: %u", before); CHECK(is(say(": A1 ;\n"), " ok\nok> ") && known_n == before + 1 && kernel_agrees(), "a colon definition is told of"); CHECK(strcmp(node_name(known[known_n - 1]), "A1") == 0, "by its xt, from which its name is read: %s", node_name(known[known_n - 1])); + /* the word ID (#189 Phase 2; Captain Bob, 2026-11-13: "ID field in the header"): a cell before the flags, + * the next number, so the kernel can join its record to the word */ + CHECK(id0 > 300 && n.mem[known[known_n - 1] - 4] == id0 && n.mem[NEXT_ID] == id0 + 1, + "A1's word ID, at xt-4, is the next one: %ld (the system's words have the ones below)", (long)n.mem[known[known_n - 1] - 4]); CHECK(is(say("VARIABLE V1 5 CONSTANT C1 CREATE D1\n"), " ok\nok> ") && known_n == before + 4 && kernel_agrees(), "and a variable, a constant and a CREATEd word"); + c1 = known[known_n - 2]; + CHECK(n.mem[known[known_n - 3] - 4] == id0 + 1 && n.mem[c1 - 4] == id0 + 2 && n.mem[known[known_n - 1] - 4] == id0 + 3, + "each numbered in turn"); CHECK(is(say("VOCABULARY VOC1 VOC1 DEFINITIONS : IN1 ; FORTH DEFINITIONS : A2 ;\n"), " ok\nok> ") && known_n == before + 7 && kernel_agrees(), "a vocabulary, a word in it, and a word after it"); CHECK(strstr(say(": BAD NOSUCH ;\n"), "ERROR") != NULL && known_n == before + 8 && kernel_agrees(), "a definition that is abandoned is still an entry, and is told of"); CHECK(is(say("FORGET C1\n"), " ok\nok> ") && known_n == before + 2 && kernel_agrees(), "FORGET tells that every entry from that one up has gone: %u left of ours", known_n - before); + CHECK(n.mem[NEXT_ID] == id0 + 2, "and gives its IDs back: the next is C1's again (%ld)", (long)n.mem[NEXT_ID]); CHECK(is(say(": A3 ;\n"), " ok\nok> ") && known_n == before + 3 && kernel_agrees(), "and what is defined next is told of as before"); + CHECK(n.mem[known[known_n - 1] - 4] == id0 + 2, "with C1's ID, which FORGET gave back"); CHECK(strstr(say("FORGET KD\n"), "Protected word") != NULL && known_n == before + 3 && kernel_agrees(), "a FORGET that is refused tells nothing"); (void)say("COLD\n"); CHECK(known_n == before && kernel_agrees(), "COLD tells that everything above the system has gone: %u", known_n); + CHECK(n.mem[NEXT_ID] == id0, "and the IDs go back to the system's"); CHECK(is(say(": A4 ; A4\n"), " ok\nok> ") && known_n == before + 1 && kernel_agrees(), "and the node goes on telling"); } diff --git a/v4/tests/test_mesh_boot.c b/v4/tests/test_mesh_boot.c index 78e0bb11..478ffc60 100644 --- a/v4/tests/test_mesh_boot.c +++ b/v4/tests/test_mesh_boot.c @@ -17,6 +17,7 @@ #include "block_subsystem.h" #include #include +#include static int failures = 0, checks = 0; #define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0) @@ -32,6 +33,13 @@ static int used[PLACES]; static unsigned roomed, given_back, borns, gones, parities; static v4_image im; static v4_mesh ms; +static v4_mesh_account accounts[PLACES * V4_MESH_WORD_IDS]; /* the words' records (#189, Phase 2) */ +static unsigned char is_word[PLACES * (V4_NODE_WORDS / 8u)]; +static unsigned forgotten; +static v4_cell forgotten_id = -1; +static void forgot(void *self, unsigned place, v4_cell id) { (void)self; (void)place; forgotten++; forgotten_id = id; } +static v4_uheat_t charged[V4_MESH_WORD_IDS]; +static void charge(void *ctx, v4_cell id, v4_uheat_t calls) { (void)ctx; charged[id] += calls; } static int no_room; /* the owner has no room to give */ static v4_fabric_node *room(void *self) { unsigned k; (void)self; if (no_room) return 0; for (k = 0; k < PLACES; k++) if (!used[k]) { used[k] = 1; roomed++; return &pool[k]; } return 0; } @@ -80,6 +88,7 @@ int main(void) ms.room = room; ms.unroom = unroom; ms.born = born; ms.gone = gone; ms.parity = parity; ms.out = out; ms.key = key; ms.words = words; ms.word_count = 1; ms.serve = serve; ms.capsules = capsules; ms.capsule_count = 2; ms.im = &im; ms.self = 0; + ms.accounts = accounts; ms.is_word = is_word; ms.forgot = forgot; /* ---- the boot ---- */ CHECK(v4_mesh_boot(&ms) == 1, "the boot: %s", said); @@ -165,6 +174,63 @@ int main(void) r = line(V4_MESH_HERA, "3 4 + .", &how); CHECK(how == V4_TEXT_COMPLETED && strcmp(r, "7 ") == 0 && ms.owed == 0, "and nothing more is owed: \"%s\"", r); + /* ---- the words' accounts (#189, Phase 2; Captain Bob, 2026-11-13: the word ID in the header, charged + * per heartbeat tick) ---- */ + { + v4_cell xt, xt2; + const v4_mesh_account *a; + r = line(V4_MESH_HERA, ": SQ DUP * ; ' SQ .", &how); + xt = (v4_cell)strtol(r, 0, 10); + a = v4_mesh_account_at(&ms, 0, xt); + CHECK(how == V4_TEXT_COMPLETED && xt > 0 && a && a->calls == 0 && a->xt == xt, + "a word defined at the prompt has a record, called 0 times: \"%s\"", r); + r = line(V4_MESH_HERA, "3 SQ .", &how); + CHECK(strcmp(r, "9 ") == 0 && a && a->calls == 1, "a call to it counts one: %lu", a ? (unsigned long)a->calls : 0ul); + r = line(V4_MESH_HERA, "5 SQ 6 SQ + .", &how); + CHECK(strcmp(r, "61 ") == 0 && a && a->calls == 3, "and each call one more: %lu", a ? (unsigned long)a->calls : 0ul); + r = line(V4_MESH_HERA, ": QUAD SQ SQ ; 2 QUAD .", &how); + CHECK(strcmp(r, "16 ") == 0 && a && a->calls == 5, "calls from inside a definition count: %lu", a ? (unsigned long)a->calls : 0ul); + r = line(V4_MESH_HERA, "4 ' SQ EXECUTE .", &how); + CHECK(strcmp(r, "16 ") == 0 && a && a->calls == 6, "and through EXECUTE: %lu", a ? (unsigned long)a->calls : 0ul); + { + v4_cell id = v4_mesh_node(&ms, V4_MESH_HERA)->n.mem[xt - 4]; + memset(charged, 0, sizeof charged); + v4_mesh_charge(&ms, 0, charge, 0); + CHECK(id >= 0 && id < (v4_cell)V4_MESH_WORD_IDS && charged[id] == 6 && a && a->since == 0 && a->calls == 6, + "the owner's charge takes the calls since, and clears them; the record keeps its count"); + memset(charged, 0, sizeof charged); + v4_mesh_charge(&ms, 0, charge, 0); + CHECK(charged[id] == 0, "a second charge with no calls between takes nothing for it"); + r = line(V4_MESH_HERA, "FORGET SQ", &how); + CHECK(how == V4_TEXT_COMPLETED && v4_mesh_account_at(&ms, 0, xt) == 0 && forgotten >= 2 && forgotten_id >= id, + "FORGET: its record goes, and QUAD's after it; the owner told (%u)", forgotten); + r = line(V4_MESH_HERA, ": CUBE DUP DUP * * ; ' CUBE .", &how); + xt2 = (v4_cell)strtol(r, 0, 10); + CHECK(xt2 > 0 && v4_mesh_node(&ms, V4_MESH_HERA)->n.mem[xt2 - 4] == id && v4_mesh_account_at(&ms, 0, xt2) + && v4_mesh_account_at(&ms, 0, xt2)->calls == 0, "the next word defined takes SQ's ID, with a record of its own"); + } + { + v4_fabric_node *h = v4_mesh_node(&ms, V4_MESH_HERA); + v4_cell w = h->n.mem[im.latest]; + unsigned k, words = 0, recorded = 0; + for (k = 0; w > 4 && k < 2000; w = h->n.mem[w - 1], k++) { words++; if (v4_mesh_account_at(&ms, 0, w)) recorded++; } + CHECK(words > 300 && recorded == words, "every word on Hera has a record: %u of %u", recorded, words); + } + r = line(V4_MESH_HERA, "11 2 2 BIRTH .", &how); + { + v4_fabric_node *x = v4_mesh_node(&ms, 11); + unsigned place = 0, k; + for (k = 0; k < PLACES; k++) if (v4_fabric_node_at(&ms.f, k) == x) place = k; + r = line(11, ": TWICE 2* ; ' TWICE .", &how); + xt = (v4_cell)strtol(r, 0, 10); + r = line(11, "21 TWICE .", &how); + CHECK(x && place != 0 && strcmp(r, "42 ") == 0 && v4_mesh_account_at(&ms, place, xt) + && v4_mesh_account_at(&ms, place, xt)->calls == 1, "a born node's words are kept too, by its own place"); + r = line(V4_MESH_HERA, "11 KILL", &how); + CHECK(how == V4_TEXT_COMPLETED && v4_mesh_account_at(&ms, place, xt) == 0, "and go when it is killed"); + } + } + printf(" %d checks, %d failures\n", checks, failures); return failures ? 1 : 0; } diff --git a/v4/tests/test_text.c b/v4/tests/test_text.c index 2c64a2db..a244f394 100644 --- a/v4/tests/test_text.c +++ b/v4/tests/test_text.c @@ -431,27 +431,40 @@ int main(void) CHECK(ok("header DUP : (DUP) dup + ;"), "a header assembles: %s", v4_text_error(&tx)); { v4_cell xt = v4_text_word(&tx, "(DUP)"); - CHECK(xt == ORIGIN + 4 && v4_text_latest(&tx) == xt, "the code follows the name cell and three more: %ld", (long)xt); + CHECK(xt == ORIGIN + 5 && v4_text_latest(&tx) == xt, "the code follows the name cell and four more: %ld", (long)xt); CHECK((v4_ucell)nb.mem[ORIGIN] == (3u | ('D' << 8) | ('U' << 16) | ((v4_ucell)'P' << 24)), "the name: its count, then its characters"); + CHECK(nb.mem[xt - 4] == 0, "the word ID: the first header's is 0 (#189, Phase 2)"); CHECK(nb.mem[xt - 3] == 0 && nb.mem[xt - 2] == ORIGIN && nb.mem[xt - 1] == 0, "flags 0, the name's address, link 0"); CHECK(result("(DUP)", 1, 7, 0) == 14, "and the word runs"); } + /* the word ID (#189, Phase 2; Captain Bob, 2026-11-13: "ID field in the header"): numbered in the + * order the headers are assembled, from 0, by `header` and by `#id,`; `#ids` is how many so far */ + CHECK(ok("header A : A' 1 ; header B : B' 2 ; header C : C' 3 ;"), "three headers: %s", v4_text_error(&tx)); + CHECK(nb.mem[v4_text_word(&tx, "A'") - 4] == 0 && nb.mem[v4_text_word(&tx, "B'") - 4] == 1 + && nb.mem[v4_text_word(&tx, "C'") - 4] == 2, "their word IDs are 0, 1, 2"); + CHECK(ok("#id, #id, #id, #, #ids"), "#id, three times, then #ids: %s", v4_text_error(&tx)); + CHECK(nb.mem[ORIGIN] == 0 && nb.mem[ORIGIN + 1] == 1 && nb.mem[ORIGIN + 2] == 2 && nb.mem[ORIGIN + 3] == 3, + "#id, lays 0, 1, 2; #ids is then 3"); + CHECK(ok("header A : A' 1 ; #id, header B : B' 2 ;"), "a header and #id, share the count: %s", v4_text_error(&tx)); + CHECK(nb.mem[v4_text_word(&tx, "B'") - 4] == 2, "so the next header's ID is 2"); + CHECK(ok("#, #ids") && nb.mem[ORIGIN] == 0, "with none yet, #ids is 0"); + CHECK(refused("macro M #id, endmacro M", "not allowed in a macro", 0), "#id, is refused in a macro"); CHECK(ok(": BEFORE 1 ; header A : A' 2 ; header LONGER-NAM immediate : B' 3 ; : MID 4 ; header + inline compile-only : PLUS + ;") && result("BEFORE", 0, 0, 0) == 1 && result("B'", 0, 0, 0) == 3 && result("MID", 0, 0, 0) == 4, "headers among other words"); { v4_cell a = v4_text_word(&tx, "A'"), b = v4_text_word(&tx, "B'"), c = v4_text_word(&tx, "PLUS"); CHECK(nb.mem[a - 1] == 0 && nb.mem[b - 1] == a && nb.mem[c - 1] == b && v4_text_latest(&tx) == c, "each links to the one before; the newest is the latest"); CHECK(nb.mem[a - 3] == 0 && nb.mem[b - 3] == 1 && nb.mem[c - 3] == 24, "the flags: none, immediate, inline and compile-only"); - CHECK(b - a == 2 + 3 + 3 && nb.mem[b - 2] == b - 6, "a ten-character name takes three cells"); - CHECK((v4_ucell)nb.mem[b - 4] == (('N') | ('A' << 8) | ('M' << 16)), "and is padded with zeros"); - CHECK((v4_ucell)nb.mem[c - 4] == (1u | ('+' << 8)), "an opcode's name is taken as it stands"); + CHECK(b - a == 2 + 3 + 4 && nb.mem[b - 2] == b - 7, "a ten-character name takes three cells"); + CHECK((v4_ucell)nb.mem[b - 5] == (('N') | ('A' << 8) | ('M' << 16)), "and is padded with zeros"); + CHECK((v4_ucell)nb.mem[c - 5] == (1u | ('+' << 8)), "an opcode's name is taken as it stands"); } CHECK(ok("header ( immediate : PAREN ; header \\ immediate : BACKSLASH ; header : : COLON ; header ; : SEMI ; header header : H ;"), "names the assembler would otherwise read as its own: %s", v4_text_error(&tx)); - CHECK((v4_ucell)nb.mem[v4_text_word(&tx, "PAREN") - 4] == (1u | ('(' << 8)) - && (v4_ucell)nb.mem[v4_text_word(&tx, "BACKSLASH") - 4] == (1u | ('\\' << 8)) - && (v4_ucell)nb.mem[v4_text_word(&tx, "COLON") - 4] == (1u | (':' << 8)) - && (v4_ucell)nb.mem[v4_text_word(&tx, "SEMI") - 4] == (1u | (';' << 8)), "are names like any other"); + CHECK((v4_ucell)nb.mem[v4_text_word(&tx, "PAREN") - 5] == (1u | ('(' << 8)) + && (v4_ucell)nb.mem[v4_text_word(&tx, "BACKSLASH") - 5] == (1u | ('\\' << 8)) + && (v4_ucell)nb.mem[v4_text_word(&tx, "COLON") - 5] == (1u | (':' << 8)) + && (v4_ucell)nb.mem[v4_text_word(&tx, "SEMI") - 5] == (1u | (';' << 8)), "are names like any other"); CHECK(ok("header data-word data : D 1 ;") && nb.mem[v4_text_word(&tx, "D") - 3] == 4, "the data flag"); CHECK(ok("header 1234567890123456789012345678901 : W ;"), "a 31-character name fits"); CHECK(refused("header 12345678901234567890123456789012 : W ;", "at most 31 characters", 1), "a 32-character one is refused"); diff --git a/v4/tools/mkmap.c b/v4/tools/mkmap.c index c70bf6b2..32606c5a 100644 --- a/v4/tools/mkmap.c +++ b/v4/tools/mkmap.c @@ -53,9 +53,10 @@ static int image_description(void) printf("#include \"v4/image.h\"\n\nconst v4_image v4_map_image = {\n"); printf(" %uu, %uu, %uu, %uu,\n", (unsigned)V4_CELL_BITS, (unsigned)V4_NODE_WORDS, (unsigned)V4_DATA_RING, (unsigned)V4_RET_RING); printf(" -1,\n -1, %ld,\n -1, -1,\n", (long)PORT); - printf(" %ld, %ld, %ld,\n %ld, %ld,\n %ld,\n %ld, %ld,\n %ld, %ld,\n %ld, %ld,\n %ld,\n", + printf(" %ld, %ld, %ld,\n %ld, %ld,\n %ld,\n %ld, %ld,\n %ld, %ld,\n %ld, %ld,\n %ld, %ld,\n %ld, %ld,\n %ld,\n", (long)CONSOLE_TX, (long)CONSOLE_RX, (long)CONSOLE_ST, (long)DSTACK_REG, (long)RSTACK_REG, - (long)NODE_ERROR, (long)HEAT_REG, (long)ME, (long)DP, (long)LATEST, (long)BOOT_CELLS, (long)FENCE, (long)BUF0_W); + (long)NODE_ERROR, (long)HEAT_REG, (long)ME, (long)DP, (long)LATEST, (long)BOOT_CELLS, (long)FENCE, + (long)NEXT_ID, (long)BOOT_ID, (long)WORD_DEFINED, (long)WORD_FORGOTTEN, (long)BUF0_W); printf(" %ld, %ld, %ld\n};\n", (long)ROM_IMG, (long)ROM_FAILED, (long)ROM_ERRLINE); return 0; } @@ -107,6 +108,7 @@ int main(int argc, char **argv) } } constant("(HERE)", (long)ROM_HERE); + constant("NEXT-ID-W", (long)NEXT_ID); /* the system's (NEXT-ID): where #id, counts (#189, Phase 2) */ constant("(CUR)", (long)ROM_CUR); constant("(SLOT)", (long)ROM_SLOT); constant("(NLIT)", (long)ROM_NLIT);