admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
1bf19d62240fcb3c4cf6abfa5c02764e385b2d62
LithosAnanake/capsules/v4/sys/words.f18
T
rajamesandClaude Opus 5.5 1bf19d6224 feat(v4): the ROM assembles the system's .f18 to the nucleus, word for word 
capsules/v4/sys: the nucleus's fourteen sources as .f18 blobs (made once by
v4/tools/v4tof18.py: header becomes the ROM's directives, every other token
and line kept), the memory map as map-<width>.f18 (mkmap sys, from one
table in host_map.h that host_load reads too), and end.f18, the switch-on
state mkimage.c set in C, the image record, and start (IDLE).

test_host_rom_nucleus.c: the ROM, fed those blobs through the console,
builds RAM identical word for word to mkimage.c's, outside its own state
and the image record, and starts at (IDLE), at both widths.  The cost:
60.7 million instructions, 1.5 s on the C model.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-15 12:27:50 -04:00

202 lines
9.0 KiB
Plaintext
Raw Blame History

\ words.v4 -- more of the FORTH vocabulary: the stack, comparison, double,
\ mixed, shift and string words that are short runs of opcodes or small loops.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.7, 5.9)
\ and the mesh-node tests execute (test_cells.c, test_foundation.c,
\ test_strings.c), here as words of the host node's vocabulary. Rests on
\ core.v4, forth.v4 and numout.v4.
\
\ Constants the loader supplies:
\ MAX-INT the largest positive number: every bit but the top one
\ (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
: 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
: 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
: 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 ;
\ ---- memory ----
set HDR-NFA here ", 2@ #, 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
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
set HDR-NFA here ", -! #, 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
: 0<> if Z drop -1 ; Z: ;
set HDR-NFA here ", 0> #, 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
: <> xor jump 0<>
set HDR-NFA here ", <= #, 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
: >= LESS jump 0=
set HDR-NFA here ", U< #, 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
: U> SWAP jump U<
set HDR-NFA here ", ABS #, 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
: 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
: 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
: 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
: LSHIFT ( x n -- x' )
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2* pop jump L
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
: RSHIFT ( x n -- x' ) \ zeros come in at the top
-if NN jump BAD
NN: dup N-1 inv + -if BAD2 drop
L: if DONE -1 + push 2/ MAX-INT and pop jump L
DONE: drop ;
BAD2: drop
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
: D- DNEGATE jump D+
set HDR-NFA here ", DABS #, 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
: D0= OR jump 0=
set HDR-NFA here ", D0< #, 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
: D= D- jump D0=
set HDR-NFA here ", D2* #, 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
: D2/ push a! 0 pop +* push drop a pop ;
set HDR-NFA here ", M+ #, 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
: M- S>D DNEGATE jump D+
\ ( d1 d2 -- d1 d2 flag ) the flag's top bit is set exactly when d1 < d2
: (D<)
dup push push over pop over over xor if TIE
drop over over xor -if HS drop drop jump S1
HS: drop push inv pop + inv
S1: -if N1 drop -1 jump D1 N1: drop 0
D1: pop SWAP ;
TIE: drop drop drop dup push push over pop
over over xor -if LS drop NIP jump S2
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
: D< (D<) push drop drop drop drop pop ;
set HDR-NFA here ", DMAX #, 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
: 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
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
set HDR-NFA here ", CMOVE> #, 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
over pop dup push + C@
over pop dup push + C!
pop jump OK
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
: 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
: 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
: ERASE ( baddr u -- ) 0 jump FILL
set HDR-NFA here ", BLANK #, 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
: -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
: 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
(X)+1 b! @b
over over - -if GE drop drop jump M
GE: drop push drop pop
M:
L: if EQ push
over C@ over C@ - if SAME
-if GT drop drop drop pop drop -1 ;
GT: drop drop drop pop drop 1 ;
SAME: drop 1 + push 1 + pop pop -1 + jump L
EQ: drop drop drop (X) b! @b (X)+1 b! @b -
-if NN drop -1 ;
NN: if ZZ drop 1 ;
ZZ: ;
set HDR-NFA here ", SEARCH #, 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
L: dup (X)+1 b! @b - -if TRY
drop drop drop (X)+2 b! @b (X)+3 b! @b 0 ;
TRY: drop over (X) b! @b (X)+1 b! @b
I: if MATCH push
over C@ over C@ xor if SAME
drop drop drop pop drop push 1 + pop -1 + jump L
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
: 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
: 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
SAME: drop push 1 + pop -1 + jump L
DONE: pop drop ;
Reference in New Issue View Git Blame Copy Permalink