\ 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