feat(v4.0.0): 48 more words at the prompt (words.v4)
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>
This commit is contained in:
rajames
co-authored by
Claude Opus 5.5
Claude Opus 5.5
parent
dc7e37ba5c
commit
c02505db69
@@ -14,6 +14,7 @@
|
||||
\ 1 Negative count 2 Not a number 3 Number too long
|
||||
\ 4 Not a character 5 Dictionary full 6 Name missing
|
||||
\ 7 Control structure mismatch 8 Control structures too deep
|
||||
\ 9 Shift count out of range
|
||||
\ -1 the word has printed its own message
|
||||
|
||||
macro SWAP over push push drop pop pop endmacro
|
||||
|
||||
+2
-1
@@ -95,7 +95,7 @@ header ABORT
|
||||
NODE-ERROR b! @b
|
||||
-if POS drop 2 jump (REPL)
|
||||
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4
|
||||
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8
|
||||
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9
|
||||
drop 2 jump (REPL)
|
||||
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (REPL)
|
||||
M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (REPL)
|
||||
@@ -105,6 +105,7 @@ header ABORT
|
||||
M6: drop $656D614E (EMIT4) $73696D20 (EMIT4) $676E6973 (EMIT4) CR 2 jump (REPL)
|
||||
M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (REPL)
|
||||
M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (REPL)
|
||||
M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (REPL)
|
||||
|
||||
\ The table the loader gives the node: six words, one for each kind of
|
||||
\ fault in the node's order, each a jump. A jump fills its word, so they
|
||||
|
||||
@@ -0,0 +1,201 @@
|
||||
\ 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 ;
|
||||
Reference in New Issue
Block a user