rajamesandClaude Opus 5.5
ab272cc2ad
- capsule/qmath.v4: Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT -- the definitions test_foundation.c executes on the mesh node, now in the host node's vocabulary. - numout.v4: DUMP. - Q./ by zero, and Q.SQRT and Q.LOG outside their domain, leave the result D-11 and D-12 give and then raise an error (D-18): "Division by zero", "Argument out of range". v3 returns 0 silently. - tests/test_host_quit.c: 122 results printed by Q.PRINT are transcripts of the v3 binary, the same at both cell widths; signed values, the errors and DUMP's layout besides. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
248 lines
9.0 KiB
Plaintext
248 lines
9.0 KiB
Plaintext
\ qmath.v4 -- Q48.16 fixed point: a signed double with sixteen bits of
|
|
\ fraction (D-8, D-10).
|
|
\
|
|
\ DECOMPOSITION.md 5.26. Each word is the definition given there and
|
|
\ executed on the mesh node by test_foundation.c and test_printing.c, here in
|
|
\ the host node's vocabulary. Rests on core.v4, forth.v4, numout.v4 and
|
|
\ words.v4.
|
|
\
|
|
\ ERRORS. Q./ by zero, and Q.SQRT and Q.LOG outside their domain, leave the
|
|
\ result D-11 and D-12 give and then raise an error (D-18): codes 11,
|
|
\ "Division by zero", and 12, "Argument out of range".
|
|
\
|
|
\ Constants the loader supplies:
|
|
\ MSB MAXHI the high cells of Q min and Q max
|
|
\ HIMASK every bit but the top sixteen
|
|
\ 2N+15 N-18 N-17 loop counts, N the cell width in bits
|
|
\ (Q/) (QE) (QR) (QL) (QT) (QP) word addresses of the words' scratch
|
|
\ cells: 5, 8, 5, 7, 6 and 4 of them
|
|
|
|
\ the logical double shift right: one +* step with S = 0, the top bit cleared
|
|
macro (UD2/) push a! 0 pop +* MAXHI and push drop a pop endmacro
|
|
|
|
: (QERR11) NODE-ERROR b! 11 !b ;
|
|
: (QERR12) NODE-ERROR b! 12 !b ;
|
|
|
|
\ ---- conversion and constants ----
|
|
header Q.FROM-INT
|
|
: Q.FROM-INT ( n -- q ) push 0 a! 0 pop N-17 FOR +* UNEXT push drop a pop ;
|
|
header Q.TO-INT
|
|
: Q.TO-INT ( q -- n ) push a! 0 pop 15 FOR +* UNEXT drop drop a ;
|
|
header Q.1 inline : Q.1 65536 0 ;
|
|
header Q.0 inline : Q.0 0 0 ;
|
|
header Q.SCALE inline : Q.SCALE 65536 0 ;
|
|
|
|
\ ---- the double words under other names ----
|
|
header Q.+ : Q.+ jump D+
|
|
header Q.- : Q.- jump D-
|
|
header Q.ABS : Q.ABS jump DABS
|
|
header Q.NEG : Q.NEG jump DNEGATE
|
|
header Q.= : Q.= jump D=
|
|
header Q.< : Q.< jump D<
|
|
header Q.> : Q.> 2SWAP jump D<
|
|
header Q.0= : Q.0= jump D0=
|
|
header Q.MAX : Q.MAX jump DMAX
|
|
header Q.MIN : Q.MIN jump DMIN
|
|
|
|
\ ---- multiply ----
|
|
header Q.*
|
|
: Q.* ( a b -- c )
|
|
SWAP push over over UM* drop
|
|
push push over pop
|
|
-if L1 SWAP jump L2 L1: SWAP drop 0 L2:
|
|
pop SWAP - push
|
|
push over pop UM* pop +
|
|
ROT pop dup push
|
|
over -if L3 drop dup jump L4 L3: drop 0 L4:
|
|
push UM* pop - D+
|
|
ROT pop UM*
|
|
SWAP push 0 D+ pop
|
|
push over pop SWAP Q.TO-INT push Q.TO-INT pop SWAP ;
|
|
|
|
\ ---- divide ----
|
|
: D2*C ( lo hi cin -- lo' hi' cout )
|
|
a! dup -if L1 drop 1 jump L2 L1: drop 0 L2: push
|
|
over -if L3 drop 1 jump L4 L3: drop 0 L4:
|
|
over + +
|
|
push 2* a + pop pop ;
|
|
|
|
: (UQ/) ( a0 a1 b0 b1 -- q0 q1 )
|
|
(Q/)+2 a! SWAP !+ ! (Q/) a! SWAP !+ ! 0 0 0
|
|
2N+15 FOR
|
|
push (Q/) a! @+ @ pop D2*C
|
|
push (Q/)+1 a! ! (Q/) a! ! pop D2*C
|
|
if CMP drop jump TAKE
|
|
CMP: drop (Q/)+3 b! @b
|
|
over over xor if EQH -if SAMEH
|
|
drop drop -if NT1 jump TAKE NT1: jump NOTAKE
|
|
SAMEH: drop over SWAP push inv pop + inv
|
|
-if T2 drop jump NOTAKE T2: drop jump TAKE
|
|
EQH: drop drop over (Q/)+2 b! @b
|
|
over over xor -if SAMEL
|
|
drop drop -if NT3 drop jump TAKEL NT3: drop jump NOTAKEL
|
|
SAMEL: drop push inv pop + inv
|
|
-if T4 drop jump NOTAKEL T4: drop jump TAKEL
|
|
TAKEL: drop (Q/)+2 b! @b push inv pop + inv 0 1 jump END
|
|
NOTAKEL: 0 jump END
|
|
TAKE: push (Q/)+2 b! @b over over push inv pop + inv push
|
|
over over xor -if SB drop NIP -if NB drop 1 jump BD NB: drop 0 jump BD
|
|
SB: drop push inv pop + inv -if NB2 drop 1 jump BD NB2: drop 0
|
|
BD: pop pop (Q/)+3 b! @b push inv pop + inv
|
|
push SWAP pop SWAP - 1 jump END
|
|
NOTAKE: 0
|
|
END:
|
|
NEXT
|
|
push (Q/) a! @+ @ pop D2*C drop push push drop drop pop pop ;
|
|
|
|
header Q./
|
|
: Q./ ( a b -- q )
|
|
over over OR if ZERO drop
|
|
push over pop SWAP over xor (Q/)+4 b! !b
|
|
-if L1 DNEGATE L1: push push -if L2 DNEGATE L2: pop pop
|
|
dup if CHK drop jump DIV
|
|
CHK: drop over -131072 and if CHK2 drop jump DIV
|
|
CHK2: drop push push dup pop dup push N-18 FOR 2* UNEXT
|
|
over over xor -if SAME drop drop -if NOOV jump OV
|
|
SAME: drop push inv pop + inv -if OV
|
|
NOOV: drop pop pop jump DIV
|
|
OV: drop drop drop pop pop drop drop
|
|
(Q/)+4 b! @b -if OVP drop 0 MSB ; OVP: drop -1 MAXHI ;
|
|
DIV: (UQ/) (Q/)+4 b! @b -if L3 drop DNEGATE ; L3: drop ;
|
|
ZERO: drop drop drop
|
|
over over OR if Z0 drop -if ZP drop drop 0 MSB jump (QERR11)
|
|
ZP: drop drop -1 MAXHI jump (QERR11)
|
|
Z0: drop jump (QERR11)
|
|
|
|
\ ---- e to the x ----
|
|
header Q.EXP
|
|
: Q.EXP ( q -- e )
|
|
over over OR if ONE drop
|
|
dup (QE)+6 b! !b -if L1 DNEGATE L1:
|
|
over over -1048576 -1 D+ push drop pop -if BIG drop
|
|
over over (QE)+2 a! SWAP !+ ! over over (QE) a! SWAP !+ !
|
|
65536 0 D+ (QE)+4 a! SWAP !+ !
|
|
2 (QE)+7 b! !b
|
|
LOOP:
|
|
(QE)+2 a! @+ @ (QE) a! @+ @ Q.*
|
|
(QE)+7 b! @b Q.FROM-INT Q./
|
|
over over (QE)+2 a! SWAP !+ !
|
|
(QE)+4 a! @+ @ D+ (QE)+4 a! SWAP !+ !
|
|
(QE)+2 a! @+ @ if HI0 drop drop jump CONT
|
|
HI0: drop -if SM drop jump CONT
|
|
SM: -50 + -if CONT1 drop jump DONE
|
|
CONT1: drop
|
|
CONT: (QE)+7 b! @b 1 + dup !b -11 + -if DONE1 drop jump LOOP
|
|
DONE1: drop
|
|
DONE: (QE)+4 a! @+ @ (QE)+6 b! @b -if POS drop 65536 0 2SWAP jump Q./
|
|
POS: drop ;
|
|
BIG: drop drop drop (QE)+6 b! @b -if BIGP drop 0 0 ; BIGP: drop -1 MAXHI ;
|
|
ONE: drop drop drop 65536 0 ;
|
|
|
|
\ ---- square root ----
|
|
header Q.SQRT
|
|
: Q.SQRT ( q -- r )
|
|
dup -if POS drop drop drop 0 0 jump (QERR12)
|
|
POS: drop over over OR if ZERO drop
|
|
over 65536 xor over OR if ONE drop
|
|
over over (QR) a! SWAP !+ ! (UD2/) 16384 0 D+ (QR)+2 a! SWAP !+ !
|
|
8 (QR)+4 b! !b
|
|
LOOP: (QR) a! @+ @ (QR)+2 a! @+ @ Q./ (QR)+2 a! @+ @ D+ (UD2/)
|
|
over over (QR)+2 a! @+ @ DNEGATE D+ -if L1 DNEGATE L1:
|
|
if HI0 drop drop jump NXT
|
|
HI0: drop -if SM drop jump NXT
|
|
SM: -10 + -if NXT1 drop drop drop (QR)+2 a! @+ @ ;
|
|
NXT1: drop
|
|
NXT: (QR)+2 a! SWAP !+ !
|
|
(QR)+4 b! @b -1 + dup !b if DONE drop jump LOOP
|
|
DONE: drop (QR)+2 a! @+ @ ;
|
|
ZERO: drop ;
|
|
ONE: drop ;
|
|
|
|
\ ---- natural logarithm ----
|
|
header Q.LOG
|
|
: Q.LOG ( x -- ln x )
|
|
dup -if POS drop jump ERR
|
|
POS: drop over over OR if ZERO drop 0 (QL)+2 b! !b
|
|
DOWN: dup if CHKLO drop jump SHR
|
|
CHKLO: drop over -131072 and if DOWNDONE drop
|
|
SHR: (UD2/) (QL)+2 b! @b 1 + !b jump DOWN
|
|
DOWNDONE: drop drop
|
|
UP: dup -65536 and if UPSHIFT drop jump NORM
|
|
UPSHIFT: drop 2* (QL)+2 b! @b -1 + !b jump UP
|
|
NORM: dup (QL) b! !b -65536 + (QL)+1 b! !b 6 (QL)+3 b! !b
|
|
NEWTON: (QL)+1 b! @b dup (QL)+4 b! !b 65536 + (QL)+5 b! !b
|
|
131072 (QL)+6 b! !b
|
|
EXPL: (QL)+4 b! @b 0 (QL)+1 b! @b 0 Q.* drop
|
|
0 (QL)+6 b! @b 0 Q./ drop dup (QL)+4 b! !b
|
|
dup (QL)+5 b! @b + !b
|
|
-50 + -if EXPC drop jump EXPD
|
|
EXPC: drop (QL)+6 b! @b 65536 + dup !b -720896 + -if EXPD2 drop jump EXPL
|
|
EXPD2: drop
|
|
EXPD: (QL) b! @b (QL)+5 b! @b push inv pop + inv
|
|
dup (QL)+4 b! !b
|
|
if DZ -if DPOS
|
|
inv 1 + 0 (QL)+5 b! @b 0 Q./ drop
|
|
(QL)+1 b! @b SWAP push inv pop + inv -if KEEP drop 0 KEEP: (QL)+1 b! !b
|
|
jump TEST
|
|
DPOS: 0 (QL)+5 b! @b 0 Q./ drop (QL)+1 b! @b + !b jump TEST
|
|
DZ: drop
|
|
TEST: (QL)+4 b! @b -if AP inv 1 + AP: -100 + -if CONT drop jump FIN
|
|
CONT: drop (QL)+3 b! @b -1 + dup !b if FIN0 drop jump NEWTON
|
|
FIN0: drop
|
|
FIN: (QL)+1 b! @b (QL)+2 b! @b
|
|
-if KP inv 1 + 45426 UM* drop inv 1 + jump KS KP: 45426 UM* drop
|
|
KS: + dup -if SP drop -1 ; SP: drop 0 ;
|
|
ZERO: drop
|
|
ERR: drop drop 0 0 jump (QERR12)
|
|
|
|
\ ---- sine and cosine ----
|
|
: (Q.REDUCE) ( x -- r )
|
|
dup (QT) b! !b -if L1 DNEGATE L1:
|
|
0 411774 UM/MOD drop 411774 UM/MOD drop
|
|
(QT) b! @b -if P1 drop inv 1 + jump J1 P1: drop J1:
|
|
dup -205888 + -if BIG drop
|
|
dup 205887 + -if OK drop 411774 + ;
|
|
OK: drop ;
|
|
BIG: drop -411774 + ;
|
|
|
|
\ The Taylor loop both use; each sets (QT) up and jumps here.
|
|
: (TRIG)
|
|
T: (QT)+2 b! @b 0 (QT)+1 b! @b 0 Q.* drop
|
|
0 (QT)+4 b! @b dup -1 + UM* drop 65536 UM* drop 0 Q./ drop
|
|
dup (QT)+2 b! !b
|
|
(QT)+5 b! @b if ADDT drop inv 1 + jump ACC ADDT: drop
|
|
ACC: (QT)+3 b! @b + !b (QT)+5 b! @b inv !b
|
|
(QT)+2 b! @b -10 + -if CONT drop jump END
|
|
CONT: drop (QT)+4 b! @b 2 + dup !b -12 + -if END2 drop jump T
|
|
END2: drop
|
|
END: (QT)+3 b! @b (QT) b! @b -if PR drop inv 1 + jump SD PR: drop
|
|
SD: dup -if SP drop -1 ; SP: drop 0 ;
|
|
|
|
header Q.SIN
|
|
: Q.SIN ( x -- sin x )
|
|
(Q.REDUCE) dup (QT) b! !b -if A1 inv 1 + A1:
|
|
dup (QT)+2 b! !b dup (QT)+3 b! !b
|
|
0 over 0 Q.* drop (QT)+1 b! !b
|
|
3 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
|
|
header Q.COS
|
|
: Q.COS ( x -- cos x )
|
|
(Q.REDUCE) -if A1 inv 1 + A1:
|
|
0 (QT) b! !b 0 over 0 Q.* drop (QT)+1 b! !b
|
|
65536 (QT)+2 b! !b 65536 (QT)+3 b! !b
|
|
2 (QT)+4 b! !b -1 (QT)+5 b! !b jump (TRIG)
|
|
|
|
\ ---- printing ----
|
|
\ The integer part, a point, five digits, a blank; always in decimal.
|
|
header Q.PRINT
|
|
: Q.PRINT ( q -- )
|
|
dup (QP)+3 b! !b -if A DNEGATE A: (QP)+2 b! !b dup (QP)+1 b! !b
|
|
BASE b! @b (QP) b! !b 10 BASE b! !b
|
|
65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT
|
|
0 <# # # # # # drop drop 46 HOLD
|
|
(QP)+1 b! @b (QP)+2 b! @b dup push
|
|
push a! 0 pop 15 FOR +* UNEXT drop drop a
|
|
pop 15 FOR 2/ UNEXT HIMASK and
|
|
#S (QP)+3 b! @b SIGN #>
|
|
(QP) b! @b BASE b! !b
|
|
TYPE jump SPACE
|