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

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

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

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

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_017RzZgrf7V7Zk2iczBXDRbm
This commit is contained in:
Claude
2026-11-13 19:12:44 +00:00
parent d64ad4a1c3
commit e8e7ec8b9f
44 changed files with 1060 additions and 349 deletions
Download Patch File Download Diff File Expand all files Collapse all files
capsules/v4/sys/acl.f18
+13 -13
View File
@@ -18,25 +18,25 @@
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
: (PINNED) -3 + a! @ 64 and ;
set HDR-NFA here ", ACL-HOOK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
set HDR-NFA here ", ACL-HOOK #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
set HDR-NFA here ", ACL-MODE@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-MODE@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
set HDR-NFA here ", ACL-TTL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-TTL@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
set HDR-NFA here ", ACL-ALLOW@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-ALLOW@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
set HDR-NFA here ", ACL-PINNED? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-PINNED? #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
set HDR-NFA here ", ACL-PIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-PIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
set HDR-NFA here ", ACL-MODE! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-MODE! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-MODE! ( mode xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop 255 and 8* @ -65281 and + ! ;
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-TTL! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-TTL! ( n xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop
@@ -44,7 +44,7 @@ set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
POS: dup -65536 and if SMALL drop drop 65535 jump SET
SMALL: drop
SET: 8* 8* @ 65535 and + ! ;
set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-ALLOW! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-ALLOW! ( flag xt -- )
(ACL-XT) (PINNED) if FREE drop drop ;
FREE: drop if DENY drop @ -33 and ! ;
@@ -52,7 +52,7 @@ set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
\ is 0 and it is allowed. This is the one word that unpins.
set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-INHERIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-INHERIT
(ACL-XT) SWAP (ACL-XT) \ dst src
-3 + a! @ $FF00 and \ dst mode
@@ -67,7 +67,7 @@ set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK he
NXT: -1 + a! @ jump L
DONE: drop ;
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-INIT-PRIMITIVES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-INIT-PRIMITIVES
(LATEST) a! @ (ACL-INIT)
VOC-LINK a! @
@@ -76,8 +76,8 @@ set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR
\ ( xt -- heat ) how often the word has been used. The node's heat
\ counters are not readable from a programme yet (D-6): 0.
set HDR-NFA here ", ACL-HEAT@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-HEAT@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-HEAT@ (ACL-XT) drop 0 ;
\ ( xt -- n ) a number for the word that never changes: its address
set HDR-NFA here ", ACL-WORD-ID #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ACL-WORD-ID #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ACL-WORD-ID (ACL-XT) ;
capsules/v4/sys/blocks.f18
+12 -12
View File
@@ -25,8 +25,8 @@
\ SCR word address of the variable: the block LIST showed last
\ BLK (SRC) (SRC-HOOK) see input.f18
set HDR-NFA here ", SCR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SCR' SCR ;
set HDR-NFA here ", BLK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BLK' BLK ;
set HDR-NFA here ", SCR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SCR' SCR ;
set HDR-NFA here ", BLK #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BLK' BLK ;
\ ( status -- ) a request that did not work is an error
: (B-ERR)
@@ -41,27 +41,27 @@ set HDR-NFA here ", BLK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL
\ ( n -- baddr ) FORTH-79: the address of a buffer assigned to block n.
\ What the buffer holds is not read from storage.
set HDR-NFA here ", BUFFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BUFFER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BUFFER BUFFER# (PORT) b! !b jump (B-GOT)
\ ( n -- baddr ) FORTH-79: the address of a buffer that holds block n,
\ read from storage if it is not already in one.
set HDR-NFA here ", BLOCK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BLOCK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BLOCK BLOCK# (PORT) b! !b jump (B-GOT)
\ FORTH-79: mark the block most recently asked for as changed, so that it is
\ written before its buffer is used for another.
set HDR-NFA here ", UPDATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UPDATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UPDATE UPDATE# (PORT) b! !b jump (B-ERR)
\ FORTH-79: write every block that has been UPDATEd.
set HDR-NFA here ", SAVE-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SAVE-BUFFERS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SAVE-BUFFERS SAVE-BUFFERS# (PORT) b! !b jump (B-ERR)
\ As v3: the same.
set HDR-NFA here ", FLUSH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FLUSH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FLUSH jump SAVE-BUFFERS
\ FORTH-79: forget what is in the buffers; nothing is written.
set HDR-NFA here ", EMPTY-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EMPTY-BUFFERS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EMPTY-BUFFERS EMPTY-BUFFERS# (PORT) b! !b ;
\ ---- LIST ----------------------------------------------------------------------
@@ -69,7 +69,7 @@ set HDR-NFA here ", EMPTY-BUFFERS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK
\ characters, each after its number, and an empty line. SCR is left holding n. A character
\ that is not printable is shown as a blank. (Q)+0 is the line, (Q)+1 the
\ column, (Q)+2 the block's number.
set HDR-NFA here ", LIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LIST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LIST
dup (Q)+2 a! ! BLOCK drop \ an error here leaves nothing behind
(Q)+2 a! @ dup SCR a! !
@@ -101,7 +101,7 @@ set HDR-NFA here ", LIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
TERM: drop ;
\ ( n -- ) FORTH-79: interpret block n, then go on with what follows.
set HDR-NFA here ", LOAD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOAD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOAD
-if POS jump BAD
POS: if BAD
@@ -114,13 +114,13 @@ set HDR-NFA here ", LOAD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) go on with the next block. Only in a block being loaded: at the
\ terminal it is an error (code 14).
set HDR-NFA here ", --> #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", --> #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NEXT-BLOCK
BLK a! @ if TERM 1 + ! 0 >IN a! ! ;
TERM: drop NODE-ERROR b! 14 !b ;
\ ( first last -- ) as v3: LOAD each block from first to last.
set HDR-NFA here ", THRU #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", THRU #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: THRU
push
L: dup inv pop dup push + 1 + -if GO drop drop pop drop ; \ last - first
capsules/v4/sys/compile.f18
+35 -35
View File
@@ -149,7 +149,7 @@ macro ROT push SWAP pop SWAP endmacro
\ ( -- ) print the word WORD has just left
: (.WORD) WBUF COUNT jump TYPE
set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXECUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ It calls the word, so that the hook at `call` sees it (#189, ENGINE.md 6,
\ ruled 2026-10-20): a `call xt` instruction word -- `call`, opcode 3, in slot
\ 0, the address in the 27 bits below it -- is put in (EXEC) with a ; after
@@ -193,7 +193,7 @@ set HDR-NFA here ", EXECUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ on the stack, or compiled as a literal. What is neither, or a compile-only
\ word met while interpreting, abandons the line, with v3's message:
\ UNKNOWN WORD: 'xxx' xxx: compile-only
set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", INTERPRET #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: INTERPRET
: (IL) 32 WORD dup C@ if EOL
drop (LOOKUP) if NUM
@@ -225,25 +225,25 @@ set HDR-NFA here ", INTERPRET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ---- state ---------------------------------------------------------------------
set HDR-NFA here ", [ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LEFT-BRACKET 0 STATE a! ! ;
set HDR-NFA here ", ] #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ] #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: RIGHT-BRACKET -1 STATE a! ! ;
\ ( x -- ) FORTH-79: if compiling, compile x as a literal
set HDR-NFA here ", LITERAL #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LITERAL #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LITERAL STATE a! @ if NO drop jump (LIT,) NO: drop ;
\ ( -- addr ) FORTH-79: the next word's parameter field address; if
\ compiling, compiled as a literal
set HDR-NFA here ", ' #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ' #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TICK (') jump LITERAL
\ ['] xxx the same inside a definition, whatever STATE is; and [LITERAL],
\ which v3 has as another name for LITERAL.
set HDR-NFA here ", ['] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ['] #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-TICK (') jump (LIT,)
set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [LITERAL] #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-LITERAL jump LITERAL
\ ---- colon definitions -----------------------------------------------------------
@@ -251,7 +251,7 @@ set HDR-NFA here ", [LITERAL] #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: start a definition; it cannot be found until ; ends it. The
\ CONTEXT vocabulary is set to the CURRENT one.
\ (C)+2 holds LATEST while the entry is made, to tell whether one was.
set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", : #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COLON
CURRENT a! @ CONTEXT a! !
LATEST (C)+2 a! !
@@ -261,7 +261,7 @@ set HDR-NFA here ", : #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
NONE: drop jump (ABANDON) \ no entry: the rest of the line is not a definition
\ FORTH-79: compile the return, let the word be found, stop compiling
set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ; #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEMICOLON
0 (OP,)
LATEST (FLAGS) a! @ -3 and !
@@ -276,27 +276,27 @@ set HDR-NFA here ", ; #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ what a word that is a C function in v3 -- BIRTH, BLOCK, BYE -- is on a
\ node. Not FORTH-79 and not in v3, where such a word is registered from C.
\ The constant (PORT) is the port's word address.
set HDR-NFA here ", KERNEL-WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", KERNEL-WORD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KERNEL-WORD
COLON (LIT,) (PORT) (LIT,) 30 (OP,) 14 (OP,) \ n port b! !b
jump SEMICOLON
\ FORTH-79: return from the definition at this point
set HDR-NFA here ", EXIT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXIT #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXIT 0 jump (OP,)
set HDR-NFA here ", IMMEDIATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IMMEDIATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IMMEDIATE LATEST if NONE (FLAGS) a! @ 1 OR ! ; NONE: drop ;
\ COMPILE xxx FORTH-79: when the word this is in runs, xxx is compiled
set HDR-NFA here ", COMPILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COMPILE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COMPILE
32 WORD (LOOKUP) if MISSING
(LIT,) &(COMPILE,) jump (CALL,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
\ [COMPILE] xxx FORTH-79: compile xxx even though it is immediate
set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", [COMPILE] #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BRACKET-COMPILE
32 WORD (LOOKUP) if MISSING jump (COMPILE,)
MISSING: drop (UNKNOWN) drop jump (ABANDON)
@@ -324,16 +324,16 @@ set HDR-NFA here ", [COMPILE] #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK her
NONE: drop ;
\ FORTH-79: an entry whose word leaves the address of its parameter field
set HDR-NFA here ", CREATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CREATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CREATE &(DOVAR) (C)+3 a! ! jump (DATA)
\ FORTH-79: CREATE and one cell. The standard leaves its first value to the
\ programme; here it is 0.
set HDR-NFA here ", VARIABLE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VARIABLE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VARIABLE &(DOVAR) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
\ ( n -- ) FORTH-79: an entry whose word leaves n
set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CONSTANT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CONSTANT &(DOCON) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop jump , NONE: drop drop ;
\ FORTH-79: in : DEFINER CREATE ... DOES> ... ; the words after DOES> become
@@ -342,7 +342,7 @@ set HDR-NFA here ", CONSTANT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ call to the code after it and leaves DEFINER; that code starts with pop,
\ which fetches the parameter field address the call left.
: (DOES) pop 402653184 + LATEST a! ! ; \ 402653184 is `call` in slot 0
set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DOES> #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOES> &(DOES) (CALL,) 25 jump (OP,)
\ ---- control structures (5.18, section 2) ---------------------------------------------
@@ -362,15 +362,15 @@ set HDR-NFA here ", DOES> #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ Native if leaves the flag, so both ways out of it drop it (section 2):
\ IF a THEN if L1 drop a jump L2 L1: drop L2:
\ IF a ELSE b THEN if L1 drop a jump L2 L1: drop b L2:
set HDR-NFA here ", IF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IF 6 (BRANCH>) >CF 23 (OP,) 1 jump >CF
set HDR-NFA here ", ELSE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ELSE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ELSE
CF> 1 (PAIR) CF> (C)+6 a! ! \ the if
2 (BRANCH>) >CF \ the jump over the else part
(C)+6 a! @ (HERE!) 23 (OP,)
2 jump >CF
set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", THEN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: THEN
CF> dup -1 + if PLAIN
drop 2 (PAIR) CF> jump (HERE!)
@@ -386,19 +386,19 @@ set HDR-NFA here ", THEN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ BEGIN a WHILE b REPEAT jump L0 Ld: drop L0: a if Lx drop b jump L0 Lx: drop
\ BEGIN a AGAIN jump L0 Ld: drop L0: a jump L0
\ The control-flow stack holds Ld, L0 and 3.
set HDR-NFA here ", BEGIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BEGIN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BEGIN
2 (BRANCH>) (C)+6 a! !
(LABEL) >CF 23 (OP,)
(LABEL) dup >CF (C)+6 a! @ (RESOLVE)
3 jump >CF
set HDR-NFA here ", UNTIL #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UNTIL #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UNTIL CF> 3 (PAIR) CF> drop CF> 6 (BRANCH,) 23 jump (OP,)
set HDR-NFA here ", AGAIN #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", AGAIN #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: AGAIN CF> 3 (PAIR) CF> (JUMP,) CF> drop ;
set HDR-NFA here ", WHILE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WHILE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WHILE CF> 3 (PAIR) 3 >CF 6 (BRANCH>) >CF 23 (OP,) 4 jump >CF
set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", REPEAT #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: REPEAT
CF> 4 (PAIR) CF> (C)+6 a! ! \ the while
CF> 3 (PAIR) CF> (JUMP,) CF> drop
@@ -412,16 +412,16 @@ set HDR-NFA here ", REPEAT #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ value for, with END after it. The control-flow stack holds the jumps to
\ END, how many there are, and 7; inside a clause, the jump to N and 8.
: (of) over xor ;
set HDR-NFA here ", CASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CASE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CASE 0 >CF 7 jump >CF
set HDR-NFA here ", OF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", OF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: OF
CF> 7 (PAIR)
&(of) (INLINE,) 6 (BRANCH>) (C)+6 a! ! \ if M
23 (OP,) 2 (BRANCH>) >CF \ drop, jump N
(C)+6 a! @ (HERE!) 23 (OP,) 23 (OP,) \ M: drop drop
8 jump >CF
set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENDOF #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDOF
CF> 8 (PAIR) CF> (C)+6 a! ! \ the jump to N
CF> (C)+7 a! ! \ how many jumps to END so far
@@ -429,7 +429,7 @@ set HDR-NFA here ", ENDOF #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(C)+7 a! @ 1 + >CF
(C)+6 a! @ (HERE!) \ N:
7 jump >CF
set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENDCASE #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENDCASE
CF> 7 (PAIR) CF> (C)+7 a! !
23 (OP,)
@@ -477,11 +477,11 @@ set HDR-NFA here ", ENDCASE #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(C)+6 a! @ jump (HERE!)
PLAIN: drop ;
set HDR-NFA here ", DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DO #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DO &(do) (INLINE,) (LABEL) >CF 5 jump >CF
set HDR-NFA here ", ?DO #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ?DO #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?DO &(?do) (INLINE,) 6 (BRANCH>) >CF 23 (OP,) &(do) (INLINE,) (LABEL) >CF 6 jump >CF
set HDR-NFA here ", LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOOP #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOOP &(inc) (INLINE,) 0 (C)+5 a! ! jump (LOOPS)
set HDR-NFA here ", +LOOP #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", +LOOP #id, #, 17 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: +LOOP &(+inc) (INLINE,) &(a-xor) (C)+5 a! ! jump (LOOPS)
capsules/v4/sys/core.f18
+12 -12
View File
@@ -32,14 +32,14 @@ macro NEGATE inv 1 + endmacro
macro NIP push drop pop endmacro
\ ---- section 4: multiply ------------------------------------------------
set HDR-NFA here ", UM* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", UM* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: UM* ROM-UM* push ; \ ( u1 u2 -- ulo uhi ) the ROM's entry 0 (MACHINE.md 2.2)
\ ---- section 5.7: doubles ------------------------------------------------
set HDR-NFA here ", D+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D+ ROM-D+ push ; \ ( d1 d2 -- d3 ) the ROM's entry 2
set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DNEGATE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DNEGATE ROM-DNEGATE push ; \ ( d -- -d ) the ROM's entry 3
\ ---- section 5.3: bytes --------------------------------------------------
@@ -50,7 +50,7 @@ set HDR-NFA here ", DNEGATE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
macro 8/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ endmacro
macro 8* 2* 2* 2* 2* 2* 2* 2* 2* endmacro
set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C@ ( baddr -- c )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
@@ -59,7 +59,7 @@ set HDR-NFA here ", C@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
K1: drop @ 8/ 255 and ;
K0: drop @ 255 and ;
set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C! ( c baddr -- )
dup 2/ 2/ a! 3 and
if K0 -1 + if K1 -1 + if K2
@@ -69,7 +69,7 @@ set HDR-NFA here ", C! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
K0: drop 255 and @ -256 and + ! ;
\ ---- section 5.9: strings ------------------------------------------------
set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CMOVE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CMOVE ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push
@@ -421,7 +421,7 @@ set HDR-NFA here ", CMOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EMIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EMIT ( c -- )
255 and a push push \ A, and then the character, to the return stack
(OUT^) b! @b (OUT)+256 xor if STALE drop jump PUT
@@ -430,18 +430,18 @@ set HDR-NFA here ", EMIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(OUT^) b! @b a! pop !+ a !b \ the character goes where (OUT^) points, which moves on
a (OUT)+256 xor if FULL drop pop a! ;
FULL: drop (FLUSH-OUT) pop a! ;
set HDR-NFA here ", KEY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", KEY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: KEY ( -- c )
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
WAIT: drop jump L
set HDR-NFA here ", CR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CR ( -- ) 10 jump EMIT
set HDR-NFA here ", SPACE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SPACE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACE ( -- ) 32 jump EMIT
set HDR-NFA here ", COUNT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COUNT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COUNT ( baddr -- baddr+1 c ) dup C@ push 1 + pop ;
set HDR-NFA here ", TYPE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", TYPE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TYPE ( baddr u -- )
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK
capsules/v4/sys/dict.f18
+36 -23
View File
@@ -10,6 +10,10 @@
\
\ name the count byte, then the characters, four bytes to a cell,
\ padded with zeros to a whole cell
\ xt - 4 the word ID: what the kernel's record of the word is kept by
\ (ENGINE.md 3b; #189 Phase 2, Captain Bob 2026-11-13: "ID field in
\ the header"). The next is in (NEXT-ID); FORGET gives back the
\ IDs of what it removes, which are always the newest
\ xt - 3 flags: 1 immediate, 2 hidden, 4 data
\ xt - 2 the word address of the name
\ xt - 1 the link: the xt of the entry before this one, 0 for the first
@@ -63,15 +67,15 @@ macro OR over inv and xor endmacro
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
HIGH: drop DP b! !b -1 ;
set HDR-NFA here ", HERE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HERE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
set HDR-NFA here ", ALIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ALIGN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
set HDR-NFA here ", ALLOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ALLOT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
set HDR-NFA here ", , #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", , #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: , ( x -- )
a!
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
@@ -79,50 +83,50 @@ set HDR-NFA here ", , #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
drop drop NODE-ERROR b! 5 !b ;
ROOM: drop dup 4 + !b \ DP is past it
4/ b! a !b ;
set HDR-NFA here ", C, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", C, #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: C, ( c -- )
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
set HDR-NFA here ", 2, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2, #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
set HDR-NFA here ", LATEST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LATEST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LATEST ( -- xt ) CURRENT a! @ a! @ ; \ the newest entry of the CURRENT vocabulary
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
set HDR-NFA here ", >LINK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >LINK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >LINK ( xt -- addr ) -1 + ;
set HDR-NFA here ", LFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LFA ( xt -- addr ) jump >LINK
set HDR-NFA here ", LINK> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LINK> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LINK> ( addr -- xt ) a! @ ;
set HDR-NFA here ", >NAME #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >NAME #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
set HDR-NFA here ", NFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NFA ( xt -- baddr ) jump >NAME
set HDR-NFA here ", NAME> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
set HDR-NFA here ", CFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NAME> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 4 + ;
set HDR-NFA here ", CFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CFA ( xt -- xt ) ;
set HDR-NFA here ", PFA #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PFA #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
set HDR-NFA here ", >BODY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >BODY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >BODY ( xt -- addr ) jump PFA
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
set HDR-NFA here ", TRAVERSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", TRAVERSE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
set HDR-NFA here ", SMUDGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SMUDGE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HIDDEN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
\ ---- telling the kernel (docs/v4.0.0/ENGINE.md 3b) ------------------------------
@@ -145,14 +149,22 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(WORD-FORGOTTEN) b! @b if NONE push ;
NONE: drop drop ;
\ ( xt -- ) and ( w -- ) the words a kernel that keeps records puts in (WORD-DEFINED) and
\ (WORD-FORGOTTEN): requests -19 and -20 to the kernel on the node's port 0, which takes the xt or
\ the word address off the stack (v4/mesh.h; #189, Phase 2). A host that keeps none leaves both 0.
set HDR-NFA here ", (TELL-DEFINED) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (TELL-DEFINED) -19 (PORT) b! !b ;
set HDR-NFA here ", (TELL-FORGOTTEN) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (TELL-FORGOTTEN) -20 (PORT) b! !b ;
\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count (D)+4 whether a lookup has gone on to FORTH
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
: (NEED) (D)+3 a! @ 4 + -4 and 12 + ;
\ cells and four more
: (NEED) (D)+3 a! @ 4 + -4 and 16 + ;
\ ( baddr -- ) an entry for the counted string at baddr; its code starts at
\ HERE afterwards. An empty name, or no room, makes nothing and sets
@@ -175,6 +187,7 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop
(NEXT-ID) a! @ dup 1 + ! , \ its word ID, and the next
0 , (D) a! @ , LATEST ,
HERE CURRENT a! @ a! !
jump (DEFINED)
@@ -216,7 +229,7 @@ set HDR-NFA here ", HIDDEN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
set HDR-NFA here ", FIND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FIND #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FIND 32 WORD jump (LOOKUP)
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
capsules/v4/sys/end.f18
+3
View File
@@ -22,6 +22,9 @@ store (SRC) TIB
\ what COLD comes back to, and the lowest FORGET goes: the nucleus as it is
store (BOOT) DBASE
store (BOOT)+1 HDR-LINK
\ the word IDs: the system's are 0 .. #ids - 1, numbered as assembled (#189, Phase 2)
store (NEXT-ID) #ids
store (BOOT-ID) #ids
store FENCE DICT-W
\ nothing has ended badly; nothing has been printed
store (LINE-STATUS) 1
capsules/v4/sys/forth.f18
+57 -57
View File
@@ -9,15 +9,15 @@
\ this file.
\ ---- stack ----
set HDR-NFA here ", DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
set HDR-NFA here ", DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DROP drop ;
set HDR-NFA here ", OVER #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OVER over ;
set HDR-NFA here ", SWAP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SWAP' SWAP ;
set HDR-NFA here ", ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ROT' ROT ;
set HDR-NFA here ", -ROT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : -ROT SWAP push SWAP pop ;
set HDR-NFA here ", ?DUP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ?DUP if Z dup ; Z: ;
set HDR-NFA here ", 2DUP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DUP over over ;
set HDR-NFA here ", 2DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DROP drop drop ;
set HDR-NFA here ", DUP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DUP dup ;
set HDR-NFA here ", DROP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : DROP drop ;
set HDR-NFA here ", OVER #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OVER over ;
set HDR-NFA here ", SWAP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SWAP' SWAP ;
set HDR-NFA here ", ROT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ROT' ROT ;
set HDR-NFA here ", -ROT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : -ROT SWAP push SWAP pop ;
set HDR-NFA here ", ?DUP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ?DUP if Z dup ; Z: ;
set HDR-NFA here ", 2DUP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DUP over over ;
set HDR-NFA here ", 2DROP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2DROP drop drop ;
\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
@@ -28,7 +28,7 @@ set HDR-NFA here ", 2DROP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here :
\ anything while n is still there, and never more than one cell after.
\ FORTH-79: how many values were on the stack before DEPTH
set HDR-NFA here ", DEPTH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEPTH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEPTH DSTACK-DEPTH b! @b ;
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
@@ -60,7 +60,7 @@ set HDR-NFA here ", DEPTH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n -- x ) FORTH-79: a copy of the n-th value, not counting n itself.
\ 1 PICK is DUP, 2 PICK is OVER. n less than one is an error.
set HDR-NFA here ", PICK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PICK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PICK
-if POS jump BAD
POS: if BAD
@@ -72,7 +72,7 @@ set HDR-NFA here ", PICK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n -- ) FORTH-79: the n-th value, not counting n itself, is taken out
\ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n
\ less than one is an error.
set HDR-NFA here ", ROLL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ROLL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ROLL
-if POS jump BAD
POS: if BAD
@@ -82,36 +82,36 @@ set HDR-NFA here ", ROLL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
BAD: drop $4C4C4F52 jump (INDEX)
\ ---- return stack: in line, and only inside a definition ----
set HDR-NFA here ", >R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >R push ;
set HDR-NFA here ", R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R> pop ;
set HDR-NFA here ", R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R@ pop dup push ;
set HDR-NFA here ", I #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : I pop dup push ;
set HDR-NFA here ", J #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : J pop pop pop dup push a! push push a ;
set HDR-NFA here ", LEAVE #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
set HDR-NFA here ", UNLOOP #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
set HDR-NFA here ", >R #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >R push ;
set HDR-NFA here ", R> #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R> pop ;
set HDR-NFA here ", R@ #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : R@ pop dup push ;
set HDR-NFA here ", I #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : I pop dup push ;
set HDR-NFA here ", J #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : J pop pop pop dup push a! push push a ;
set HDR-NFA here ", LEAVE #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LEAVE pop pop drop dup push push ;
set HDR-NFA here ", UNLOOP #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : UNLOOP pop drop pop drop ;
\ ---- memory ----
set HDR-NFA here ", @ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FETCH a! @ ;
set HDR-NFA here ", ! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STORE a! ! ;
set HDR-NFA here ", +! #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
set HDR-NFA here ", CELLS #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
set HDR-NFA here ", @ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FETCH a! @ ;
set HDR-NFA here ", ! #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STORE a! ! ;
set HDR-NFA here ", +! #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : +! a! @ + ! ;
set HDR-NFA here ", CELLS #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CELLS ; \ an address unit is a cell (D-1)
\ ---- arithmetic ----
set HDR-NFA here ", + #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
set HDR-NFA here ", - #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : MINUS - ;
set HDR-NFA here ", + #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PLUS + ;
set HDR-NFA here ", - #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : MINUS - ;
\ The low cell of the product, by N steps of +* with nothing but the count on
\ the return stack. UM* drop gives the same cell but needs two more return
\ entries, which a word inside two DO loops does not have (D-2). The low
\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach
\ the bit that moves into A, and the loop ends first.
set HDR-NFA here ", * #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", NEGATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
set HDR-NFA here ", 1+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1+ 1 + ;
set HDR-NFA here ", 1- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1- -1 + ;
set HDR-NFA here ", 2+ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2+ 2 + ;
set HDR-NFA here ", 2- #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2- -2 + ;
set HDR-NFA here ", 2* #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO* 2* ;
set HDR-NFA here ", 2/ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO/ 2/ ;
set HDR-NFA here ", * #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", NEGATE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NEGATE' NEGATE ;
set HDR-NFA here ", 1+ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1+ 1 + ;
set HDR-NFA here ", 1- #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 1- -1 + ;
set HDR-NFA here ", 2+ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2+ 2 + ;
set HDR-NFA here ", 2- #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2- -2 + ;
set HDR-NFA here ", 2* #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO* 2* ;
set HDR-NFA here ", 2/ #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO/ 2/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
@@ -163,11 +163,11 @@ set HDR-NFA here ", 2/ #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TWO
(F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
set HDR-NFA here ", S>D #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", S>D #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
set HDR-NFA here ", M* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M* ( n1 n2 -- d )
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop jump DNEGATE P: drop ;
@@ -181,49 +181,49 @@ set HDR-NFA here ", M* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
(F) a! @ -if P drop DNEGATE jump Q P: drop Q:
(F)+2 a! @ jump SM/REM
set HDR-NFA here ", /MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", /MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: drop drop 0 $444F4D2F jump (DIV0)
set HDR-NFA here ", / #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", / #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: drop drop 0 $2F jump (DIV0)
set HDR-NFA here ", MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: drop drop 0 $444F4D jump (DIV0)
set HDR-NFA here ", */MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", */MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: drop drop drop $44 $4F4D2F2A jump (DIV0)
set HDR-NFA here ", */ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", */ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: drop drop drop 0 $2F2A jump (DIV0)
set HDR-NFA here ", M/MOD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M/MOD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: drop drop drop $44 $4F4D2F4D jump (DIV0)
\ ---- logic and comparison ----
set HDR-NFA here ", AND #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
set HDR-NFA here ", XOR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : XOR xor ;
set HDR-NFA here ", OR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OR' OR ;
set HDR-NFA here ", 0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0= if L1 drop 0 ; L1: drop -1 ;
set HDR-NFA here ", 0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0< -if L1 drop -1 ; L1: drop 0 ;
set HDR-NFA here ", NOT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOT jump 0=
set HDR-NFA here ", = #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : EQUALS xor jump 0=
set HDR-NFA here ", < #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
set HDR-NFA here ", AND #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : AND and ;
set HDR-NFA here ", XOR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : XOR xor ;
set HDR-NFA here ", OR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : OR' OR ;
set HDR-NFA here ", 0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0= if L1 drop 0 ; L1: drop -1 ;
set HDR-NFA here ", 0< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 0< -if L1 drop -1 ; L1: drop 0 ;
set HDR-NFA here ", NOT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOT jump 0=
set HDR-NFA here ", = #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : EQUALS xor jump 0=
set HDR-NFA here ", < #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LESS
over over xor -if SAME drop drop jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", > #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : GREATER SWAP jump LESS
set HDR-NFA here ", > #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : GREATER SWAP jump LESS
\ ---- in-line addresses and constants ----
set HDR-NFA here ", BL #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL' BL ;
set HDR-NFA here ", TIB #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TIB' TIB ;
set HDR-NFA here ", >IN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >IN' >IN ;
set HDR-NFA here ", SPAN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SPAN' SPAN ;
set HDR-NFA here ", BASE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BASE' BASE ;
set HDR-NFA here ", PAD #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PAD' PAD ;
set HDR-NFA here ", STATE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
set HDR-NFA here ", BL #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BL' BL ;
set HDR-NFA here ", TIB #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TIB' TIB ;
set HDR-NFA here ", >IN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : >IN' >IN ;
set HDR-NFA here ", SPAN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : SPAN' SPAN ;
set HDR-NFA here ", BASE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : BASE' BASE ;
set HDR-NFA here ", PAD #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : PAD' PAD ;
set HDR-NFA here ", STATE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : STATE' STATE ;
capsules/v4/sys/input.f18
+9 -9
View File
@@ -27,7 +27,7 @@
macro BL 32 endmacro
\ ( -- baddr u ) the input buffer and how much of it is in use
set HDR-NFA here ", SOURCE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SOURCE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SOURCE (SRC) a! @ SPAN a! @ -if P drop 0 P: ;
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
@@ -40,7 +40,7 @@ set HDR-NFA here ", SOURCE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ on the stack beneath it, so it works in (P) -- (P)+0 where the next
\ character goes, (P)+1 how many more may come, (P)+2 where the first went --
\ and has at most three cells of its own on the data stack (D-2).
set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", EXPECT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: EXPECT
-if NN drop drop ; \ n < 0
NN: if ZERO
@@ -57,7 +57,7 @@ set HDR-NFA here ", EXPECT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ZERO: drop drop ;
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
set HDR-NFA here ", QUERY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", QUERY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUERY TIB (SRC) a! ! TIB 80 EXPECT 0 >IN a! ! ;
\ ---- WORD ------------------------------------------------------------------
@@ -122,7 +122,7 @@ macro (STEP) (P)+6 a! @ 1 + ! endmacro
RANOUT: drop 0 (P)+2 a! @ WBUF+1 + C!
(P)+6 a! @ >IN a! ! WBUF ;
set HDR-NFA here ", WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WORD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WORD
(WORD-SET)
SK: (LEFT) -if SKE drop (CH) if SKS drop jump (WORD-TAKE) \ past delimiters
@@ -146,7 +146,7 @@ set HDR-NFA here ", WORD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr c -- baddr n1 n2 n3 ) in the zero-terminated string at baddr:
\ n1 the offset of the first character that is not c, n2 the offset of the
\ first c after it, n3 the offset of the first character after that run of c.
set HDR-NFA here ", ENCLOSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ENCLOSE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ENCLOSE
255 and (P) a! ! dup (P)+1 a! !
0 (ESKIP) dup (ESCAN) dup (ESKIP) ;
@@ -167,7 +167,7 @@ set HDR-NFA here ", ENCLOSE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ it is multiplied by BASE, until one is not a digit; baddr2 is its address.
\ (P)+2 holds the digit while the double is multiplied and (P)+5 the address,
\ so nothing waits on the return stack across the calls.
set HDR-NFA here ", CONVERT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CONVERT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CONVERT
L: 1 + dup (P)+5 a! ! C@ (DIGIT) \ lo hi n
-if DIG drop (P)+5 a! @ ;
@@ -201,16 +201,16 @@ set HDR-NFA here ", CONVERT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ERR0: 0 0 0 ;
\ ( baddr -- d ) FORTH-79. What is not a number gives 0 and sets NODE-ERROR.
set HDR-NFA here ", NUMBER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NUMBER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NUMBER
(NUMBER?) if BAD drop ;
BAD: drop NODE-ERROR b! 2 !b ;
\ ---- comments (5.15) -------------------------------------------------------
\ PAREN skips to the closing parenthesis; BACKSLASH skips the rest of the line.
set HDR-NFA here ", ( #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ( #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PAREN 41 WORD drop ;
set HDR-NFA here ", \ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", \ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BACKSLASH
BLK a! @ if TERM drop >IN a! @ -64 and 64 + ! ;
capsules/v4/sys/log.f18
+18 -18
View File
@@ -16,16 +16,16 @@
\ Constants the loader supplies:
\ (LOG-LEVEL) word address of the variable: 2, LOG-INFO, at switch-on
set HDR-NFA here ", LOG-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR 0 ;
set HDR-NFA here ", LOG-WARN #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN 1 ;
set HDR-NFA here ", LOG-INFO #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO 2 ;
set HDR-NFA here ", LOG-TEST #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST 3 ;
set HDR-NFA here ", LOG-DEBUG #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG 4 ;
set HDR-NFA here ", LOG-ERROR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR 0 ;
set HDR-NFA here ", LOG-WARN #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN 1 ;
set HDR-NFA here ", LOG-INFO #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO 2 ;
set HDR-NFA here ", LOG-TEST #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST 3 ;
set HDR-NFA here ", LOG-DEBUG #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG 4 ;
set HDR-NFA here ", LOG-LEVEL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOG-LEVEL@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOG-LEVEL@ ( -- n ) (LOG-LEVEL) a! @ ;
\ ( n -- ) as v3: a level below 0 is 0, one above 4 is 4
set HDR-NFA here ", LOG-LEVEL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LOG-LEVEL! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LOG-LEVEL!
-if POS drop 0 jump SET
POS: dup -5 + -if BIG drop jump SET
@@ -45,15 +45,15 @@ set HDR-NFA here ", LOG-LEVEL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
P4: drop $34335B1B (EMIT4) $6D (EMIT4) $55424544 (EMIT4) $203A47 (EMIT4) $6D305B1B (EMIT4) jump OUT
OUT: TYPE jump CR
set HDR-NFA here ", LOG-ERROR-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
set HDR-NFA here ", LOG-WARN-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
set HDR-NFA here ", LOG-INFO-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
set HDR-NFA here ", LOG-TEST-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
set HDR-NFA here ", LOG-DEBUG-STR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
set HDR-NFA here ", LOG-ERROR-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-STR ( baddr u -- ) 0 jump (LOG)
set HDR-NFA here ", LOG-WARN-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-STR ( baddr u -- ) 1 jump (LOG)
set HDR-NFA here ", LOG-INFO-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-STR ( baddr u -- ) 2 jump (LOG)
set HDR-NFA here ", LOG-TEST-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-STR ( baddr u -- ) 3 jump (LOG)
set HDR-NFA here ", LOG-DEBUG-STR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-STR ( baddr u -- ) 4 jump (LOG)
\ ( level -- ) the run time of LOG-xxx" : the text is after the call, as
\ for ." ; log it at that level and go on after it.
set HDR-NFA here ", (LOG") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (LOG") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (LOG")
pop 4* dup C@ over + 4/ 1 + push \ level baddr R: the cell after the text
COUNT ROT jump (LOG)
@@ -65,8 +65,8 @@ set HDR-NFA here ", (LOG") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
STATE a! @ if NOW
drop (Q)+3 a! @ (LIT,) &(LOG") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT (Q)+3 a! @ jump (LOG)
set HDR-NFA here ", LOG-ERROR" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-WARN" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-INFO" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-TEST" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-DEBUG" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-ERROR" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-ERROR-QUOTE 0 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-WARN" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-WARN-QUOTE 1 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-INFO" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-INFO-QUOTE 2 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-TEST" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-TEST-QUOTE 3 jump (LOG-QUOTE)
set HDR-NFA here ", LOG-DEBUG" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here : LOG-DEBUG-QUOTE 4 jump (LOG-QUOTE)
capsules/v4/sys/map-32.f18
+2
View File
@@ -28,6 +28,8 @@ constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (NEXT-ID) 15746
constant (BOOT-ID) 15747
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
capsules/v4/sys/map-64.f18
+2
View File
@@ -28,6 +28,8 @@ constant (S) 15812
constant (W) 16285
constant (X) 15792
constant (BOOT) 15750
constant (NEXT-ID) 15746
constant (BOOT-ID) 15747
constant (LOG-LEVEL) 14707
constant (ACL-HOOK) 14706
constant SCR 15742
capsules/v4/sys/numout.f18
+19 -19
View File
@@ -21,34 +21,34 @@ macro (-ROT) SWAP push SWAP pop endmacro
: UM/MOD ROM-UM/MOD push ; \ ( ulo uhi ud -- urem uquot )
\ ---- pictured output ----
set HDR-NFA here ", <# #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <# #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <# ( -- ) HEND HLD b! !b ;
set HDR-NFA here ", HOLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HOLD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HOLD ( c -- )
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
OKC: drop HLD b! @b -HFLOOR + -if ROOM
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
ROOM: drop HLD b! @b -1 + dup !b jump C!
set HDR-NFA here ", SIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SIGN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
set HDR-NFA here ", # #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", # #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: # ( ud1 -- ud2 )
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
(BASE) UM/MOD (-ROT) \ qlo qhi rem
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
set HDR-NFA here ", #S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", #S #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
set HDR-NFA here ", #> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", #> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
set HDR-NFA here ", SPACES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SPACES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
set HDR-NFA here ", DECIMAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DECIMAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DECIMAL 10 BASE a! ! ;
set HDR-NFA here ", HEX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HEX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HEX 16 BASE a! ! ;
set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", OCTAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: OCTAL 8 BASE a! ! ;
\ ---- numbers ----
@@ -69,28 +69,28 @@ set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (D.BODY) ( d width -- )
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
set HDR-NFA here ", .R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", .R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
set HDR-NFA here ", . #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", . #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
set HDR-NFA here ", U.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U.R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
set HDR-NFA here ", U. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U. #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
set HDR-NFA here ", D.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D.R #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
set HDR-NFA here ", D. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D. #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
set HDR-NFA here ", ? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ? #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUESTION a! @ jump DOT
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line. The stack is
\ left as it was. It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", .S #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-S
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
DEPTH (W)+2 b! !b
@@ -105,7 +105,7 @@ set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ Everything it keeps between words is in (DP): the saved BASE, the address,
\ the count and the column. ADDR-DIGITS is two for each byte of a cell.
: (DB) ( -- c ) (DP)+1 b! @b (DP)+3 b! @b + jump C@
set HDR-NFA here ", DUMP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DUMP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DUMP
-if OK drop drop NODE-ERROR b! 1 !b ;
OK: (DP)+2 b! !b (DP)+1 b! !b
capsules/v4/sys/qmath.f18
+23 -23
View File
@@ -24,38 +24,38 @@ macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
: (QERR12) NODE-ERROR b! 12 !b ;
\ ---- conversion and constants ----
set HDR-NFA here ", Q.FROM-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.FROM-INT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
set HDR-NFA here ", Q.TO-INT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.TO-INT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
set HDR-NFA here ", Q.1 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.1 65536 0 ;
set HDR-NFA here ", Q.0 #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0 0 0 ;
set HDR-NFA here ", Q.SCALE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
set HDR-NFA here ", Q.1 #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.1 65536 0 ;
set HDR-NFA here ", Q.0 #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0 0 0 ;
set HDR-NFA here ", Q.SCALE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.SCALE 65536 0 ;
\ ---- the double words under other names ----
set HDR-NFA here ", Q.+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.+ jump D+
set HDR-NFA here ", Q.- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.- jump D-
set HDR-NFA here ", Q.ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.ABS jump DABS
set HDR-NFA here ", Q.NEG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.NEG jump DNEGATE
set HDR-NFA here ", Q.= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.= jump D=
set HDR-NFA here ", Q.< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.< jump D<
set HDR-NFA here ", Q.> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.> 2SWAP jump D<
set HDR-NFA here ", Q.0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0= jump D0=
set HDR-NFA here ", Q.MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MAX jump DMAX
set HDR-NFA here ", Q.MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
set HDR-NFA here ", Q.+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.+ jump D+
set HDR-NFA here ", Q.- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.- jump D-
set HDR-NFA here ", Q.ABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.ABS jump DABS
set HDR-NFA here ", Q.NEG #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.NEG jump DNEGATE
set HDR-NFA here ", Q.= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.= jump D=
set HDR-NFA here ", Q.< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.< jump D<
set HDR-NFA here ", Q.> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.> 2SWAP jump D<
set HDR-NFA here ", Q.0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.0= jump D0=
set HDR-NFA here ", Q.MAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MAX jump DMAX
set HDR-NFA here ", Q.MIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here : Q.MIN jump DMIN
\ ---- multiply ----
set HDR-NFA here ", Q.* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.* ROM-Q.* push ; \ ( a b -- c ) the ROM's entry 4 (MACHINE.md 2.2)
\ ---- divide ----
\ D2*C and (UQ/), Q./'s core, are the ROM's (capsules/v4/rom/math.f18).
set HDR-NFA here ", Q./ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q./ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q./ ROM-Q./ push ; \ ( a b -- q ) the ROM's entry 5
\ ---- e to the x ----
set HDR-NFA here ", Q.EXP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.EXP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.EXP ( q -- e )
over over OR if ONE drop
dup (QE)+6 b! !b -if L1 DNEGATE L1:
@@ -80,7 +80,7 @@ set HDR-NFA here ", Q.EXP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ONE: drop drop drop 65536 0 ;
\ ---- square root ----
set HDR-NFA here ", Q.SQRT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.SQRT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.SQRT ( q -- r )
dup -if POS drop drop drop 0 0 jump (QERR12)
POS: drop over over OR if ZERO drop
@@ -100,7 +100,7 @@ set HDR-NFA here ", Q.SQRT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
ONE: drop ;
\ ---- natural logarithm ----
set HDR-NFA here ", Q.LOG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.LOG #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.LOG ( x -- ln x )
dup -if POS drop jump ERR
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
@@ -159,13 +159,13 @@ set HDR-NFA here ", Q.LOG #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
END: (QT)+3 b! @b (QT) b! @b -if PR drop inv 1 + jump SD PR: drop
SD: dup -if SP drop -1 ; SP: drop 0 ;
set HDR-NFA here ", Q.SIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.SIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.SIN ( x -- sin x )
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
dup (QT)+2 b! !b dup (QT)+3 b! !b
0 over 0 Q.* drop (QT)+1 b! !b
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
set HDR-NFA here ", Q.COS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.COS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.COS ( x -- cos x )
(Q.REDUCE) -if A1 inv 1 + A1:
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
@@ -174,7 +174,7 @@ set HDR-NFA here ", Q.COS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ---- printing ----
\ The integer part, a point, five digits, a blank; always in decimal.
set HDR-NFA here ", Q.PRINT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", Q.PRINT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: Q.PRINT ( q -- )
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
BASE b! @b (QP) b! !b 10 BASE b! !b
capsules/v4/sys/quit.f18
+28 -27
View File
@@ -200,7 +200,7 @@ macro R-CLEAR RSTACK-DEPTH b! a !b endmacro
\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel.
\ ( node port -- ) the port, by its number, leads toward that node
set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ROUTE
(ROUTE#) a! @ -16 + if FULL drop
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
@@ -212,20 +212,20 @@ set HDR-NFA here ", ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ 0: none, or a device. Whoever wires the node tells it, and tells it again
\ when the wiring changes. It is how a node knows who its centre is, the
\ one node whose GONE it believes: (CENTRE).
set HDR-NFA here ", NEIGHBOUR #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NEIGHBOUR #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NEIGHBOUR
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( port -- ) the port, by its number, leads toward every node not told of
set HDR-NFA here ", DEFAULT-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFAULT-ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
\ ( node -- ) forget the way to that node, if one is known: what is for it
\ then goes by the way for every node not told of, if there is one. The
\ last way in the table takes its place.
set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NO-ROUTE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NO-ROUTE
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
@@ -253,11 +253,11 @@ set HDR-NFA here ", NO-ROUTE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( n node -- ) tell the node that node n is gone. It acts on that only
\ if this node is its centre: it forgets the way to n, and if it is waiting
\ for n's answer the wait ends.
set HDR-NFA here ", GONE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", GONE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", NO-ROUTES #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
\ ( baddr u node port -- ) send the node u characters of text to
@@ -299,7 +299,7 @@ set HDR-NFA here ", NO-ROUTES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr u node -- ) send the node u characters of text to interpret,
\ by the way this node knows to it. What it prints there goes to that
\ node's console. With no way to the node it is error 12.
set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEND #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEND
dup (WAY) -if GO drop drop drop drop NODE-ERROR b! 12 !b ;
GO: jump (SEND-ON)
@@ -307,7 +307,7 @@ set HDR-NFA here ", SEND #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( baddr u node port -- ) the same by a port this node names, by its
\ number, whatever ways it knows: for a neighbour that has no number of
\ its own yet, to which text is sent as to node 0.
set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEND-ON #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEND-ON
dup -if POS jump BAD
POS: -PORTS + -if BAD drop jump (SEND-ON)
@@ -359,7 +359,7 @@ set HDR-NFA here ", SEND-ON #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ does not keep it awake.
\ The stack what it does needs is tried first, (ROOM), core.f18: text that
\ has left too little ends "Stack overflow" with nothing taken off a wire.
set HDR-NFA here ", AWAIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", AWAIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: AWAIT
(ONE) a! ! (ROOM) \ if this faults, no one is waited for:
(ONE) a! @ (AWAIT-FROM) a! ! 0 (A-SELF) a! ! \ (AWAIT-FROM) is set only when the stack has been tried
@@ -392,7 +392,7 @@ set HDR-NFA here ", AWAIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ the neighbour has taken it. This is how a node is sent a capsule of F18
\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a
\ message, to a node that is executing from its ports.
set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PORT! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PORT!
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
@@ -401,11 +401,12 @@ set HDR-NFA here ", PORT! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) WHAT IS IN THE DICTIONARY NOW IS THE SYSTEM: COLD comes back to
\ it and FORGET will not go below it. Whoever has loaded a node's capsules
\ has it do this (system.f18, (BOOT) and FENCE).
set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (SEAL) #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (SEAL)
DP a! @ (BOOT) a! !
(LATEST) a! @ (BOOT)+1 a! !
DP a! @ 3 + 2/ 2/ FENCE a! ! ;
DP a! @ 3 + 2/ 2/ FENCE a! !
(NEXT-ID) a! @ (BOOT-ID) a! ! ;
\ FORTH-79: clear the return stack, set execution mode, return control to
\ the terminal; no message is given. The data stack is left as it is.
@@ -413,22 +414,22 @@ set HDR-NFA here ", (SEAL) #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ A store of a code that is not zero is the trap of D-18 -- the word goes no
\ further, the message for the code is printed (-1: the word has printed
\ its own) and the line ends with ERROR. The codes are listed in core.f18.
set HDR-NFA here ", NODE-ERROR #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NODE-ERROR' NODE-ERROR ;
set HDR-NFA here ", (ME) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (ME)' (ME) ;
set HDR-NFA here ", (CONSOLE) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (CONSOLE)' (CONSOLE) ;
set HDR-NFA here ", (LOST) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ;
set HDR-NFA here ", (REFUSED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ;
set HDR-NFA here ", (WORD-DEFINED) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ;
set HDR-NFA here ", (WORD-FORGOTTEN) #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
set HDR-NFA here ", NODE-ERROR #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NODE-ERROR' NODE-ERROR ;
set HDR-NFA here ", (ME) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (ME)' (ME) ;
set HDR-NFA here ", (CONSOLE) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (CONSOLE)' (CONSOLE) ;
set HDR-NFA here ", (LOST) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (LOST)' (LOST) ;
set HDR-NFA here ", (REFUSED) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (REFUSED)' (REFUSED) ;
set HDR-NFA here ", (WORD-DEFINED) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-DEFINED)' (WORD-DEFINED) ;
set HDR-NFA here ", (WORD-FORGOTTEN) #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
set HDR-NFA here ", QUIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", QUIT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
\ FORTH-79: clear the data and return stacks, set execution mode, return
\ control to the terminal. As v3, the line it stops ends with " ok".
\ Both are emptied before anything is called: ABORT may be run with the
\ return stack full.
set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABORT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
\ ---- faults (D-14, D-16) -------------------------------------------------------
@@ -531,7 +532,7 @@ set HDR-NFA here ", ABORT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ It takes the return address off before it calls anything and keeps the
\ count there instead, so a word that prints text goes no deeper than one
\ that calls any other word.
set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (.") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (.")
pop 4* dup C@ \ baddr n
L: if DONE
@@ -540,7 +541,7 @@ set HDR-NFA here ", (.") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
\ it is compiled into runs, if compiling.
set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ." #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DOT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
@@ -550,7 +551,7 @@ set HDR-NFA here ", ." #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the
\ string after the call, start a new line and ABORT; otherwise go on after
\ the string.
set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (ABORT") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (ABORT")
if NO
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
@@ -558,7 +559,7 @@ set HDR-NFA here ", (ABORT") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if
\ the flag is not zero, print the text and ABORT.
set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABORT" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABORT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
@@ -569,7 +570,7 @@ set HDR-NFA here ", ABORT" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", (S") #id, #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
@@ -578,7 +579,7 @@ set HDR-NFA here ", (S") #, 16 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
set HDR-NFA here ", S" #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", S" #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
capsules/v4/sys/system.f18
+23 -21
View File
@@ -11,37 +11,37 @@
\ HEAT-OP ANTICLOCK word addresses of HEAT-OP[0] and ANTICLOCK, the heat
\ registers (DECOMPOSITION.md section 7): read-only
set HDR-NFA here ", FENCE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FENCE' FENCE ;
set HDR-NFA here ", FENCE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FENCE' FENCE ;
\ ---- the heat registers (DECOMPOSITION.md section 7; #189) -----------------------
\ Captain Bob, 2026-11-12: "Add HEAT-OP". The node counts every instruction it
\ retires, by opcode, and the anti-clock ticks once for each; these read them.
\ ( op -- n ) how many times opcode op has retired; op is taken mod 32
set HDR-NFA here ", HEAT-OP@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", HEAT-OP@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: HEAT-OP@ 31 and HEAT-OP + b! @b ;
\ ( -- n ) the anti-clock: one tick per instruction retired
set HDR-NFA here ", ANTICLOCK@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ANTICLOCK@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ANTICLOCK@ ANTICLOCK b! @b ;
\ ---- vocabularies (FORTH-79) ----------------------------------------------------
\ A vocabulary is two cells: its head -- the xt of its newest entry, or 0 --
\ and the address of the vocabulary defined before it, or 0. VOC-LINK holds
\ the newest one's address. FORTH's head is (LATEST) and it is in no chain.
set HDR-NFA here ", CONTEXT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CONTEXT' CONTEXT ;
set HDR-NFA here ", CURRENT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
set HDR-NFA here ", CONTEXT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CONTEXT' CONTEXT ;
set HDR-NFA here ", CURRENT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : CURRENT' CURRENT ;
\ FORTH-79: the primary vocabulary; it becomes the CONTEXT vocabulary.
set HDR-NFA here ", FORTH #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FORTH #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FORTH (LATEST) CONTEXT a! ! ;
\ FORTH-79: new definitions go into the CONTEXT vocabulary from now on.
set HDR-NFA here ", DEFINITIONS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFINITIONS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFINITIONS CONTEXT a! @ CURRENT a! ! ;
\ VOCABULARY xxx FORTH-79: xxx is a new, empty list of words; executing
\ xxx makes it the CONTEXT vocabulary. When a search of it finds nothing,
\ FORTH is searched.
: (DOVOC) pop CONTEXT a! ! ;
set HDR-NFA here ", VOCABULARY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VOCABULARY #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VOCABULARY
&(DOVOC) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop
0 , VOC-LINK a! @ , HERE -2 + VOC-LINK a! ! ;
@@ -53,7 +53,7 @@ set HDR-NFA here ", VOCABULARY #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK her
F: drop drop $54524F46 (EMIT4) $48 (EMIT4) ;
\ ( -- ) as v3's, but true: where names are looked for, and where new ones go
set HDR-NFA here ", ORDER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ORDER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ORDER
$72616553 (EMIT4) $6F206863 (EMIT4) $72656472 (EMIT4) $203A (EMIT4)
CONTEXT a! @ dup (.VOC) SPACE
@@ -66,7 +66,7 @@ set HDR-NFA here ", ORDER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) the names in the CONTEXT vocabulary, the newest first, a blank after
\ each, a new line whenever one has passed column 64. Hidden entries -- a
\ definition under way -- are not shown. (Q)+0 is the column.
set HDR-NFA here ", WORDS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WORDS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WORDS
0 (Q) a! !
CONTEXT a! @ a! @
@@ -80,7 +80,7 @@ set HDR-NFA here ", WORDS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
WRAP: drop CR 0 (Q) a! !
NXT: -1 + a! @ jump L
DONE: drop jump CR
set HDR-NFA here ", VLIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VLIST #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VLIST jump WORDS
\ ( cell -- ) take off a vocabulary's list every entry at or above the
@@ -97,7 +97,7 @@ set HDR-NFA here ", VLIST #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ goes is no longer CONTEXT or CURRENT: FORTH is. A word that is not there
\ is an error, and so is one below FENCE, which is where the capsule's own
\ words are (code 10, "Protected word").
set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FORGET #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FORGET
32 WORD (LOOKUP) if MISSING
-2 + a! @ \ where its name starts
@@ -116,7 +116,8 @@ set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
C1: drop (LATEST) CONTEXT a! !
C2: CURRENT a! @ (Q) a! @ inv + 1 + -if C3 drop jump TOLD
C3: drop (LATEST) CURRENT a! !
TOLD: (Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.f18)
TOLD: (Q) a! @ 4* NAME> -4 + a! @ (NEXT-ID) a! ! \ their IDs are free again: the newest are
(Q) a! @ jump (FORGOTTEN) \ the kernel's records of them go too (dict.f18)
MISSING: drop (UNKNOWN) drop ;
\ ---- the system as a whole -------------------------------------------------------
@@ -125,21 +126,21 @@ set HDR-NFA here ", FORGET #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ FORTH-79: execute to be sure a FORTH-79 system is there. It is: nothing
\ happens. (v3's prints two lines and leaves a flag.)
set HDR-NFA here ", 79-STANDARD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 79-STANDARD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 79-STANDARD ;
\ ( -- ) which system this is, and its cell width
set HDR-NFA here ", VERSION #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", VERSION #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: VERSION
$72617453 (EMIT4) $74726F46 (EMIT4) $34762068 (EMIT4) $302E302E (EMIT4) $38314620 (EMIT4) $20 (EMIT4)
N-1 1 + 0 U-DOT-R $7469622D (EMIT4) CR ;
\ ( -- ) clear the screen and put the cursor at the top, as v3: ESC [2J ESC [H
set HDR-NFA here ", PAGE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", PAGE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: PAGE 27 EMIT 91 EMIT 50 EMIT 74 EMIT 27 EMIT 91 EMIT 72 jump EMIT
\ ( -- ) as v3's message, and then ABORT: both stacks emptied, the prompt
set HDR-NFA here ", WARM #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WARM #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WARM
$54524F46 (EMIT4) $39372D48 (EMIT4) $72615720 (EMIT4) $7453206D (EMIT4) $747261 (EMIT4) CR
$74737953 (EMIT4) $72206D65 (EMIT4) $61747365 (EMIT4) $64657472 (EMIT4) $2E (EMIT4) CR
@@ -148,11 +149,12 @@ set HDR-NFA here ", WARM #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
\ ( -- ) the system as it was when the capsule had just been loaded:
\ everything defined since is gone, there is one vocabulary, numbers are
\ decimal, the block buffers are empty. Then as WARM.
set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COLD #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COLD
(BOOT) a! @ DP a! !
(BOOT)+1 a! @ (LATEST) a! !
(BOOT) a! @ 2/ 2/ FENCE a! !
(BOOT-ID) a! @ (NEXT-ID) a! !
(LATEST) CONTEXT a! ! (LATEST) CURRENT a! ! 0 VOC-LINK a! !
10 BASE a! ! 0 SCR a! ! 2 (LOG-LEVEL) a! ! 0 (ACL-HOOK) a! ! EMPTY-BUFFERS
(BOOT) a! @ 2/ 2/ (FORGOTTEN) \ the kernel's records of what has gone go too (dict.f18)
@@ -167,15 +169,15 @@ set HDR-NFA here ", COLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: (DODEFER)
pop a! @ if UNSET push ; \ go to it: it returns to xxx's caller
UNSET: drop NODE-ERROR b! 15 !b ;
set HDR-NFA here ", DEFER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER &(DODEFER) (C)+3 a! ! (DATA) (C)+8 a! @ if NONE drop 0 jump , NONE: drop ;
: (is!) a! ! ;
: (defer@) a! @ ;
set HDR-NFA here ", IS #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", IS #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: IS
(') STATE a! @ if NOW drop (LIT,) &(is!) jump (CALL,)
NOW: drop jump (is!)
set HDR-NFA here ", DEFER@ #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DEFER@ #id, #, 1 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DEFER@
(') STATE a! @ if NOW drop (LIT,) &(defer@) jump (CALL,)
NOW: drop jump (defer@)
capsules/v4/sys/words.f18
+49 -49
View File
@@ -11,57 +11,57 @@
\ (X) word address of four cells of scratch for COMPARE and SEARCH
\ ---- stack ----
set HDR-NFA here ", 2SWAP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2SWAP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
set HDR-NFA here ", 2OVER #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2OVER #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
set HDR-NFA here ", 2ROT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2ROT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
set HDR-NFA here ", 2>R #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2>R SWAP push push ;
set HDR-NFA here ", 2R> #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R> pop pop SWAP ;
set HDR-NFA here ", 2R@ #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R@ pop pop over over push push SWAP ;
set HDR-NFA here ", NOP #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOP' nop ;
set HDR-NFA here ", TRUE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TRUE -1 ;
set HDR-NFA here ", FALSE #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FALSE 0 ;
set HDR-NFA here ", INVERT #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
set HDR-NFA here ", 2>R #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2>R SWAP push push ;
set HDR-NFA here ", 2R> #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R> pop pop SWAP ;
set HDR-NFA here ", 2R@ #id, #, 24 #, HDR-NFA #, HDR-LINK set HDR-LINK here : 2R@ pop pop over over push push SWAP ;
set HDR-NFA here ", NOP #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : NOP' nop ;
set HDR-NFA here ", TRUE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : TRUE -1 ;
set HDR-NFA here ", FALSE #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : FALSE 0 ;
set HDR-NFA here ", INVERT #id, #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : INVERT inv ;
\ ---- memory ----
set HDR-NFA here ", 2@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2@ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2@ ( addr -- lo hi ) a! @+ @ ;
set HDR-NFA here ", 2! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 2! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
set HDR-NFA here ", -! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", -! #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -! ( n addr -- ) a! NEGATE @ + ! ;
\ ---- comparison ----
set HDR-NFA here ", 0<> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 0<> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0<> if Z drop -1 ; Z: ;
set HDR-NFA here ", 0> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", 0> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
set HDR-NFA here ", <> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <> xor jump 0<>
set HDR-NFA here ", <= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", <= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: <= GREATER jump 0=
set HDR-NFA here ", >= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", >= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: >= LESS jump 0=
set HDR-NFA here ", U< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U< over over xor -if SAME drop NIP jump 0<
SAME: drop - jump 0<
set HDR-NFA here ", U> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", U> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: U> SWAP jump U<
set HDR-NFA here ", ABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ABS -if P inv 1 + P: ;
set HDR-NFA here ", MAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
set HDR-NFA here ", MIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
set HDR-NFA here ", WITHIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", WITHIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: WITHIN ( n low high -- flag ) push over pop LESS push LESS inv pop and ;
\ ---- shifts ----
\ As v3, a count that is negative or as large as the cell is wide is an
\ error (code 9, "Shift count out of range").
set HDR-NFA here ", LSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", LSHIFT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: LSHIFT ( x n -- x' )
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
@@ -69,7 +69,7 @@ set HDR-NFA here ", LSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop ;
BAD2: drop
BAD: drop drop NODE-ERROR b! 9 !b ;
set HDR-NFA here ", RSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", RSHIFT #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: RSHIFT ( x n -- x' ) \ zeros come in at the top
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
@@ -79,23 +79,23 @@ set HDR-NFA here ", RSHIFT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
BAD: drop drop NODE-ERROR b! 9 !b ;
\ ---- doubles and mixed ----
set HDR-NFA here ", D- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D- DNEGATE jump D+
set HDR-NFA here ", DABS #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DABS #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DABS -if P jump DNEGATE P: ;
set HDR-NFA here ", D0= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D0= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0= OR jump 0=
set HDR-NFA here ", D0< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D0< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D0< push drop pop jump 0<
set HDR-NFA here ", D= #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D= #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D= D- jump D0=
set HDR-NFA here ", D2* #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D2* #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
set HDR-NFA here ", D2/ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D2/ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D2/ push a! 0 pop +* push drop a pop ;
set HDR-NFA here ", M+ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M+ #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M+ S>D jump D+
set HDR-NFA here ", M- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", M- #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: M- S>D DNEGATE jump D+
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
@@ -110,18 +110,18 @@ set HDR-NFA here ", M- #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
LS: drop push inv pop + inv
S2: -if N2 drop -1 jump D2 N2: drop 0
D2: pop pop ROT ;
set HDR-NFA here ", D< #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", D< #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: D< (D<) push drop drop drop drop pop ;
set HDR-NFA here ", DMAX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DMAX #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
set HDR-NFA here ", DMIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", DMIN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
\ ---- strings and memory ----
set HDR-NFA here ", ?TERMINAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ?TERMINAL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
set HDR-NFA here ", CMOVE> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", CMOVE> #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: CMOVE> ( src dst u -- )
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE -1 + push
@@ -131,31 +131,31 @@ set HDR-NFA here ", CMOVE> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
DONE: drop drop drop ;
\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
set HDR-NFA here ", MOVE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", MOVE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: MOVE ( addr1 addr2 n -- )
-if OK drop drop drop ;
OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
DONE: drop drop drop ;
set HDR-NFA here ", FILL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", FILL #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: FILL ( baddr u c -- )
SWAP push SWAP pop \ c baddr u
-if OK drop drop drop NODE-ERROR b! 1 !b ;
OK: if DONE push over over C! 1 + pop -1 + jump OK
DONE: drop drop drop ;
set HDR-NFA here ", ERASE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", ERASE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: ERASE ( baddr u -- ) 0 jump FILL
set HDR-NFA here ", BLANK #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", BLANK #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: BLANK ( baddr u -- ) 32 jump FILL
set HDR-NFA here ", -TRAILING #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", -TRAILING #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: -TRAILING ( baddr u -- baddr u' )
-if L drop 0 ;
L: if DONE over over + -1 + C@ -32 + if SP drop ;
SP: drop -1 + jump L
DONE: ;
set HDR-NFA here ", COMPARE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", COMPARE #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: COMPARE ( a1 u1 a2 u2 -- n )
-if A drop 0 A: (X)+1 b! !b
SWAP -if B drop 0 B: dup (X) b! !b
@@ -173,7 +173,7 @@ set HDR-NFA here ", COMPARE #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
NN: if ZZ drop 1 ;
ZZ: ;
set HDR-NFA here ", SEARCH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SEARCH #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
-if A drop 0 A: (X)+1 b! !b (X) b! !b
-if B drop 0 B: dup (X)+3 b! !b over (X)+2 b! !b
@@ -186,14 +186,14 @@ set HDR-NFA here ", SEARCH #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
SAME: drop 1 + push 1 + pop pop -1 + jump I
MATCH: drop drop drop -1 ;
set HDR-NFA here ", SCAN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SCAN #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SCAN ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if FOUND
drop push 1 + pop -1 + jump L
FOUND: drop
DONE: pop drop ;
set HDR-NFA here ", SKIP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
set HDR-NFA here ", SKIP #id, #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
: SKIP ( baddr u c -- baddr' u' )
255 and push -if L drop 0
L: if DONE over C@ pop dup push xor if SAME drop jump DONE