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

refactor(v4.0.0): the capsule's inner words keep their state in memory

Browse Source 
WORD, the dictionary words and the code generator run underneath
whatever the user has on the stacks, which are ten and nine deep (D-2).
Measured, they used five to seven data cells of their own, leaving a
line about three.  Each now keeps what it works on in its file's
scratch cells and has at most three cells on the data stack; , calls
nothing; and the longest chains of calls are shorter.

The public words of core.v4, input.v4 and dict.v4 get dictionary
headers.  NUMBER is split so the interpreter can have a flag instead of
NODE-ERROR.  The host-node tests share one memory map, host_map.h.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 10:41:50 -04:00
co-authored by Claude Opus 5.5
parent 44ffd261bb
commit bbd1b4047f
10 changed files with 360 additions and 248 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/dict.v4
+87 -34
View File
@@ -29,7 +29,7 @@
\ (LATEST) word address of the variable: the xt of the newest entry, or 0
\ DBASE DLIMIT byte addresses of the start and end of dictionary space
\ PAD byte address of the scratch area for strings, 84 bytes or more
\ (D) word address of two cells of scratch for this file
\ (D) word address of five cells of scratch for this file
\ PAD is in line.
macro 4* 2* 2* endmacro
@@ -37,103 +37,156 @@ macro 4/ 2/ 2/ endmacro
macro OR over inv and xor endmacro
\ ---- the space (5.12) ------------------------------------------------------
\ These reach DP through B and leave A alone, so that , and C, can keep what
\ they are storing in A while the space is taken: nothing of theirs is then
\ on the data stack under (DP+), which itself needs three cells (D-2).
: (DERR) ( -- 0 ) NODE-ERROR b! -1 !b 0 ;
\ ( n -- flag ) move DP by n bytes if it stays inside the dictionary space
\ and say -1; otherwise leave it, set NODE-ERROR and say 0.
\ and say -1; otherwise leave it, set NODE-ERROR and say 0. The two
\ subtractions are x + ~y + 1, which unlike the in-line - needs no return
\ entry: these words are called at the bottom of long chains of calls.
: (DP+)
DP a! @ +
dup DBASE - -if LOW drop drop jump (DERR)
LOW: drop DLIMIT over - -if HIGH drop drop jump (DERR)
HIGH: drop DP a! ! -1 ;
DP b! @b +
dup DBASE inv + 1 + -if LOW drop drop jump (DERR) \ new - DBASE
LOW: drop dup inv DLIMIT + 1 + -if HIGH drop drop jump (DERR) \ DLIMIT - new
HIGH: drop DP b! !b -1 ;
: HERE ( -- addr ) DP a! @ 3 + 4/ ;
: ALIGN ( -- ) DP a! @ 3 + -4 and DP a! ! ;
header HERE
: HERE ( -- addr ) DP b! @b 3 + 4/ ;
header ALIGN
: ALIGN ( -- ) DP b! @b 3 + -4 and !b ;
header ALLOT
: ALLOT ( n -- ) ALIGN 4* (DP+) drop ;
\ , calls nothing: the code generator calls it from as deep as anything goes.
header ,
: , ( x -- )
ALIGN HERE push 4 (DP+) if FULL drop pop a! ! ;
FULL: drop pop drop drop ;
a!
DP b! @b 3 + -4 and \ the next whole cell, as a byte address
dup inv DLIMIT + -3 + -if ROOM \ DLIMIT - (it + 4)
drop drop NODE-ERROR b! -1 !b ;
ROOM: drop dup 4 + !b \ DP is past it
4/ b! a !b ;
header C,
: C, ( c -- )
DP a! @ push 1 (DP+) if FULL drop pop C! ;
FULL: drop pop drop drop ;
a! 1 (DP+) if FULL
drop a DP b! @b -1 + jump C!
FULL: drop ;
header 2,
: 2, ( lo hi -- ) SWAP , , ; \ the low cell first, as v3
header LATEST
: LATEST ( -- xt ) (LATEST) a! @ ;
\ ---- the fields of an entry (5.13) -----------------------------------------
: (FLAGS) ( xt -- addr ) -3 + ;
header >LINK
: >LINK ( xt -- addr ) -1 + ;
header LFA
: LFA ( xt -- addr ) jump >LINK
header LINK>
: LINK> ( addr -- xt ) a! @ ;
header >NAME
: >NAME ( xt -- baddr ) -2 + a! @ 4* ;
header NFA
: NFA ( xt -- baddr ) jump >NAME
header NAME>
: NAME> ( baddr -- xt ) dup C@ 31 and 4 + 4/ push 4/ pop + 3 + ;
header CFA
: CFA ( xt -- xt ) ;
header PFA
: PFA ( xt -- addr ) dup (FLAGS) a! @ 4 and if CODE drop 1 + ; CODE: drop ;
header >BODY
: >BODY ( xt -- addr ) jump PFA
\ ( baddr n -- baddr' ) as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
header TRAVERSE
: TRAVERSE
-if NN drop ;
NN: if ZERO drop dup C@ 31 and + 1 + ;
ZERO: drop ;
header SMUDGE
: SMUDGE ( -- ) LATEST if NONE (FLAGS) a! @ 2 xor ! ; NONE: drop ;
header HIDDEN
: HIDDEN ( -- ) LATEST if NONE (FLAGS) a! @ 2 OR ! ; NONE: drop ;
\ ---- 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 (CLIP)'s string
\ ( baddr -- baddr ) cut the counted string to 31 characters, in place
: (CLIP) dup C@ -32 + -if LONG drop ; LONG: drop 31 over C! ;
: (CLIP)
dup (D)+4 a! ! C@ -32 + -if LONG drop (D)+4 a! @ ;
LONG: drop 31 (D)+4 a! @ C! (D)+4 a! @ ;
\ ( -- bytes ) what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
: (NEED) (D)+3 a! @ 4 + -4 and 12 + ;
\ ( baddr -- ) an entry for the counted string at baddr; its code starts at
\ HERE afterwards. An empty name, or no room, makes nothing and sets
\ NODE-ERROR.
: (HEADER)
(CLIP) dup C@ if EMPTY \ baddr len
dup (D)+2 a! ! \ (CLIP), in line
C@ -32 + -if LONG drop jump CLIPPED
LONG: drop 31 (D)+2 a! @ C!
CLIPPED:
(D)+2 a! @ C@ if EMPTY \ len
(D)+3 a! !
ALIGN
dup 4 + -4 and 12 + \ baddr len need bytes: name cells and three more
dup (DP+) if FULL drop NEGATE (DP+) drop \ there is room; DP back where it was
(NEED) (DP+) if FULL drop \ there is room;
(NEED) NEGATE (DP+) drop \ DP back where it was
HERE (D) a! ! \ where the name starts
dup C, \ baddr len
L: if DONE SWAP 1 + dup C@ C, SWAP -1 + jump L \ nothing on R across C,
DONE: drop drop
P: DP a! @ 3 and if ALIGNED drop 0 C, jump P
(D)+3 a! @ C,
L: (D)+3 a! @ if DONE -1 + !
(D)+2 a! @ 1 + dup ! C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop
0 , (D) a! @ , LATEST ,
HERE (LATEST) a! ! ;
FULL: drop drop
EMPTY: drop drop NODE-ERROR b! -1 !b ;
FULL: drop ; \ (DP+) has set NODE-ERROR
EMPTY: drop NODE-ERROR b! -1 !b ;
\ ---- looking a name up -----------------------------------------------------
\ ( baddr1 baddr2 -- flag ) two counted strings are the same
\ ( -- flag ) the name of the entry in (D)+2 is the counted string in (D)+1
: (NAME=)
over C@ 1 + \ b1 b2 n the count byte and the characters
L: if SAME push
over C@ over C@ xor if EQ drop drop drop pop drop 0 ;
EQ: drop 1 + push 1 + pop pop -1 + jump L
SAME: drop drop drop -1 ;
(D)+2 a! @ >NAME (D) a! !
(D)+1 a! @ C@ 1 + (D)+3 a! ! \ the count byte and the characters
L: (D)+3 a! @ if SAME -1 + dup ! \ k
dup (D) a! @ + C@ \ k c1
SWAP (D)+1 a! @ + C@ \ c1 c2
xor if EQ drop 0 ;
EQ: drop jump L
SAME: drop -1 ;
\ ( baddr -- xt | 0 ) the newest visible entry named by the counted string
: (LOOKUP)
(CLIP) (D) 1 + a! !
(CLIP) (D)+1 a! !
LATEST
L: if END
dup (FLAGS) a! @ 2 and if VISIBLE jump OLDER
VISIBLE: drop dup >NAME (D) 1 + a! @ (NAME=) if OLDER drop ;
OLDER: drop >LINK a! @ jump L
(D)+2 a! !
(D)+2 a! @ (FLAGS) a! @ 2 and if VISIBLE drop jump OLDER
VISIBLE: drop (NAME=) if DIFF drop (D)+2 a! @ ;
DIFF: drop
OLDER: (D)+2 a! @ >LINK a! @ jump L
END: ;
\ ( -- xt | 0 ) FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
header FIND
: FIND 32 WORD jump (LOOKUP)
\ ( -- addr ) FORTH-79: the parameter field address of the next word in the
\ input stream. Not found is an error: 0, and NODE-ERROR is set.
: ' 32 WORD (LOOKUP) if MISSING jump PFA
\ input stream. Not found is an error: 0, and NODE-ERROR is set. This is '
\ when interpreting; compile.v4 adds what ' does when compiling.
: (') 32 WORD (LOOKUP) if MISSING jump PFA
MISSING: drop jump (DERR)