|
Listing 3. DOUBLE AND QUAD MATH WORDS
¡@ ( Double precision math operators, 01mau89cht)
: 2SWAP ( d1 d2 -- d2 d1 ) ROT >R ROT R> ;
: 2OVER ( d1 d2 -- d1 d2 d1 ) >R >R 2DUP R> R> 2SWAP ;
: 2ROT ( d1 d2 d3 -- d2 d3 d1 ) >R >R 2SWAP R> R> 2SWAP ;
: D+ ( d1 d2 -- d3 ) >R SWAP >R + R> R> +c ;
: D- ( d1 d2 -- d3 ) >R SWAP >R - R> R> -c ;
: DNEGATE ( d -- -d ) SWAP NEGATE SWAP 0SWAP-c ;
: D0= ( d -- f ) OR 0= ;
: D< ( d1 d2 -- f ) D- SWAP DROP 0< ;
: D0< ( d1 -- f ) SWAP DROP 0< ;
: -ROT ( n1 n2 n3 -- n3 n1 n2 ) SWAP >R SWAP R> ;
: D>S ( d -- n) DROP ;
: S>D ( n -- d ) DUP 0< ;
( UMD/MD, 01may89cht) Divide a quad number by a double. Return double remainder and quotient. HEX Use traditional shift-subtract.
: UMD/MOD ( uquad uddiv -- udmod udquot) OVER OVER OR 0= Is divisor 0? IF ABORT" div by 0" THEN Abort if so. 4 G! 6 G! Save divisor in MD and SR. 4 G@ OVER U< Test for overflow. IF ABORT" div overflow" THEN DUP 4 G@ = IF OVER 6 G@ SWAP U< Second test for overflow. IF ABORT" div overflow" THEN THEN 20 FOR Repeat conditional subtraction. OVER [ B486 , ] ( SR@ -) Double subtract. OVER [ B584 , ] ( MD@ -c) DUP 0< Underflow? IF DROP DROP >R >R If underflow, nullify the subtract. ELSE >R >R DROP DROP Subtract ok, keep difference. THEN [ A00B , ] ( D2*c) Shift carry into quotient. R> R> [ A00B , ] Restore dividend. NEXT Repeat 31 times. D2/ 2SWAP Justify remainder. ; DECIMAL
( UDM*, 01may89cht) Multiply two doubles to get a quad. Arrange the double products among the stacks so that they can be added conveniently to leave the quad product on the data stack. : UDM* ( ud1 ud2 -- qprod ) ( a b c d -- ) 4 G! ( d) Save d in MD. 6 G! ( c) Save c in SR. DUP 6 G@ Multiply b and c. ( UM*) MULU MLR@ MHR@ >R >R ( b*c) Save b*c on the return stack. 4 G@ ( UM*) MULU MLR@ MHR@ Multiply b and d. >R >R ( b*d) Push b*d on the return stack. DUP >R 6 G@ ( UM* ( a*c) MULU MLR@ MHR@ Multiply a and c. R> 4 G@ ( UM*) MULU MLR@ MHR@ Multiply a and d. >R ( R: b*c b*d a*dh -- ; D: a*c a*dl -- ) + All products are properly ordered. R> R> +c 6 G! Start adding. R> 0 +c 4 G! R> + R> 6 G@ +c 4 G@ 0 +c ;
( D*, DUM/MOD ) All other multiply and divide words can be built from UDM* and UMD/MOD.
: D* ( d1 d2 -- dprod ) UDM* 2DROP ;
: DUM/MOD ( uq1 ud1 -- ud2 uqq) >R >R 0 0 R> R> 2DUP >R >R UMD/MOD R> R> 2SWAP >R >R UMD/MOD R> R> ;
( QDUP, ETC) Miscellaneous quad operators.
: QDUP ( q -- q q) 2OVER 2OVER ;
: Q0< ( q -- flag) >R DROP 2DROP R> 0< ;
: Q0= ( q -- flag) OR OR OR 0= ;
: Q@ ( addr -- q ) 2 @+ 2 @+ >R SWAP R> 2 @+ @ SWAP ;
: Q! ( q addr -- ) >R 2SWAP R> 2 !+ 2 !+ 2 !+ ! ;
: DXOR ( d1 d2 -- d3 ) >R SWAP >R XOR R> R> XOR ;
: QXOR ( q1 q2 -- q3) >R >R 2SWAP >R >R DXOR R> R> R> R> DXOR ;
: Q+ ( q1 q2 -- q3) >R >R 4 G! 6 G! R> SWAP >R >R >R >R 6 G@ + R> 4 G@ +c R> R> +c R> R> +c ;
: QNEGATE ( q1 -- -q1) >R >R >R NEGATE R> 0SWAP-c R> 0SWAP-c R> 0SWAP-c ;
: Q+- ( q n -- q1) 0< IF QNEGATE THEN ;
: QABS ( q -- qabs) DUP Q+- ;
: Q- ( q1 q2 -- q3 ) QNEGATE Q+ ; : D>Q ( d -- q ) DUP 0< DUP ;
( <#Q, #Q, Q#>, 01MAY89CHT) Print quad numbers.
: PAD PAD and PTR are not defined in H @ 80 + ; cmForth.
VARIABLE PTR
: QHOLD ( b -- ) -1 PTR +! PTR @ C! ;
: <Q# ( q1 -- q1) PAD PTR ! ;
: Q#> ( uq1 -- addr n2) 2DROP 2DROP PTR @ PAD OVER - ;
: Q# ( uq1 -- uq2 ) BASE @ S>D DUM/MOD 2ROT D>S 9 OVER < IF 7 + THEN 48 + QHOLD ;
: Q#S ( uq -- 0 0 0 0 ) BEGIN Q# QDUP Q0= UNTIL ;
: QSIGN ( n -- ) 0< IF 45 QHOLD THEN ;
: Q.R ( q n -- ) >R DUP >R QABS <Q# Q#S R> QSIGN Q#> R> OVER - SPACES TYPE ;
: Q. ( q -- ) 0 Q.R SPACE ;
: Q? ( addr -- ) Q@ Q. ;
( MD/MOD, 01MAY89CHT) Some handy double word operators.
: ?DNEGATE 0< IF DNEGATE THEN ;
: DABS DUP 0< IF DNEGATE THEN ;
: MD/MOD ( q d1 -- d2 d3) Signed quad division. 2DUP >R >R 4 G! OVER >R 4 G@ Keep d1 and sign of q. >R >R QABS R> R> DABS UMD/MOD udmod udquot -- 2SWAP I ?DNEGATE udquot dmod -- R> R> I SWAP >R XOR 0< Find sign. IF R> R> D+ 2SWAP DNEGATE 1 0 D- dmod dquot -- ELSE R> R> 2DROP 2SWAP THEN ;
: D/MOD ( d1 d2 -- d3 d4) >R >R D>Q R> R> MD/MOD ;
( D MATH, 01MAY89CHT) With quad word set done, the double word set is easy. : D/ ( d1 d2 -- d3 ) D/MOD 2SWAP 2DROP ;
: DMOD ( d1 d2 -- d3 ) D/MOD 2DROP ;
: DM* ( d1 d2 -- q) 4 G! OVER 4 G@ XOR >R 4 G@ DABS 2SWAP DABS UDM* R> Q+- ;
: D*/MOD ( d1 d2 d3 -- d4 d5 ) >R >R DM* R> R> MD/MOD ;
: D*/ ( d1 d2 d3 -- d4 ) D*/MOD 2SWAP 2DROP ;
: S>Q ( n -- q) DUP 0< DUP DUP ;
HEX
: -DIGIT ( c -- n f ) The cmForth version is not adequate. DUP 39 > It must not abort on a non-digit, IF DUP 40 > but return a flag. 7 AND - THEN 30 - DUP BASE @ U< ; DECIMAL
( Q INPUT, 01MAY89CHT) Output quad numbers.
: UQN* ( uq un -- uq1) DUP >R SWAP >R SWAP >R S>D UDM* R> R> R> S>D UDM* 2DROP D+ ;
: QCONVERT ( q1 adr1 -- q2 adr2 ) BEGIN 1 + DUP >R C@ -DIGIT WHILE >R BASE @ UQN* R> S>Q Q+ R> REPEAT DROP R> ;
VARIABLE DPL Flag for decimal point.
: Q ( -- q ) Accept a numeric string and convert it to a quad number. 32 WORD 0 0 ROT 0 0 ROT DUP 1 + C@ 45 ( ASCII - ) = IF -1 DPL ! 1 + ELSE 0 DPL ! THEN QCONVERT DROP DPL @ Q+- ;
¡@ |