rajamesandClaude Opus 5.5
361dcd1148
Ruled 2026-10-04: guarded, an error shown, back to the prompt.
- capsule/forth.v4: / MOD /MOD */ */MOD M/MOD, M* and S>D join the
vocabulary. Each dividing word tests its divisor first; zero prints
v3's message ("/: Division by zero"), ends an open definition, prints
ERROR and returns to the prompt from however deep.
- SM/REM here has UM/MOD written into it and keeps its signs in memory,
and */MOD has M* written in, so that division can be used inside words
that other words call: / from four words deep, */MOD from three.
- forth.v4 now loads after quit.v4, which the guard leaves through.
- tests: v3 transcripts for each message; /MOD, /, MOD and */MOD against
C on every pair of edge values.
Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
165 lines
6.4 KiB
Plaintext
165 lines
6.4 KiB
Plaintext
\ 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 three cells of scratch for
|
|
\ this file.
|
|
|
|
\ ---- stack ----
|
|
header DUP inline : DUP dup ;
|
|
header DROP inline : DROP drop ;
|
|
header OVER inline : OVER over ;
|
|
header SWAP inline : SWAP' SWAP ;
|
|
header ROT inline : ROT' ROT ;
|
|
header -ROT inline : -ROT SWAP push SWAP pop ;
|
|
header ?DUP : ?DUP if Z dup ; Z: ;
|
|
header 2DUP inline : 2DUP over over ;
|
|
header 2DROP inline : 2DROP drop drop ;
|
|
|
|
\ ---- return stack: in line, and only inside a definition ----
|
|
header >R inline compile-only : >R push ;
|
|
header R> inline compile-only : R> pop ;
|
|
header R@ inline compile-only : R@ pop dup push ;
|
|
header I inline compile-only : I pop dup push ;
|
|
header J inline compile-only : J pop pop pop dup push a! push push a ;
|
|
header LEAVE inline compile-only : LEAVE pop pop drop dup push push ;
|
|
header UNLOOP inline compile-only : UNLOOP pop drop pop drop ;
|
|
|
|
\ ---- memory ----
|
|
header @ inline : FETCH a! @ ;
|
|
header ! inline : STORE a! ! ;
|
|
header +! inline : +! a! @ + ! ;
|
|
header CELLS inline : CELLS ; \ an address unit is a cell (D-1)
|
|
|
|
\ ---- arithmetic ----
|
|
header + inline : PLUS + ;
|
|
header - inline : 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.
|
|
header * : STAR a! 0 N-1 FOR +* UNEXT drop drop a ;
|
|
header NEGATE inline : NEGATE' NEGATE ;
|
|
header 1+ inline : 1+ 1 + ;
|
|
header 1- inline : 1- -1 + ;
|
|
header 2+ inline : 2+ 2 + ;
|
|
header 2- inline : 2- -2 + ;
|
|
header 2* inline : TWO* 2* ;
|
|
header 2/ inline : 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. Nothing is left for the word's caller: it is not returned to.
|
|
|
|
\ ( name -- ) name is up to four characters of the word's name (EMIT4)
|
|
: (DIV0)
|
|
(EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b"
|
|
$657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero"
|
|
2 jump (REPL)
|
|
|
|
\ ( 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 ;
|
|
|
|
header S>D
|
|
: 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.
|
|
header M*
|
|
: 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
|
|
|
|
header /MOD
|
|
: /MOD ( n1 n2 -- rem quot )
|
|
if Z push S>D pop jump SM/REM
|
|
Z: $444F4D2F jump (DIV0)
|
|
header /
|
|
: / ( n1 n2 -- quot )
|
|
if Z push S>D pop SM/REM NIP ;
|
|
Z: $2F jump (DIV0)
|
|
header MOD
|
|
: MOD ( n1 n2 -- rem )
|
|
if Z push S>D pop SM/REM drop ;
|
|
Z: $444F4D jump (DIV0)
|
|
header */MOD
|
|
: */MOD ( n1 n2 n3 -- rem quot )
|
|
if Z jump (*/MOD)
|
|
Z: $4F4D2F2A (EMIT4) $44 jump (DIV0)
|
|
header */
|
|
: */ ( n1 n2 n3 -- quot )
|
|
if Z (*/MOD) NIP ;
|
|
Z: $2F2A jump (DIV0)
|
|
header M/MOD
|
|
: M/MOD ( d n -- rem quot )
|
|
if Z jump SM/REM
|
|
Z: $4F4D2F4D (EMIT4) $44 jump (DIV0)
|
|
|
|
\ ---- logic and comparison ----
|
|
header AND inline : AND and ;
|
|
header XOR inline : XOR xor ;
|
|
header OR inline : OR' OR ;
|
|
header 0= : 0= if L1 drop 0 ; L1: drop -1 ;
|
|
header 0< : 0< -if L1 drop -1 ; L1: drop 0 ;
|
|
header NOT : NOT jump 0=
|
|
header = : EQUALS xor jump 0=
|
|
header < : LESS
|
|
over over xor -if SAME drop drop jump 0<
|
|
SAME: drop - jump 0<
|
|
header > : GREATER SWAP jump LESS
|
|
|
|
\ ---- in-line addresses and constants ----
|
|
header BL inline : BL' BL ;
|
|
header TIB inline : TIB' TIB ;
|
|
header >IN inline : >IN' >IN ;
|
|
header SPAN inline : SPAN' SPAN ;
|
|
header BASE inline : BASE' BASE ;
|
|
header PAD inline : PAD' PAD ;
|
|
header STATE inline : STATE' STATE ;
|