rajamesandClaude Opus 5.5
443439c3d2
The first layer of the compiler capsule, on the host node: TIB >IN SPAN SOURCE BL EXPECT QUERY WORD ENCLOSE CONVERT NUMBER and the comment words. The definitions are text, v4/capsule/core.v4 (the core words they rest on) and v4/capsule/input.v4, assembled by the text assembler, which can now read a file. EXPECT, QUERY, WORD and ENCLOSE behave as v3's. CONVERT and NUMBER are FORTH-79 (ruled 2026-10-04): any BASE, a double in the standard order, and NUMBER returns a signed double or sets NODE-ERROR. Executed at both cell widths against C and against values recorded from the v3 binary. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
78 lines
2.9 KiB
Plaintext
78 lines
2.9 KiB
Plaintext
\ core.v4 -- the core words the host-node capsules rest on.
|
|
\
|
|
\ Each is the definition DECOMPOSITION.md gives and the golden-model tests
|
|
\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c),
|
|
\ written here as text for the text assembler (v4/include/v4/text.h).
|
|
\
|
|
\ Constants the loader supplies: N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX,
|
|
\ CONSOLE-RX, CONSOLE-STATUS, BASE.
|
|
|
|
macro SWAP over push push drop pop pop endmacro
|
|
macro - push inv pop + inv endmacro \ x y -- x-y
|
|
macro NEGATE inv 1 + endmacro
|
|
macro NIP push drop pop endmacro
|
|
|
|
\ ---- section 4: multiply ------------------------------------------------
|
|
: UM* ( u1 u2 -- ulo uhi )
|
|
over 1 and inv 1 + over 2/ and \ u1 u2 t0 t0 = u2 2/ if u1 odd
|
|
over a! N-1 push \ A: u2 R: loop count
|
|
push over 2/ pop \ u1 u2 s t0 s = u1 2/
|
|
L: +* unext \ u1 u2 s hi A: lo
|
|
push drop pop \ u1 u2 hi
|
|
2* a -if L0 drop 1 + jump L1 L0: drop L1: push
|
|
over -if L2 drop dup jump L3 L2: drop 0 L3: push
|
|
dup -if L4 drop over 1 and jump L5 L4: drop 0 L5:
|
|
pop + pop + push
|
|
and 1 and a 2* + pop ;
|
|
|
|
\ ---- section 5.7: doubles ------------------------------------------------
|
|
: D+ ( d1 d2 -- d3 )
|
|
push over push push drop pop \ al bl R: bh ah
|
|
over over xor -if L1
|
|
drop + -if C1 jump C0
|
|
L1: drop over -if L2
|
|
drop + jump C1
|
|
L2: drop +
|
|
C0: pop pop + ;
|
|
C1: pop pop + 1 + ;
|
|
|
|
: DNEGATE ( d -- -d )
|
|
inv over if L1 drop push inv 1 + pop ;
|
|
L1: drop 1 + ;
|
|
|
|
\ ---- section 5.3: bytes --------------------------------------------------
|
|
: C@ ( baddr -- c )
|
|
dup 2/ 2/ a! 3 and
|
|
if K0 -1 + if K1 -1 + if K2
|
|
drop @ 23 FOR 2/ UNEXT 255 and ;
|
|
K2: drop @ 15 FOR 2/ UNEXT 255 and ;
|
|
K1: drop @ 7 FOR 2/ UNEXT 255 and ;
|
|
K0: drop @ 255 and ;
|
|
|
|
: C! ( c baddr -- )
|
|
dup 2/ 2/ a! 3 and push 255 and pop
|
|
if K0 -1 + if K1 -1 + if K2
|
|
drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;
|
|
K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;
|
|
K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;
|
|
K0: drop @ -256 and + ! ;
|
|
|
|
\ ---- section 5.9: strings ------------------------------------------------
|
|
: CMOVE ( src dst u -- )
|
|
-if OK drop drop drop NODE-ERROR b! -1 !b ;
|
|
OK: if DONE push
|
|
over C@ over C! 1 + push 1 + pop pop -1 + jump OK
|
|
DONE: drop drop drop ;
|
|
|
|
\ ---- section 5.10: the console -------------------------------------------
|
|
: EMIT ( c -- ) CONSOLE-TX b! !b ;
|
|
: KEY ( -- c )
|
|
L: CONSOLE-STATUS b! @b if WAIT drop CONSOLE-RX b! @b ;
|
|
WAIT: drop jump L
|
|
|
|
\ ---- section 5.8: the number base ----------------------------------------
|
|
: (BASE) ( -- b ) \ BASE, or 10 when it is outside 2 .. 36
|
|
BASE b! @b dup -2 + -if L1 drop drop 10 ;
|
|
L1: drop dup -37 + -if L2 drop ;
|
|
L2: drop drop 10 ;
|