rajamesandClaude Opus 5.5
c02505db69
capsule/words.v4: the stack, comparison, shift, double, mixed and string words whose definitions DECOMPOSITION.md already gives and the mesh-node tests execute, now in the host node's vocabulary: 2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP - A shift count that is negative or as large as the cell is an error, as in v3 (code 9, "Shift count out of range"). - tests/test_host_quit.c: 36 sessions from the prompt that are transcripts of the v3 binary, and the cases where v4 keeps the standard (MOVE in cells; M+ and M- with the double low cell first). Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
202 lines
6.0 KiB
Plaintext
202 lines
6.0 KiB
Plaintext
\ 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 ----
|
|
header 2SWAP
|
|
: 2SWAP ( a b c d -- c d a b ) ROT push ROT pop ;
|
|
header 2OVER
|
|
: 2OVER ( a b c d -- a b c d a b ) push push over over pop pop jump 2SWAP
|
|
header 2ROT
|
|
: 2ROT ( a b c d e f -- c d e f a b ) push push 2SWAP pop pop jump 2SWAP
|
|
header 2>R inline compile-only : 2>R SWAP push push ;
|
|
header 2R> inline compile-only : 2R> pop pop SWAP ;
|
|
header 2R@ inline compile-only : 2R@ pop pop over over push push SWAP ;
|
|
header NOP inline : NOP' nop ;
|
|
header TRUE inline : TRUE -1 ;
|
|
header FALSE inline : FALSE 0 ;
|
|
header INVERT inline : INVERT inv ;
|
|
|
|
\ ---- memory ----
|
|
header 2@
|
|
: 2@ ( addr -- lo hi ) a! @+ @ ;
|
|
header 2!
|
|
: 2! ( lo hi addr -- ) a! SWAP !+ ! ;
|
|
header -!
|
|
: -! ( n addr -- ) a! NEGATE @ + ! ;
|
|
|
|
\ ---- comparison ----
|
|
header 0<>
|
|
: 0<> if Z drop -1 ; Z: ;
|
|
header 0>
|
|
: 0> -if NN drop 0 ; NN: if Z drop -1 ; Z: ;
|
|
header <>
|
|
: <> xor jump 0<>
|
|
header <=
|
|
: <= GREATER jump 0=
|
|
header >=
|
|
: >= LESS jump 0=
|
|
header U<
|
|
: U< over over xor -if SAME drop NIP jump 0<
|
|
SAME: drop - jump 0<
|
|
header U>
|
|
: U> SWAP jump U<
|
|
header ABS
|
|
: ABS -if P inv 1 + P: ;
|
|
header MAX
|
|
: MAX over over LESS if A drop push drop pop ; A: drop drop ;
|
|
header MIN
|
|
: MIN over over LESS if B drop drop ; B: drop push drop pop ;
|
|
header WITHIN
|
|
: 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").
|
|
header LSHIFT
|
|
: 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 ;
|
|
header RSHIFT
|
|
: 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 ----
|
|
header D-
|
|
: D- DNEGATE jump D+
|
|
header DABS
|
|
: DABS -if P jump DNEGATE P: ;
|
|
header D0=
|
|
: D0= OR jump 0=
|
|
header D0<
|
|
: D0< push drop pop jump 0<
|
|
header D=
|
|
: D= D- jump D0=
|
|
header D2*
|
|
: D2* 2* over -if P drop 1 + jump J P: drop J: push 2* pop ;
|
|
header D2/
|
|
: D2/ push a! 0 pop +* push drop a pop ;
|
|
header M+
|
|
: M+ S>D jump D+
|
|
header M-
|
|
: 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 ;
|
|
header D<
|
|
: D< (D<) push drop drop drop drop pop ;
|
|
header DMAX
|
|
: DMAX (D<) if L drop push push drop drop pop pop ; L: drop drop drop ;
|
|
header DMIN
|
|
: DMIN (D<) if L drop drop drop ; L: drop push push drop drop pop pop ;
|
|
|
|
\ ---- strings and memory ----
|
|
header ?TERMINAL
|
|
: ?TERMINAL ( -- flag ) CONSOLE-STATUS b! @b ;
|
|
|
|
header CMOVE>
|
|
: 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.
|
|
header MOVE
|
|
: 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 ;
|
|
|
|
header FILL
|
|
: 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 ;
|
|
header ERASE
|
|
: ERASE ( baddr u -- ) 0 jump FILL
|
|
header BLANK
|
|
: BLANK ( baddr u -- ) 32 jump FILL
|
|
|
|
header -TRAILING
|
|
: -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: ;
|
|
|
|
header COMPARE
|
|
: 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: ;
|
|
|
|
header SEARCH
|
|
: 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 ;
|
|
|
|
header SCAN
|
|
: 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 ;
|
|
header SKIP
|
|
: 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 ;
|