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 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_017RzZgrf7V7Zk2iczBXDRbm
This commit is contained in:
+17
-4
@@ -11,8 +11,12 @@
|
|||||||
\ store ADDR VALUE ADDR := VALUE, anywhere in RAM
|
\ store ADDR VALUE ADDR := VALUE, anywhere in RAM
|
||||||
\ start NAME the end: every branch must have its target; the
|
\ start NAME the end: every branch must have its target; the
|
||||||
\ tables the ROM used are cleared; then NAME runs
|
\ 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
|
\ 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
|
\ ( -- v 1 | 0 0 ) the token as a VALUE; "not a value" if it is none
|
||||||
: (VALUE)
|
: (VALUE)
|
||||||
@@ -20,7 +24,8 @@
|
|||||||
-if NUMOK drop drop ERR-BIG (FAIL) 0 0 ;
|
-if NUMOK drop drop ERR-BIG (FAIL) 0 0 ;
|
||||||
NUMOK: drop 1 ;
|
NUMOK: drop 1 ;
|
||||||
NN: drop drop
|
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
|
0 (CHAR@) 38 xor if AMPV drop
|
||||||
(FIND) if NOSYM
|
(FIND) if NOSYM
|
||||||
dup 2 + a! @ 2 xor if CV drop
|
dup 2 + a! @ 2 xor if CV drop
|
||||||
@@ -31,7 +36,8 @@
|
|||||||
(CONST+N) if BAD0 ;
|
(CONST+N) if BAD0 ;
|
||||||
BAD0: drop drop
|
BAD0: drop drop
|
||||||
BAD: ERR-VALUE (FAIL) 0 0 ;
|
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
|
AMPV: drop (TOKN) a! @ -1 + if ONEV drop
|
||||||
(TOK-SAVE) 1 (MLEN) a! @ -1 + (TOK-SUB)
|
(TOK-SAVE) 1 (MLEN) a! @ -1 + (TOK-SUB)
|
||||||
(FIND) if BADA
|
(FIND) if BADA
|
||||||
@@ -68,8 +74,15 @@
|
|||||||
BADV: drop drop ;
|
BADV: drop drop ;
|
||||||
MISS: drop jump (MISSING)
|
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-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)
|
: (H-CELL)
|
||||||
(IN-MACRO?) if OK drop ;
|
(IN-MACRO?) if OK drop ;
|
||||||
|
|||||||
@@ -51,7 +51,7 @@
|
|||||||
: (RESERVED)
|
: (RESERVED)
|
||||||
", : ", macro ", endmacro ", FOR ", NEXT ", UNEXT
|
", : ", macro ", endmacro ", FOR ", NEXT ", UNEXT
|
||||||
", constant ", set ", here ", #, ", ", ", store
|
", constant ", set ", here ", #, ", ", ", store
|
||||||
", start
|
", start ", #id, ", #ids
|
||||||
#, 0
|
#, 0
|
||||||
|
|
||||||
\ ( -- op | -1 ) which opcode the token names
|
\ ( -- op | -1 ) which opcode the token names
|
||||||
|
|||||||
@@ -338,7 +338,7 @@
|
|||||||
jump (H-FOR) jump (H-NEXT) jump (H-UNEXT)
|
jump (H-FOR) jump (H-NEXT) jump (H-UNEXT)
|
||||||
jump (H-CONSTANT) jump (H-SET) jump (H-HERE)
|
jump (H-CONSTANT) jump (H-SET) jump (H-HERE)
|
||||||
jump (H-CELL) jump (H-STRING) jump (H-STORE)
|
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
|
\ : NAME end the word before, and begin NAME at the next instruction word
|
||||||
: (H-COLON)
|
: (H-COLON)
|
||||||
|
|||||||
+13
-13
@@ -18,25 +18,25 @@
|
|||||||
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
|
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
|
||||||
: (PINNED) -3 + a! @ 64 and ;
|
: (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 ;
|
: 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 ;
|
: 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 ;
|
: 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: ;
|
: 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 ! ;
|
: 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-MODE! ( mode xt -- )
|
||||||
(ACL-XT) (PINNED) if FREE drop drop ;
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
||||||
FREE: drop 255 and 8* @ -65281 and + ! ;
|
FREE: drop 255 and 8* @ -65281 and + ! ;
|
||||||
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
|
\ 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-TTL! ( n xt -- )
|
||||||
(ACL-XT) (PINNED) if FREE drop drop ;
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
||||||
FREE: 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
|
POS: dup -65536 and if SMALL drop drop 65535 jump SET
|
||||||
SMALL: drop
|
SMALL: drop
|
||||||
SET: 8* 8* @ 65535 and + ! ;
|
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-ALLOW! ( flag xt -- )
|
||||||
(ACL-XT) (PINNED) if FREE drop drop ;
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
||||||
FREE: drop if DENY drop @ -33 and ! ;
|
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
|
\ ( 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.
|
\ 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-INHERIT
|
||||||
(ACL-XT) SWAP (ACL-XT) \ dst src
|
(ACL-XT) SWAP (ACL-XT) \ dst src
|
||||||
-3 + a! @ $FF00 and \ dst mode
|
-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
|
NXT: -1 + a! @ jump L
|
||||||
DONE: drop ;
|
DONE: drop ;
|
||||||
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
|
\ ( -- ) 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
|
: ACL-INIT-PRIMITIVES
|
||||||
(LATEST) a! @ (ACL-INIT)
|
(LATEST) a! @ (ACL-INIT)
|
||||||
VOC-LINK a! @
|
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
|
\ ( xt -- heat ) how often the word has been used. The node's heat
|
||||||
\ counters are not readable from a programme yet (D-6): 0.
|
\ 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 ;
|
: ACL-HEAT@ (ACL-XT) drop 0 ;
|
||||||
\ ( xt -- n ) a number for the word that never changes: its address
|
\ ( 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) ;
|
: ACL-WORD-ID (ACL-XT) ;
|
||||||
|
|||||||
+12
-12
@@ -25,8 +25,8 @@
|
|||||||
\ SCR word address of the variable: the block LIST showed last
|
\ SCR word address of the variable: the block LIST showed last
|
||||||
\ BLK (SRC) (SRC-HOOK) see input.f18
|
\ 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 ", SCR #id, #, 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 ", BLK #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BLK' BLK ;
|
||||||
|
|
||||||
\ ( status -- ) a request that did not work is an error
|
\ ( status -- ) a request that did not work is an error
|
||||||
: (B-ERR)
|
: (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.
|
\ ( n -- baddr ) FORTH-79: the address of a buffer assigned to block n.
|
||||||
\ What the buffer holds is not read from storage.
|
\ 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)
|
: BUFFER BUFFER# (PORT) b! !b jump (B-GOT)
|
||||||
|
|
||||||
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
|
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
|
||||||
\ read from storage if it is not already in one.
|
\ 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)
|
: BLOCK BLOCK# (PORT) b! !b jump (B-GOT)
|
||||||
|
|
||||||
\ FORTH-79: mark the block most recently asked for as changed, so that it is
|
\ FORTH-79: mark the block most recently asked for as changed, so that it is
|
||||||
\ written before its buffer is used for another.
|
\ 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)
|
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
|
||||||
|
|
||||||
\ FORTH-79: write every block that has been UPDATEd.
|
\ 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)
|
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
|
||||||
\ As v3: the same.
|
\ 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
|
: FLUSH jump SAVE-BUFFERS
|
||||||
\ FORTH-79: forget what is in the buffers; nothing is written.
|
\ 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 ;
|
: EMPTY-BUFFERS EMPTY-BUFFERS# (PORT) b! !b ;
|
||||||
|
|
||||||
\ ---- LIST ----------------------------------------------------------------------
|
\ ---- 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
|
\ 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
|
\ that is not printable is shown as a blank. (Q)+0 is the line, (Q)+1 the
|
||||||
\ column, (Q)+2 the block's number.
|
\ 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
|
: LIST
|
||||||
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
|
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
|
||||||
(Q)+2 a! @ dup SCR a! !
|
(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 ;
|
TERM: drop ;
|
||||||
|
|
||||||
\ ( n -- ) FORTH-79: interpret block n, then go on with what follows.
|
\ ( 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
|
: LOAD
|
||||||
-if POS jump BAD
|
-if POS jump BAD
|
||||||
POS: if 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
|
\ ( -- ) go on with the next block. Only in a block being loaded: at the
|
||||||
\ terminal it is an error (code 14).
|
\ 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
|
: NEXT-BLOCK
|
||||||
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
|
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
|
||||||
TERM: drop NODE-ERROR b! 14 !b ;
|
TERM: drop NODE-ERROR b! 14 !b ;
|
||||||
|
|
||||||
\ ( first last -- ) as v3: LOAD each block from first to last.
|
\ ( 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
|
: THRU
|
||||||
push
|
push
|
||||||
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
|
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
|
||||||
|
|||||||
+35
-35
@@ -149,7 +149,7 @@ macro ROT push SWAP pop SWAP endmacro
|
|||||||
\ ( -- ) print the word WORD has just left
|
\ ( -- ) print the word WORD has just left
|
||||||
: (.WORD) WBUF COUNT jump TYPE
|
: (.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,
|
\ 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
|
\ 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
|
\ 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
|
\ 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:
|
\ word met while interpreting, abandons the line, with v3's message:
|
||||||
\ UNKNOWN WORD: 'xxx' xxx: compile-only
|
\ 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
|
: INTERPRET
|
||||||
: (IL) 32 WORD dup C@ if EOL
|
: (IL) 32 WORD dup C@ if EOL
|
||||||
drop (LOOKUP) if NUM
|
drop (LOOKUP) if NUM
|
||||||
@@ -225,25 +225,25 @@ set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|||||||
|
|
||||||
\ ---- state ---------------------------------------------------------------------
|
\ ---- 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! ! ;
|
: 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! ! ;
|
: RIGHT-BRACKET -1 STATE a! ! ;
|
||||||
|
|
||||||
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
|
\ ( 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 ;
|
: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ;
|
||||||
|
|
||||||
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
|
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
|
||||||
\ compiling, compiled as a literal
|
\ 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
|
: TICK (') jump LITERAL
|
||||||
|
|
||||||
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
|
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
|
||||||
\ which v3 has as another name for 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,)
|
: 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
|
: BRACKET-LITERAL jump LITERAL
|
||||||
|
|
||||||
\ ---- colon definitions -----------------------------------------------------------
|
\ ---- 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
|
\ FORTH-79: start a definition; it cannot be found until ; ends it. The
|
||||||
\ CONTEXT vocabulary is set to the CURRENT one.
|
\ CONTEXT vocabulary is set to the CURRENT one.
|
||||||
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
|
\ (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
|
: COLON
|
||||||
CURRENT a! @ CONTEXT a! !
|
CURRENT a! @ CONTEXT a! !
|
||||||
LATEST (C)+2 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
|
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
|
\ 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
|
: SEMICOLON
|
||||||
0 (OP,)
|
0 (OP,)
|
||||||
LATEST (FLAGS) a! @ -3 and !
|
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
|
\ 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.
|
\ 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.
|
\ 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
|
: KERNEL-WORD
|
||||||
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
|
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
|
||||||
jump SEMICOLON
|
jump SEMICOLON
|
||||||
|
|
||||||
\ FORTH-79: return from the definition at this point
|
\ 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,)
|
: 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 ;
|
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
|
||||||
|
|
||||||
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
|
\ 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
|
: COMPILE
|
||||||
32 WORD (LOOKUP) if MISSING
|
32 WORD (LOOKUP) if MISSING
|
||||||
(LIT,) &(COMPILE,) jump (CALL,)
|
(LIT,) &(COMPILE,) jump (CALL,)
|
||||||
MISSING: drop (UNKNOWN) drop jump (ABANDON)
|
MISSING: drop (UNKNOWN) drop jump (ABANDON)
|
||||||
|
|
||||||
\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate
|
\ [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
|
: BRACKET-COMPILE
|
||||||
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
|
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
|
||||||
MISSING: drop (UNKNOWN) drop jump (ABANDON)
|
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 ;
|
NONE: drop ;
|
||||||
|
|
||||||
\ FORTH-79: an entry whose word leaves the address of its parameter field
|
\ 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)
|
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
|
||||||
|
|
||||||
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
|
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
|
||||||
\ programme; here it is 0.
|
\ 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 ;
|
: 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
|
\ ( 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 ;
|
: 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
|
\ 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,
|
\ call to the code after it and leaves DEFINER; that code starts with pop,
|
||||||
\ which fetches the parameter field address the call left.
|
\ which fetches the parameter field address the call left.
|
||||||
: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0
|
: (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,)
|
: DOES> &(DOES) (CALL,) 25 jump (OP,)
|
||||||
|
|
||||||
\ ---- control structures (5.18, section 2) ---------------------------------------------
|
\ ---- 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):
|
\ 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 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:
|
\ 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
|
: 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
|
: ELSE
|
||||||
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
|
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
|
||||||
2 (BRANCH>) >CF \ the jump over the else part
|
2 (BRANCH>) >CF \ the jump over the else part
|
||||||
(C)+6 a! @ (HERE!) 23 (OP,)
|
(C)+6 a! @ (HERE!) 23 (OP,)
|
||||||
2 jump >CF
|
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
|
: THEN
|
||||||
CF> dup -1 + if PLAIN
|
CF> dup -1 + if PLAIN
|
||||||
drop 2 (PAIR) CF> jump (HERE!)
|
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 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
|
\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0
|
||||||
\ The control-flow stack holds Ld, L0 and 3.
|
\ 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
|
: BEGIN
|
||||||
2 (BRANCH>) (C)+6 a! !
|
2 (BRANCH>) (C)+6 a! !
|
||||||
(LABEL) >CF 23 (OP,)
|
(LABEL) >CF 23 (OP,)
|
||||||
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
|
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
|
||||||
3 jump >CF
|
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,)
|
: 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 ;
|
: 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
|
: 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
|
: REPEAT
|
||||||
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
|
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
|
||||||
CF> 3 (PAIR) CF> (JUMP,) CF> drop
|
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
|
\ 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.
|
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
|
||||||
: (of) over xor ;
|
: (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
|
: 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
|
: OF
|
||||||
CF> 7 (PAIR)
|
CF> 7 (PAIR)
|
||||||
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
|
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
|
||||||
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
|
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
|
||||||
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
|
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
|
||||||
8 jump >CF
|
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
|
: ENDOF
|
||||||
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
|
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
|
||||||
CF> (C)+7 a! ! \ how many jumps to END so far
|
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)+7 a! @ 1 + >CF
|
||||||
(C)+6 a! @ (HERE!) \ N:
|
(C)+6 a! @ (HERE!) \ N:
|
||||||
7 jump >CF
|
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
|
: ENDCASE
|
||||||
CF> 7 (PAIR) CF> (C)+7 a! !
|
CF> 7 (PAIR) CF> (C)+7 a! !
|
||||||
23 (OP,)
|
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!)
|
(C)+6 a! @ jump (HERE!)
|
||||||
PLAIN: drop ;
|
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
|
: 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
|
: ?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)
|
: 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)
|
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
|
||||||
|
|||||||
+12
-12
@@ -32,14 +32,14 @@ macro NEGATE inv 1 + endmacro
|
|||||||
macro NIP push drop pop endmacro
|
macro NIP push drop pop endmacro
|
||||||
|
|
||||||
\ ---- section 4: multiply ------------------------------------------------
|
\ ---- 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)
|
: UM* ROM-UM* push ; \ ( u1 u2 -- ulo uhi ) the ROM's entry 0 (MACHINE.md 2.2)
|
||||||
|
|
||||||
\ ---- section 5.7: doubles ------------------------------------------------
|
\ ---- 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
|
: 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
|
: DNEGATE ROM-DNEGATE push ; \ ( d -- -d ) the ROM's entry 3
|
||||||
|
|
||||||
\ ---- section 5.3: bytes --------------------------------------------------
|
\ ---- 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
|
||||||
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 )
|
: C@ ( baddr -- c )
|
||||||
dup 2/ 2/ a! 3 and
|
dup 2/ 2/ a! 3 and
|
||||||
if K0 -1 + if K1 -1 + if K2
|
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 ;
|
K1: drop @ 8/ 255 and ;
|
||||||
K0: drop @ 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 -- )
|
: C! ( c baddr -- )
|
||||||
dup 2/ 2/ a! 3 and
|
dup 2/ 2/ a! 3 and
|
||||||
if K0 -1 + if K1 -1 + if K2
|
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 + ! ;
|
K0: drop 255 and @ -256 and + ! ;
|
||||||
|
|
||||||
\ ---- section 5.9: strings ------------------------------------------------
|
\ ---- 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 -- )
|
: CMOVE ( src dst u -- )
|
||||||
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
||||||
OK: if DONE push
|
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
|
\ 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
|
\ past the buffer's end, and (OUT^) would never again be at the end to be
|
||||||
\ flushed (MESH.md 7c.6).
|
\ 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 -- )
|
: EMIT ( c -- )
|
||||||
255 and a push push \ A, and then the character, to the return stack
|
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
|
(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
|
(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! ;
|
a (OUT)+256 xor if FULL drop pop a! ;
|
||||||
FULL: drop (FLUSH-OUT) 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 )
|
: KEY ( -- c )
|
||||||
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
|
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
|
||||||
WAIT: drop jump L
|
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
|
: 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
|
: 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 ;
|
: 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 -- )
|
: TYPE ( baddr u -- )
|
||||||
-if OK drop drop NODE-ERROR b! 1 !b ;
|
-if OK drop drop NODE-ERROR b! 1 !b ;
|
||||||
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
|
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
|
||||||
|
|||||||
+36
-23
@@ -10,6 +10,10 @@
|
|||||||
\
|
\
|
||||||
\ name the count byte, then the characters, four bytes to a cell,
|
\ name the count byte, then the characters, four bytes to a cell,
|
||||||
\ padded with zeros to a whole 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 - 3 flags: 1 immediate, 2 hidden, 4 data
|
||||||
\ xt - 2 the word address of the name
|
\ xt - 2 the word address of the name
|
||||||
\ xt - 1 the link: the xt of the entry before this one, 0 for the first
|
\ xt - 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
|
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
|
||||||
HIGH: drop DP b! !b -1 ;
|
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/ ;
|
: 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 ;
|
: 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 ;
|
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
|
||||||
|
|
||||||
\ , calls nothing: the code generator calls it from as deep as anything goes.
|
\ , 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 -- )
|
: , ( x -- )
|
||||||
a!
|
a!
|
||||||
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
|
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 ;
|
drop drop NODE-ERROR b! 5 !b ;
|
||||||
ROOM: drop dup 4 + !b \ DP is past it
|
ROOM: drop dup 4 + !b \ DP is past it
|
||||||
4/ b! a !b ;
|
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 -- )
|
: C, ( c -- )
|
||||||
a! 1 (DP+) if FULL
|
a! 1 (DP+) if FULL
|
||||||
drop a DP b! @b -1 + jump C!
|
drop a DP b! @b -1 + jump C!
|
||||||
FULL: drop ;
|
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
|
: 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
|
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
|
||||||
|
|
||||||
\ ---- the fields of an entry (5.13) -----------------------------------------
|
\ ---- the fields of an entry (5.13) -----------------------------------------
|
||||||
|
|
||||||
: (FLAGS) ( xt -- addr ) -3 + ;
|
: (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 + ;
|
: >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
|
: 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! @ ;
|
: 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* ;
|
: >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
|
: NFA ( xt -- baddr ) jump >NAME
|
||||||
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> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
|
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 4 + ;
|
||||||
set HDR-NFA here ", CFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
set HDR-NFA here ", CFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
||||||
: CFA ( xt -- xt ) ;
|
: 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 ;
|
: 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
|
: >BODY ( xt -- addr ) jump PFA
|
||||||
|
|
||||||
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
|
\ ( 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.
|
\ 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
|
: TRAVERSE
|
||||||
-if NN drop ;
|
-if NN drop ;
|
||||||
NN: if ZERO drop dup C@ 31 and + 1 + ;
|
NN: if ZERO drop dup C@ 31 and + 1 + ;
|
||||||
ZERO: drop ;
|
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 ;
|
: 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 ;
|
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
|
||||||
|
|
||||||
\ ---- telling the kernel (docs/v4.0.0/ENGINE.md 3b) ------------------------------
|
\ ---- 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 ;
|
(WORD-FORGOTTEN) b! @b if NONE push ;
|
||||||
NONE: drop drop ;
|
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 -------------------------------------------------------
|
\ ---- making an entry -------------------------------------------------------
|
||||||
\ (D)+0 where the name starts (D)+1 the name being looked up
|
\ (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)+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
|
\ (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
|
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
|
||||||
\ cells and three more
|
\ cells and four more
|
||||||
: (NEED) (D)+3 a! @ 4 + -4 and 12 + ;
|
: (NEED) (D)+3 a! @ 4 + -4 and 16 + ;
|
||||||
|
|
||||||
\ ( baddr -- ) an entry for the counted string at baddr; its code starts at
|
\ ( 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
|
\ 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
|
DONE: drop
|
||||||
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
|
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
|
||||||
ALIGNED: drop
|
ALIGNED: drop
|
||||||
|
(NEXT-ID) a! @ dup 1 + ! , \ its word ID, and the next
|
||||||
0 , (D) a! @ , LATEST ,
|
0 , (D) a! @ , LATEST ,
|
||||||
HERE CURRENT a! @ a! !
|
HERE CURRENT a! @ a! !
|
||||||
jump (DEFINED)
|
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
|
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
|
||||||
\ input stream, or 0 if it is not in the dictionary.
|
\ 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)
|
: FIND 32 WORD jump (LOOKUP)
|
||||||
|
|
||||||
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
|
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
|
||||||
|
|||||||
@@ -22,6 +22,9 @@ store (SRC) TIB
|
|||||||
\ what COLD comes back to, and the lowest FORGET goes: the nucleus as it is
|
\ what COLD comes back to, and the lowest FORGET goes: the nucleus as it is
|
||||||
store (BOOT) DBASE
|
store (BOOT) DBASE
|
||||||
store (BOOT)+1 HDR-LINK
|
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
|
store FENCE DICT-W
|
||||||
\ nothing has ended badly; nothing has been printed
|
\ nothing has ended badly; nothing has been printed
|
||||||
store (LINE-STATUS) 1
|
store (LINE-STATUS) 1
|
||||||
|
|||||||
+57
-57
@@ -9,15 +9,15 @@
|
|||||||
\ this file.
|
\ this file.
|
||||||
|
|
||||||
\ ---- stack ----
|
\ ---- stack ----
|
||||||
set HDR-NFA here ", DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
|
set HDR-NFA here ", DUP #id, #, 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 ", DROP #id, #, 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 ", OVER #id, #, 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 ", SWAP #id, #, 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 #id, #, 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 ", -ROT #id, #, 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 ", ?DUP #id, #, 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 ", 2DUP #id, #, 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 ", 2DROP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DROP drop drop ;
|
||||||
|
|
||||||
\ ---- the stack as a whole (D-16) ----
|
\ ---- the stack as a whole (D-16) ----
|
||||||
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
|
\ 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.
|
\ anything while n is still there, and never more than one cell after.
|
||||||
|
|
||||||
\ FORTH-79: how many values were on the stack before DEPTH
|
\ 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 ;
|
: DEPTH DSTACK-DEPTH b! @b ;
|
||||||
|
|
||||||
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
|
\ ( 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.
|
\ ( 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.
|
\ 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
|
: PICK
|
||||||
-if POS jump BAD
|
-if POS jump BAD
|
||||||
POS: if 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
|
\ ( 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
|
\ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n
|
||||||
\ less than one is an error.
|
\ 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
|
: ROLL
|
||||||
-if POS jump BAD
|
-if POS jump BAD
|
||||||
POS: if 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)
|
BAD: drop $4C4C4F52 jump (INDEX)
|
||||||
|
|
||||||
\ ---- return stack: in line, and only inside a definition ----
|
\ ---- 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 #id, #, 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> #id, #, 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 ", R@ #id, #, 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 ", I #id, #, 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 ", 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 #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
|
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 #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
|
set HDR-NFA here ", UNLOOP #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
|
||||||
|
|
||||||
\ ---- memory ----
|
\ ---- memory ----
|
||||||
set HDR-NFA here ", @ #, 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 : FETCH a! @ ;
|
||||||
set HDR-NFA here ", ! #, 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 : STORE a! ! ;
|
||||||
set HDR-NFA here ", +! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
|
set HDR-NFA here ", +! #id, #, 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 ", CELLS #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
|
||||||
|
|
||||||
\ ---- arithmetic ----
|
\ ---- arithmetic ----
|
||||||
set HDR-NFA here ", + #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
|
set HDR-NFA here ", + #id, #, 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 : MINUS - ;
|
||||||
\ The low cell of the product, by N steps of +* with nothing but the count on
|
\ 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
|
\ 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
|
\ 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
|
\ 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.
|
\ 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 ", * #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 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
|
set HDR-NFA here ", NEGATE #id, #, 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+ #id, #, 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 ", 1- #id, #, 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+ #id, #, 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- #id, #, 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* #id, #, 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 ", 2/ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO/ 2/ ;
|
||||||
|
|
||||||
\ ---- division (sections 4 and 5.6) ----
|
\ ---- division (sections 4 and 5.6) ----
|
||||||
\ Division by zero is guarded (D-15): each word tests its divisor before it
|
\ 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)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
|
||||||
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
|
(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 ;
|
: 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
|
\ The product's sign waits in (F), not on the return stack, for the same
|
||||||
\ reason as SM/REM's.
|
\ 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 )
|
: M* ( n1 n2 -- d )
|
||||||
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
|
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 ;
|
(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) a! @ -if P drop DNEGATE jump Q P: drop Q:
|
||||||
(F)+2 a! @ jump SM/REM
|
(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 )
|
: /MOD ( n1 n2 -- rem quot )
|
||||||
if Z push S>D pop jump SM/REM
|
if Z push S>D pop jump SM/REM
|
||||||
Z: drop drop 0 $444F4D2F jump (DIV0)
|
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 )
|
: / ( n1 n2 -- quot )
|
||||||
if Z push S>D pop SM/REM NIP ;
|
if Z push S>D pop SM/REM NIP ;
|
||||||
Z: drop drop 0 $2F jump (DIV0)
|
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 )
|
: MOD ( n1 n2 -- rem )
|
||||||
if Z push S>D pop SM/REM drop ;
|
if Z push S>D pop SM/REM drop ;
|
||||||
Z: drop drop 0 $444F4D jump (DIV0)
|
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 )
|
: */MOD ( n1 n2 n3 -- rem quot )
|
||||||
if Z jump (*/MOD)
|
if Z jump (*/MOD)
|
||||||
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
|
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 )
|
: */ ( n1 n2 n3 -- quot )
|
||||||
if Z (*/MOD) NIP ;
|
if Z (*/MOD) NIP ;
|
||||||
Z: drop drop drop 0 $2F2A jump (DIV0)
|
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 )
|
: M/MOD ( d n -- rem quot )
|
||||||
if Z jump SM/REM
|
if Z jump SM/REM
|
||||||
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
|
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
|
||||||
|
|
||||||
\ ---- logic and comparison ----
|
\ ---- logic and comparison ----
|
||||||
set HDR-NFA here ", AND #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
|
set HDR-NFA here ", AND #id, #, 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 ", XOR #id, #, 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 ", OR #id, #, 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= #id, #, 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 ", 0< #id, #, 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 ", NOT #id, #, 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 ", = #id, #, 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 ", < #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
|
||||||
over over xor -if SAME drop drop jump 0<
|
over over xor -if SAME drop drop jump 0<
|
||||||
SAME: 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 ----
|
\ ---- 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 ", BL #id, #, 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 ", TIB #id, #, 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 ", >IN #id, #, 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 ", SPAN #id, #, 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 ", BASE #id, #, 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 ", PAD #id, #, 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 ", STATE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
|
||||||
|
|||||||
@@ -27,7 +27,7 @@
|
|||||||
macro BL 32 endmacro
|
macro BL 32 endmacro
|
||||||
|
|
||||||
\ ( -- baddr u ) the input buffer and how much of it is in use
|
\ ( -- 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: ;
|
: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ;
|
||||||
|
|
||||||
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
|
\ ( 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
|
\ 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 --
|
\ 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).
|
\ 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
|
: EXPECT
|
||||||
-if NN drop drop ; \ n < 0
|
-if NN drop drop ; \ n < 0
|
||||||
NN: if ZERO
|
NN: if ZERO
|
||||||
@@ -57,7 +57,7 @@ set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|||||||
ZERO: drop drop ;
|
ZERO: drop drop ;
|
||||||
|
|
||||||
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
|
\ ( -- ) 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! ! ;
|
: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
|
||||||
|
|
||||||
\ ---- WORD ------------------------------------------------------------------
|
\ ---- WORD ------------------------------------------------------------------
|
||||||
@@ -122,7 +122,7 @@ macro (STEP) (P)+6 a! @ 1 + ! endmacro
|
|||||||
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
|
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
|
||||||
(P)+6 a! @ >IN a! ! WBUF ;
|
(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
|
||||||
(WORD-SET)
|
(WORD-SET)
|
||||||
SK: (LEFT) -if SKE drop (CH) if SKS drop jump (WORD-TAKE) \ past delimiters
|
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:
|
\ ( 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
|
\ 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.
|
\ 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
|
: ENCLOSE
|
||||||
255 and (P) a! ! dup (P)+1 a! !
|
255 and (P) a! ! dup (P)+1 a! !
|
||||||
0 (ESKIP) dup (ESCAN) dup (ESKIP) ;
|
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.
|
\ 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,
|
\ (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.
|
\ 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
|
: CONVERT
|
||||||
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
|
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
|
||||||
-if DIG drop (P)+5 a! @ ;
|
-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 ;
|
ERR0: 0 0 0 ;
|
||||||
|
|
||||||
\ ( baddr -- d ) FORTH-79. What is not a number gives 0 and sets NODE-ERROR.
|
\ ( 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
|
||||||
(NUMBER?) if BAD drop ;
|
(NUMBER?) if BAD drop ;
|
||||||
BAD: drop NODE-ERROR b! 2 !b ;
|
BAD: drop NODE-ERROR b! 2 !b ;
|
||||||
|
|
||||||
\ ---- comments (5.15) -------------------------------------------------------
|
\ ---- comments (5.15) -------------------------------------------------------
|
||||||
\ PAREN skips to the closing parenthesis; BACKSLASH skips the rest of the line.
|
\ 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 ;
|
: 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
|
: BACKSLASH
|
||||||
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
|
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
|
||||||
|
|||||||
+18
-18
@@ -16,16 +16,16 @@
|
|||||||
\ Constants the loader supplies:
|
\ Constants the loader supplies:
|
||||||
\ (LOG-LEVEL) word address of the variable: 2, LOG-INFO, at switch-on
|
\ (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-ERROR #id, #, 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-WARN #id, #, 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-INFO #id, #, 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-TEST #id, #, 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-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! @ ;
|
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
|
||||||
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
|
\ ( 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!
|
: LOG-LEVEL!
|
||||||
-if POS drop 0 jump SET
|
-if POS drop 0 jump SET
|
||||||
POS: dup -5 + -if BIG drop 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
|
P4: drop $34335B1B (EMIT4) $6D (EMIT4) $55424544 (EMIT4) $203A47 (EMIT4) $6D305B1B (EMIT4) jump OUT
|
||||||
OUT: TYPE jump CR
|
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-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 #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 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 #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 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 #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 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 #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-STR ( baddr u -- ) 4 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
|
\ ( 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.
|
\ 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")
|
: (LOG")
|
||||||
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
|
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
|
||||||
COUNT ROT jump (LOG)
|
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
|
STATE a! @ if NOW
|
||||||
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
|
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
|
||||||
NOW: drop WBUF COUNT (Q)+3 a! @ jump (LOG)
|
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-ERROR" #id, #, 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-WARN" #id, #, 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-INFO" #id, #, 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-TEST" #id, #, 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-DEBUG" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
|
||||||
|
|||||||
@@ -28,6 +28,8 @@ constant (S) 15812
|
|||||||
constant (W) 16285
|
constant (W) 16285
|
||||||
constant (X) 15792
|
constant (X) 15792
|
||||||
constant (BOOT) 15750
|
constant (BOOT) 15750
|
||||||
|
constant (NEXT-ID) 15746
|
||||||
|
constant (BOOT-ID) 15747
|
||||||
constant (LOG-LEVEL) 14707
|
constant (LOG-LEVEL) 14707
|
||||||
constant (ACL-HOOK) 14706
|
constant (ACL-HOOK) 14706
|
||||||
constant SCR 15742
|
constant SCR 15742
|
||||||
|
|||||||
@@ -28,6 +28,8 @@ constant (S) 15812
|
|||||||
constant (W) 16285
|
constant (W) 16285
|
||||||
constant (X) 15792
|
constant (X) 15792
|
||||||
constant (BOOT) 15750
|
constant (BOOT) 15750
|
||||||
|
constant (NEXT-ID) 15746
|
||||||
|
constant (BOOT-ID) 15747
|
||||||
constant (LOG-LEVEL) 14707
|
constant (LOG-LEVEL) 14707
|
||||||
constant (ACL-HOOK) 14706
|
constant (ACL-HOOK) 14706
|
||||||
constant SCR 15742
|
constant SCR 15742
|
||||||
|
|||||||
+19
-19
@@ -21,34 +21,34 @@ macro (-ROT) SWAP push SWAP pop endmacro
|
|||||||
: UM/MOD ROM-UM/MOD push ; \ ( ulo uhi ud -- urem uquot )
|
: UM/MOD ROM-UM/MOD push ; \ ( ulo uhi ud -- urem uquot )
|
||||||
|
|
||||||
\ ---- pictured output ----
|
\ ---- 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 ;
|
: <# ( -- ) 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 -- )
|
: HOLD ( c -- )
|
||||||
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
|
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
|
||||||
OKC: drop HLD b! @b -HFLOOR + -if ROOM
|
OKC: drop HLD b! @b -HFLOOR + -if ROOM
|
||||||
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
|
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
|
||||||
ROOM: drop HLD b! @b -1 + dup !b jump C!
|
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 ;
|
: 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 )
|
: # ( ud1 -- ud2 )
|
||||||
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
|
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
|
||||||
(BASE) UM/MOD (-ROT) \ qlo qhi rem
|
(BASE) UM/MOD (-ROT) \ qlo qhi rem
|
||||||
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
|
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 ;
|
: #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 ;
|
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
|
||||||
|
|
||||||
\ ---- spaces and the number base ----
|
\ ---- 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 ;
|
: 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! ! ;
|
: 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! ! ;
|
: 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! ! ;
|
: OCTAL 8 BASE a! ! ;
|
||||||
|
|
||||||
\ ---- numbers ----
|
\ ---- numbers ----
|
||||||
@@ -69,28 +69,28 @@ set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|||||||
: (D.BODY) ( d width -- )
|
: (D.BODY) ( d width -- )
|
||||||
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
|
(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)
|
: 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)
|
: 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)
|
: 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)
|
: 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)
|
: 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)
|
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
|
||||||
|
|
||||||
\ ( addr -- ) print what the cell holds
|
\ ( 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
|
: QUESTION a! @ jump DOT
|
||||||
|
|
||||||
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
|
\ ( -- ) 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
|
\ 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
|
\ left as it was. It reads each value with PICK, so it needs a few cells of
|
||||||
\ the stack free to work in.
|
\ 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
|
: DOT-S
|
||||||
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
|
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
|
||||||
DEPTH (W)+2 b! !b
|
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,
|
\ 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.
|
\ 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@
|
: (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
|
: DUMP
|
||||||
-if OK drop drop NODE-ERROR b! 1 !b ;
|
-if OK drop drop NODE-ERROR b! 1 !b ;
|
||||||
OK: (DP)+2 b! !b (DP)+1 b! !b
|
OK: (DP)+2 b! !b (DP)+1 b! !b
|
||||||
|
|||||||
+23
-23
@@ -24,38 +24,38 @@ macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
|
|||||||
: (QERR12) NODE-ERROR b! 12 !b ;
|
: (QERR12) NODE-ERROR b! 12 !b ;
|
||||||
|
|
||||||
\ ---- conversion and constants ----
|
\ ---- 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 ;
|
: 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 ;
|
: 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.1 #id, #, 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.0 #id, #, 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.SCALE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
|
||||||
|
|
||||||
\ ---- the double words under other names ----
|
\ ---- 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.+ #id, #, 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.- #id, #, 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.ABS #id, #, 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.NEG #id, #, 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.= #id, #, 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.< #id, #, 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.> #id, #, 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.0= #id, #, 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.MAX #id, #, 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.MIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
|
||||||
|
|
||||||
\ ---- multiply ----
|
\ ---- 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)
|
: Q.* ROM-Q.* push ; \ ( a b -- c ) the ROM's entry 4 (MACHINE.md 2.2)
|
||||||
|
|
||||||
\ ---- divide ----
|
\ ---- divide ----
|
||||||
\ D2*C and (UQ/), Q./'s core, are the ROM's (capsules/v4/rom/math.f18).
|
\ 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
|
: Q./ ROM-Q./ push ; \ ( a b -- q ) the ROM's entry 5
|
||||||
|
|
||||||
\ ---- e to the x ----
|
\ ---- 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 )
|
: Q.EXP ( q -- e )
|
||||||
over over OR if ONE drop
|
over over OR if ONE drop
|
||||||
dup (QE)+6 b! !b -if L1 DNEGATE L1:
|
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 ;
|
ONE: drop drop drop 65536 0 ;
|
||||||
|
|
||||||
\ ---- square root ----
|
\ ---- 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 )
|
: Q.SQRT ( q -- r )
|
||||||
dup -if POS drop drop drop 0 0 jump (QERR12)
|
dup -if POS drop drop drop 0 0 jump (QERR12)
|
||||||
POS: drop over over OR if ZERO drop
|
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 ;
|
ONE: drop ;
|
||||||
|
|
||||||
\ ---- natural logarithm ----
|
\ ---- 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 )
|
: Q.LOG ( x -- ln x )
|
||||||
dup -if POS drop jump ERR
|
dup -if POS drop jump ERR
|
||||||
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
|
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
|
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 ;
|
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.SIN ( x -- sin x )
|
||||||
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
|
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
|
||||||
dup (QT)+2 b! !b dup (QT)+3 b! !b
|
dup (QT)+2 b! !b dup (QT)+3 b! !b
|
||||||
0 over 0 Q.* drop (QT)+1 b! !b
|
0 over 0 Q.* drop (QT)+1 b! !b
|
||||||
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
|
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.COS ( x -- cos x )
|
||||||
(Q.REDUCE) -if A1 inv 1 + A1:
|
(Q.REDUCE) -if A1 inv 1 + A1:
|
||||||
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
|
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 ----
|
\ ---- printing ----
|
||||||
\ The integer part, a point, five digits, a blank; always in decimal.
|
\ 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 -- )
|
: Q.PRINT ( q -- )
|
||||||
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
|
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
|
BASE b! @b (QP) b! !b 10 BASE b! !b
|
||||||
|
|||||||
+28
-27
@@ -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.
|
\ 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
|
\ ( 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
|
||||||
(ROUTE#) a! @ -16 + if FULL drop
|
(ROUTE#) a! @ -16 + if FULL drop
|
||||||
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
|
(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
|
\ 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
|
\ when the wiring changes. It is how a node knows who its centre is, the
|
||||||
\ one node whose GONE it believes: (CENTRE).
|
\ 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
|
: NEIGHBOUR
|
||||||
dup -if POS jump BAD
|
dup -if POS jump BAD
|
||||||
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
|
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
|
||||||
BAD: drop drop drop NODE-ERROR b! 12 !b ;
|
BAD: drop drop drop NODE-ERROR b! 12 !b ;
|
||||||
|
|
||||||
\ ( port -- ) the port, by its number, leads toward every node not told of
|
\ ( 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! ! ;
|
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
|
||||||
|
|
||||||
\ ( node -- ) forget the way to that node, if one is known: what is for it
|
\ ( 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
|
\ then goes by the way for every node not told of, if there is one. The
|
||||||
\ last way in the table takes its place.
|
\ 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
|
: NO-ROUTE
|
||||||
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
|
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
|
||||||
FOR dup @+ xor if HIT drop @+ drop NEXT
|
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
|
\ ( 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
|
\ if this node is its centre: it forgets the way to n, and if it is waiting
|
||||||
\ for n's answer the wait ends.
|
\ 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)
|
: GONE 5 jump (SEND1)
|
||||||
|
|
||||||
\ ( -- ) forget every way: for when the wiring has changed
|
\ ( -- ) 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! ! ;
|
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
|
||||||
|
|
||||||
\ ( baddr u node port -- ) send the node u characters of text to
|
\ ( 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,
|
\ ( 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
|
\ 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.
|
\ 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
|
: SEND
|
||||||
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
|
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
|
||||||
GO: jump (SEND-ON)
|
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
|
\ ( 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
|
\ 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.
|
\ 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
|
: SEND-ON
|
||||||
dup -if POS jump BAD
|
dup -if POS jump BAD
|
||||||
POS: -PORTS + -if BAD drop jump (SEND-ON)
|
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.
|
\ does not keep it awake.
|
||||||
\ The stack what it does needs is tried first, (ROOM), core.f18: text that
|
\ The stack what it does needs is tried first, (ROOM), core.f18: text that
|
||||||
\ has left too little ends "Stack overflow" with nothing taken off a wire.
|
\ 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
|
: AWAIT
|
||||||
(ONE) a! ! (ROOM) \ if this faults, no one is waited for:
|
(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
|
(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
|
\ 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
|
\ 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.
|
\ 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!
|
: PORT!
|
||||||
dup -if POS jump BAD
|
dup -if POS jump BAD
|
||||||
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
|
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
|
\ ( -- ) 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
|
\ it and FORGET will not go below it. Whoever has loaded a node's capsules
|
||||||
\ has it do this (system.f18, (BOOT) and FENCE).
|
\ has it do this (system.f18, (BOOT) and FENCE).
|
||||||
set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
set HDR-NFA here ", (SEAL) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
||||||
: (SEAL)
|
: (SEAL)
|
||||||
DP a! @ (BOOT) a! !
|
DP a! @ (BOOT) a! !
|
||||||
(LATEST) a! @ (BOOT)+1 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
|
\ 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.
|
\ 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
|
\ 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
|
\ 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.
|
\ 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 ", NODE-ERROR #id, #, 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 ", (ME) #id, #, 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 ", (CONSOLE) #id, #, 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 ", (LOST) #id, #, 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 ", (REFUSED) #id, #, 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-DEFINED) #id, #, 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 ", (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)
|
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
|
||||||
|
|
||||||
\ FORTH-79: clear the data and return stacks, set execution mode, return
|
\ 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".
|
\ 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
|
\ Both are emptied before anything is called: ABORT may be run with the
|
||||||
\ return stack full.
|
\ 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)
|
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
|
||||||
|
|
||||||
\ ---- faults (D-14, D-16) -------------------------------------------------------
|
\ ---- 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
|
\ 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
|
\ count there instead, so a word that prints text goes no deeper than one
|
||||||
\ that calls any other word.
|
\ 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
|
pop 4* dup C@ \ baddr n
|
||||||
L: if DONE
|
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
|
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
|
||||||
\ it is compiled into runs, if compiling.
|
\ 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
|
: DOT-QUOTE
|
||||||
34 (PARSE) drop
|
34 (PARSE) drop
|
||||||
STATE a! @ if NOW
|
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
|
\ ( 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
|
\ string after the call, start a new line and ABORT; otherwise go on after
|
||||||
\ the string.
|
\ 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")
|
: (ABORT")
|
||||||
if NO
|
if NO
|
||||||
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
|
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
|
\ ( 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.
|
\ 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
|
: ABORT-QUOTE
|
||||||
34 (PARSE) drop
|
34 (PARSE) drop
|
||||||
STATE a! @ if NOW
|
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
|
\ The run time of S" : leave the address and length of the string after the
|
||||||
\ call, and go on after it.
|
\ 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")
|
: (S")
|
||||||
pop 4* dup C@ \ baddr n
|
pop 4* dup C@ \ baddr n
|
||||||
over over + 4/ 1 + push \ the cell after the last character
|
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
|
\ ( -- 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
|
\ 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.
|
\ 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
|
: S-QUOTE
|
||||||
34 (PARSE) drop
|
34 (PARSE) drop
|
||||||
STATE a! @ if NOW
|
STATE a! @ if NOW
|
||||||
|
|||||||
+23
-21
@@ -11,37 +11,37 @@
|
|||||||
\ HEAT-OP ANTICLOCK word addresses of HEAT-OP[0] and ANTICLOCK, the heat
|
\ HEAT-OP ANTICLOCK word addresses of HEAT-OP[0] and ANTICLOCK, the heat
|
||||||
\ registers (DECOMPOSITION.md section 7): read-only
|
\ 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) -----------------------
|
\ ---- the heat registers (DECOMPOSITION.md section 7; #189) -----------------------
|
||||||
\ Captain Bob, 2026-11-12: "Add HEAT-OP". The node counts every instruction it
|
\ 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.
|
\ 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
|
\ ( 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 ;
|
: HEAT-OP@ 31 and HEAT-OP + b! @b ;
|
||||||
\ ( -- n ) the anti-clock: one tick per instruction retired
|
\ ( -- 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 ;
|
: ANTICLOCK@ ANTICLOCK b! @b ;
|
||||||
|
|
||||||
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
|
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
|
||||||
\ A vocabulary is two cells: its head -- the xt of its newest entry, or 0 --
|
\ 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
|
\ 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.
|
\ 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 ", CONTEXT #id, #, 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 ", CURRENT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
|
||||||
|
|
||||||
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
|
\ 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 (LATEST) CONTEXT a! ! ;
|
||||||
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
|
\ 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! ! ;
|
: DEFINITIONS CONTEXT a! @ CURRENT a! ! ;
|
||||||
|
|
||||||
\ VOCABULARY xxx FORTH-79: xxx is a new, empty list of words; executing
|
\ 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,
|
\ xxx makes it the CONTEXT vocabulary. When a search of it finds nothing,
|
||||||
\ FORTH is searched.
|
\ FORTH is searched.
|
||||||
: (DOVOC) pop CONTEXT a! ! ;
|
: (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
|
: VOCABULARY
|
||||||
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
|
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
|
||||||
0 , VOC-LINK a! @ , HERE -2 + VOC-LINK a! ! ;
|
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) ;
|
F: drop drop $54524F46 (EMIT4) $48 (EMIT4) ;
|
||||||
|
|
||||||
\ ( -- ) as v3's, but true: where names are looked for, and where new ones go
|
\ ( -- ) 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
|
: ORDER
|
||||||
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
|
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
|
||||||
CONTEXT a! @ dup (.VOC) SPACE
|
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
|
\ ( -- ) 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
|
\ each, a new line whenever one has passed column 64. Hidden entries -- a
|
||||||
\ definition under way -- are not shown. (Q)+0 is the column.
|
\ 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
|
: WORDS
|
||||||
0 (Q) a! !
|
0 (Q) a! !
|
||||||
CONTEXT a! @ 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! !
|
WRAP: drop CR 0 (Q) a! !
|
||||||
NXT: -1 + a! @ jump L
|
NXT: -1 + a! @ jump L
|
||||||
DONE: drop jump CR
|
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
|
: VLIST jump WORDS
|
||||||
|
|
||||||
\ ( cell -- ) take off a vocabulary's list every entry at or above the
|
\ ( 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
|
\ 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
|
\ is an error, and so is one below FENCE, which is where the capsule's own
|
||||||
\ words are (code 10, "Protected word").
|
\ 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
|
: FORGET
|
||||||
32 WORD (LOOKUP) if MISSING
|
32 WORD (LOOKUP) if MISSING
|
||||||
-2 + a! @ \ where its name starts
|
-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! !
|
C1: drop (LATEST) CONTEXT a! !
|
||||||
C2: CURRENT a! @ (Q) a! @ inv + 1 + -if C3 drop jump TOLD
|
C2: CURRENT a! @ (Q) a! @ inv + 1 + -if C3 drop jump TOLD
|
||||||
C3: drop (LATEST) CURRENT a! !
|
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 ;
|
MISSING: drop (UNKNOWN) drop ;
|
||||||
|
|
||||||
\ ---- the system as a whole -------------------------------------------------------
|
\ ---- 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
|
\ 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.)
|
\ 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 ;
|
: 79-STANDARD ;
|
||||||
|
|
||||||
\ ( -- ) which system this is, and its cell width
|
\ ( -- ) 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
|
: VERSION
|
||||||
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
|
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
|
||||||
N-1 1 + 0 U-DOT-R $7469622D (EMIT4) CR ;
|
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
|
\ ( -- ) 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
|
: 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
|
\ ( -- ) 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
|
: WARM
|
||||||
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
|
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
|
||||||
$74737953 (EMIT4) $72206D65 (EMIT4) $61747365 (EMIT4) $64657472 (EMIT4) $2E (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:
|
\ ( -- ) the system as it was when the capsule had just been loaded:
|
||||||
\ everything defined since is gone, there is one vocabulary, numbers are
|
\ everything defined since is gone, there is one vocabulary, numbers are
|
||||||
\ decimal, the block buffers are empty. Then as WARM.
|
\ 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
|
: COLD
|
||||||
(BOOT) a! @ DP a! !
|
(BOOT) a! @ DP a! !
|
||||||
(BOOT)+1 a! @ (LATEST) a! !
|
(BOOT)+1 a! @ (LATEST) a! !
|
||||||
(BOOT) a! @ 2/ 2/ FENCE a! !
|
(BOOT) a! @ 2/ 2/ FENCE a! !
|
||||||
|
(BOOT-ID) a! @ (NEXT-ID) a! !
|
||||||
(LATEST) CONTEXT a! ! (LATEST) CURRENT a! ! 0 VOC-LINK 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
|
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)
|
(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)
|
: (DODEFER)
|
||||||
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
|
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
|
||||||
UNSET: drop NODE-ERROR b! 15 !b ;
|
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 ;
|
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
|
||||||
: (is!) a! ! ;
|
: (is!) a! ! ;
|
||||||
: (defer@) 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
|
: IS
|
||||||
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
|
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
|
||||||
NOW: drop jump (is!)
|
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@
|
: DEFER@
|
||||||
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
|
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
|
||||||
NOW: drop jump (defer@)
|
NOW: drop jump (defer@)
|
||||||
|
|||||||
+49
-49
@@ -11,57 +11,57 @@
|
|||||||
\ (X) word address of four cells of scratch for COMPARE and SEARCH
|
\ (X) word address of four cells of scratch for COMPARE and SEARCH
|
||||||
|
|
||||||
\ ---- stack ----
|
\ ---- 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 ;
|
: 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
|
: 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
|
: 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 ", 2>R #id, #, 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> #id, #, 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 ", 2R@ #id, #, 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 ", NOP #id, #, 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 ", TRUE #id, #, 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 ", FALSE #id, #, 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 ", INVERT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
|
||||||
|
|
||||||
\ ---- memory ----
|
\ ---- 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! @+ @ ;
|
: 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 !+ ! ;
|
: 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 @ + ! ;
|
: -! ( n addr -- ) a! NEGATE @ + ! ;
|
||||||
|
|
||||||
\ ---- comparison ----
|
\ ---- 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: ;
|
: 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: ;
|
: 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<>
|
: <> 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=
|
: <= 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=
|
: >= 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<
|
: U< over over xor -if SAME drop NIP jump 0<
|
||||||
SAME: drop - 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<
|
: 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: ;
|
: 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 ;
|
: 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 ;
|
: 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 ;
|
: WITHIN ( n low high -- flag ) push over pop LESS push LESS inv pop and ;
|
||||||
|
|
||||||
\ ---- shifts ----
|
\ ---- shifts ----
|
||||||
\ As v3, a count that is negative or as large as the cell is wide is an
|
\ 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").
|
\ 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' )
|
: LSHIFT ( x n -- x' )
|
||||||
-if NN jump BAD
|
-if NN jump BAD
|
||||||
NN: dup N-1 inv + -if BAD2 drop
|
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 ;
|
DONE: drop ;
|
||||||
BAD2: drop
|
BAD2: drop
|
||||||
BAD: drop drop NODE-ERROR b! 9 !b ;
|
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
|
: RSHIFT ( x n -- x' ) \ zeros come in at the top
|
||||||
-if NN jump BAD
|
-if NN jump BAD
|
||||||
NN: dup N-1 inv + -if BAD2 drop
|
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 ;
|
BAD: drop drop NODE-ERROR b! 9 !b ;
|
||||||
|
|
||||||
\ ---- doubles and mixed ----
|
\ ---- 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+
|
: 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: ;
|
: 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=
|
: 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<
|
: 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=
|
: 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 ;
|
: 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 ;
|
: 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+
|
: 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+
|
: M- S>D DNEGATE jump D+
|
||||||
|
|
||||||
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
|
\ ( 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
|
LS: drop push inv pop + inv
|
||||||
S2: -if N2 drop -1 jump D2 N2: drop 0
|
S2: -if N2 drop -1 jump D2 N2: drop 0
|
||||||
D2: pop pop ROT ;
|
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 ;
|
: 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 ;
|
: 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 ;
|
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
|
||||||
|
|
||||||
\ ---- strings and memory ----
|
\ ---- 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 ;
|
: ?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 -- )
|
: CMOVE> ( src dst u -- )
|
||||||
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
||||||
OK: if DONE -1 + push
|
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 ;
|
DONE: drop drop drop ;
|
||||||
|
|
||||||
\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
|
\ 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 -- )
|
: MOVE ( addr1 addr2 n -- )
|
||||||
-if OK drop drop drop ;
|
-if OK drop drop drop ;
|
||||||
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
|
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
|
||||||
DONE: drop drop drop ;
|
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 -- )
|
: FILL ( baddr u c -- )
|
||||||
SWAP push SWAP pop \ c baddr u
|
SWAP push SWAP pop \ c baddr u
|
||||||
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
-if OK drop drop drop NODE-ERROR b! 1 !b ;
|
||||||
OK: if DONE push over over C! 1 + pop -1 + jump OK
|
OK: if DONE push over over C! 1 + pop -1 + jump OK
|
||||||
DONE: drop drop drop ;
|
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
|
: 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
|
: 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' )
|
: -TRAILING ( baddr u -- baddr u' )
|
||||||
-if L drop 0 ;
|
-if L drop 0 ;
|
||||||
L: if DONE over over + -1 + C@ -32 + if SP drop ;
|
L: if DONE over over + -1 + C@ -32 + if SP drop ;
|
||||||
SP: drop -1 + jump L
|
SP: drop -1 + jump L
|
||||||
DONE: ;
|
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 )
|
: COMPARE ( a1 u1 a2 u2 -- n )
|
||||||
-if A drop 0 A: (X)+1 b! !b
|
-if A drop 0 A: (X)+1 b! !b
|
||||||
SWAP -if B drop 0 B: dup (X) 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 ;
|
NN: if ZZ drop 1 ;
|
||||||
ZZ: ;
|
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 )
|
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
|
||||||
-if A drop 0 A: (X)+1 b! !b (X) b! !b
|
-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
|
-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
|
SAME: drop 1 + push 1 + pop pop -1 + jump I
|
||||||
MATCH: drop drop drop -1 ;
|
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' )
|
: SCAN ( baddr u c -- baddr' u' )
|
||||||
255 and push -if L drop 0
|
255 and push -if L drop 0
|
||||||
L: if DONE over C@ pop dup push xor if FOUND
|
L: if DONE over C@ pop dup push xor if FOUND
|
||||||
drop push 1 + pop -1 + jump L
|
drop push 1 + pop -1 + jump L
|
||||||
FOUND: drop
|
FOUND: drop
|
||||||
DONE: pop 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' )
|
: SKIP ( baddr u c -- baddr' u' )
|
||||||
255 and push -if L drop 0
|
255 and push -if L drop 0
|
||||||
L: if DONE over C@ pop dup push xor if SAME drop jump DONE
|
L: if DONE over C@ pop dup push xor if SAME drop jump DONE
|
||||||
|
|||||||
@@ -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.
|
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
|
- **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).
|
(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).
|
||||||
|
|||||||
@@ -18,6 +18,8 @@
|
|||||||
(REFUSED) ( -- addr ) Variable: a count of the messages that came back to this node, refused.
|
(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.
|
(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.
|
(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).
|
(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-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.
|
(WORD-FORGOTTEN) ( -- addr ) Variable: the hook told when entries are forgotten, with the word address they went from.
|
||||||
|
|||||||
|
Can't render this file because it contains an unexpected character in line 10 and column 3.
|
@@ -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).
|
||||||
@@ -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);
|
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
|
* 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
|
* word-execution residents only (item 4.1's cells, tracked in this file's
|
||||||
|
|||||||
@@ -72,6 +72,32 @@ static v4_fabric_node sk_v4_nucleus, sk_v4_hera;
|
|||||||
static v4_image sk_v4_image;
|
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 */
|
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)
|
static v4_fabric_node *sk_v4_room(void *self)
|
||||||
{
|
{
|
||||||
v4_fabric_node *x = (v4_fabric_node *)kmalloc(sizeof *x);
|
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;
|
sk_v4_keyed[k] = number;
|
||||||
}
|
}
|
||||||
stadium_ops_charge(stadium_node_key((uint32_t)number), x->h.op, now);
|
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
|
#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.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.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.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.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.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;
|
sk_v4_mesh.serve = sk_v4_serve;
|
||||||
|
|||||||
@@ -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) {
|
void stadium_word_forget(VMUuid vm_id, uint32_t word_id) {
|
||||||
int slot;
|
int slot;
|
||||||
size_t cell;
|
size_t cell;
|
||||||
|
|||||||
@@ -19,9 +19,11 @@ CC ?= cc
|
|||||||
CFLAGS := -std=c99 -Wall -Wextra -Werror -O2 -g -I$(HERE) -I$(ROOT)/kernel/include \
|
CFLAGS := -std=c99 -Wall -Wextra -Werror -O2 -g -I$(HERE) -I$(ROOT)/kernel/include \
|
||||||
-I$(ROOT)/kernel/include/starkernel -I$(ROOT)/v3/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
|
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__
|
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
|
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__
|
EXTRA_test_stadium_node := -D__STARKERNEL__
|
||||||
SRC_test_physics_l2 := $(ROOT)/v3/src/physics_execution_hooks.c
|
SRC_test_physics_l2 := $(ROOT)/v3/src/physics_execution_hooks.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 <stdarg.h>
|
||||||
|
#include <string.h>
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
|
||||||
|
void *kmalloc(size_t size) { return calloc(1, size); }
|
||||||
|
void kfree(void *ptr) { free(ptr); }
|
||||||
|
kmalloc_stats_t kmalloc_get_stats(void)
|
||||||
|
{
|
||||||
|
kmalloc_stats_t s;
|
||||||
|
memset(&s, 0, sizeof s);
|
||||||
|
s.free_bytes = 512u * 1024u * 1024u;
|
||||||
|
return s;
|
||||||
|
}
|
||||||
|
void log_message(int level, const char *fmt, ...) { (void)level; (void)fmt; }
|
||||||
|
void sk_hal_panic(const char *message) { printf("PANIC: %s\n", message); exit(2); }
|
||||||
|
int blk_flush(uint32_t block_num) { (void)block_num; return 0; }
|
||||||
|
|
||||||
|
int main(void)
|
||||||
|
{
|
||||||
|
VMUuid a = stadium_node_key(10);
|
||||||
|
uint64_t q = (uint64_t)STADIUM_WORD_HEAT_QUANTUM, r0, pullable;
|
||||||
|
uint32_t ids[3];
|
||||||
|
uint64_t calls[3];
|
||||||
|
|
||||||
|
CHECK(stadium_boot_init_for(a) == 0 && session_boot_init() == 0 && stadium_birth_node(a, "Hera") == 0,
|
||||||
|
"a Stadium with the node born in it");
|
||||||
|
stadium_words_init();
|
||||||
|
|
||||||
|
/* the same as that many dispatches: word 7 charged five calls, word 8 dispatched five times */
|
||||||
|
ids[0] = 7; calls[0] = 5;
|
||||||
|
r0 = stadium_reservoir_peek(a);
|
||||||
|
stadium_words_charge(a, ids, calls, 1, 2);
|
||||||
|
CHECK(stadium_reservoir_peek(a) == r0 - 5u * q && stadium_words_resident_heat(a) == 5u * q,
|
||||||
|
"five calls of word 7 pull five quanta, and it holds them: %llu", (unsigned long long)(r0 - stadium_reservoir_peek(a)));
|
||||||
|
{
|
||||||
|
unsigned k;
|
||||||
|
r0 = stadium_reservoir_peek(a);
|
||||||
|
for (k = 0; k < 5; k++) stadium_word_dispatch(a, 8, 2);
|
||||||
|
CHECK(stadium_reservoir_peek(a) == r0 - 5u * q && stadium_words_resident_heat(a) == 10u * q,
|
||||||
|
"the same as five dispatches of a word");
|
||||||
|
}
|
||||||
|
CHECK(stadium_conserved(a), "conservation holds");
|
||||||
|
/* a resident word cools by the ticks since, once, then takes its calls: as its dispatches would */
|
||||||
|
{
|
||||||
|
uint64_t before = stadium_words_resident_heat(a);
|
||||||
|
ids[0] = 7; calls[0] = 2;
|
||||||
|
stadium_words_charge(a, ids, calls, 1, 12);
|
||||||
|
ids[0] = 8; calls[0] = 1;
|
||||||
|
stadium_word_dispatch(a, 8, 12); stadium_word_dispatch(a, 8, 12);
|
||||||
|
CHECK(stadium_words_resident_heat(a) < before + 4u * q, "ten ticks on, both cooled before they took their calls");
|
||||||
|
CHECK(stadium_conserved(a), "conservation holds");
|
||||||
|
}
|
||||||
|
|
||||||
|
/* no calls, nothing */
|
||||||
|
ids[0] = 9; calls[0] = 0;
|
||||||
|
r0 = stadium_reservoir_peek(a);
|
||||||
|
stadium_words_charge(a, ids, calls, 1, 3);
|
||||||
|
CHECK(stadium_reservoir_peek(a) == r0, "a word with no calls is not charged");
|
||||||
|
|
||||||
|
/* more wanted than there is: shared by calls, the floor left */
|
||||||
|
pullable = stadium_reservoir_peek(a) - Q48_ONE / 3;
|
||||||
|
ids[0] = 20; calls[0] = 3 * (pullable / q);
|
||||||
|
ids[1] = 21; calls[1] = 1 * (pullable / q);
|
||||||
|
stadium_words_charge(a, ids, calls, 2, 4);
|
||||||
|
CHECK(stadium_reservoir_peek(a) >= Q48_ONE / 3 && stadium_reservoir_peek(a) - Q48_ONE / 3 < 4u,
|
||||||
|
"the reservoir is left at its third");
|
||||||
|
CHECK(stadium_conserved(a), "conservation holds when the calls want more than there is");
|
||||||
|
|
||||||
|
|
||||||
|
return DONE();
|
||||||
|
}
|
||||||
@@ -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.
|
||||||
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user