admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
1bf19d62240fcb3c4cf6abfa5c02764e385b2d62
LithosAnanake/capsules/v4/sys/forth.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

230 lines
12 KiB
Plaintext
Raw Blame History

\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are
\ opcodes or short runs of them, and the variables that are in-line addresses.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18).
\ A word flagged inline is copied into a definition in place of a call; the
\ ones that touch the return stack are compile-only as well. Rests on core.v4,
\ compile.v4's loader constants, and quit.v4, which the division words leave
\ through when the divisor is zero. (F) is seven cells of scratch for
\ 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 ;
\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register. PICK and ROLL reach under the top of a
\ stack that has no addresses: the values above the one wanted are set aside
\ in (S), and put back. (F)+3 how many are still to set aside, (F)+4 where
\ the next goes, (F)+5 the value wanted, (F)+6 how many are set aside. With n on top of a stack that is
\ otherwise one short of full there is no room at all, so until a value has been set aside nothing here pushes
\ 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
: DEPTH DSTACK-DEPTH b! @b ;
\ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR
: (INDEX)
R-CLEAR (EMIT4) $6E49203A (EMIT4) $696C6176 (EMIT4) $6E692064 (EMIT4) $786564 (EMIT4) CR
2 jump (DONE)
\ ( x1 .. xn-1 -- ) A: n, which is 2 or more. Set the n-1 values above
\ the n-th aside. If there are not that many, the pop that finds the stack
\ empty is a fault: "Stack underflow". The count is taken down only after a
\ value has been set aside, when there is room to do the arithmetic.
: (DIG)
(F)+3 b! a !b
(F)+4 b! (S) !b
(F)+6 b! 0 !b
L: (F)+4 b! @b a! !+
a (F)+4 b! !b
(F)+6 b! @b 1 + !b
(F)+3 b! @b -1 + dup !b
-1 + if DONE drop jump L
DONE: drop ;
\ ( -- x1 .. xk ) put them back. The test that ends it pushes one cell:
\ after the last value is back the stack may be one short of full.
: (BURY)
L: (F)+6 b! @b if DONE -1 + !b
(F)+4 a! @ -1 + dup ! a! @
jump L
DONE: drop ;
\ ( 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
: PICK
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop \ n is 1 when half of it is 0
(DIG) dup (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop dup ;
BAD: drop $4B434950 jump (INDEX)
\ ( 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
: ROLL
-if POS jump BAD
POS: if BAD
a! a 2/ if ONE drop
(DIG) (F)+5 a! ! (BURY) (F)+5 a! @ ;
ONE: drop ;
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 ;
\ ---- 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)
\ ---- 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 - ;
\ 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/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
\ does anything else, and a zero divisor prints v3's message --
\ /: Division by zero
\ -- and ends the line with ERROR, from however deep, as an address fault
\ does. The word's operands are taken off the stack, as v3 takes them, and
\ its caller is not returned to.
\ ( name2 name1 -- ) the word's name: its first four characters, and the
\ rest or 0 (EMIT4). The return stack is emptied before anything is called:
\ the word may have been run with it full.
: (DIV0)
R-CLEAR (EMIT4) (EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b"
$657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero"
2 jump (DONE)
\ ( d n -- rem quot ) truncating toward zero: the quotient has the sign of
\ d xor n, the remainder the sign of d. This is section 4's SM/REM with its
\ UM/MOD -- restoring division, one step a bit, the divisor in A -- written
\ into it, and the two signs kept in (F) where section 4 has them on the
\ return stack. A word that divides is then four return entries deep, not
\ eight, so division can be used inside words that other words call (D-2).
\ The answer is the same. Exact when the quotient fits a cell; its callers
\ have seen to it that n is not zero.
: SM/REM
over over xor (F) a! ! \ the quotient's sign, in its top bit
over (F)+1 a! ! \ the remainder's
-if L0 inv 1 + L0: a! \ A: |n|
-if L1 DNEGATE L1: \ |d|
N-1 FOR
-if S0
2* over -if S1 drop 1 + jump S2
S1: drop S2: push 2* pop
jump SUB
S0:
2* over -if S3 drop 1 + jump S4
S3: drop S4: push 2* pop
dup a xor -if S5
drop -if NOSUB jump SUB
S5: drop dup inv a + inv -if S6
drop jump NOSUB
S6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop \ urem uquot
(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
: 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
: 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 ;
\ ( n1 n2 n3 -- rem quot ) n1 * n2 as a double, divided by n3, which is
\ not zero. M* is written in, and n3 waits in (F)+2, so that the multiply
\ is as few return entries down as it can be.
: (*/MOD)
(F)+2 a! !
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(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
: /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
: / ( 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
: 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
: */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
: */ ( 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
: 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
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
\ ---- 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 ;
Reference in New Issue View Git Blame Copy Permalink