home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
dmath.seq
< prev
next >
Wrap
Text File
|
1990-04-16
|
4KB
|
143 lines
\ DOUBLE PRECISION ARITHMETIC
\ BY S. Y. TANG
\ Double precision arithmetic with some quad precision arithmetic
\ using codes by Robert Smith and public domain MVP-MATH by
\ Kooperman modified to give floored division in accordance with the
\ Forth-83 standard.
\ Naming convention used is: U indicates unsigned, D double, Q quad
\ and M mixed double and quad.
\ Usage of this package is subject to the conditions specified by R. Smith
\ and Kooperman.
\
\ If you have any questions contact
\ S. Y. Tang
\ 3236 Round Hill Dr
\ Hayward, Ca 94542
\ Modified for compatibility with DMULDIV.SEQ by Jack Brown 041690
\ Deleted UMD/MOD , D* and renamed UDM* to UMD* as in DMULDIV.SEQ
\ CR .( DMATH.SEQ requires loading of DMULDIV.SEQ first. )
\ CR .( DMULDIV.SEQ is from SMITH.ZIP and is placed in \FPC\TOOLS\ )
\ CR .( by F-PC 3.5 INSTALL program )
: 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>
;
: D>S ( d --- n) DROP ;
: QDUP ( q --- q q) 2OVER 2OVER ;
: Q0< ( q --- flag) >R 2DROP 2DROP R> 0< ;
: Q0= ( q --- flag) OR OR OR 0= ;
: Q@ ( addr --- q )
DUP 4 + 2@ ROT 2@
;
: Q! ( q addr --- )
DUP >R 2! R> 4 + 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
;
: ADC ( n1 n2 carry.in --- n3 carry.out)
>R 0 ROT 0 D+ R> IF 1 0 D+ THEN
;
: DADC ( d1 d2 carry.in --- d3 carry.out)
SWAP >R ROT >R ADC R> R> ROT ADC
;
: QADC ( q1 q2 carry.in --- q3 carry.out)
-ROT >R >R >R 2SWAP R> -ROT >R >R DADC
R> R> ROT R> R> ROT DADC
;
: Q+ ( q1 q2 --- q3) 0 QADC DROP ;
: QNEGATE ( q1 --- -q1)
-1. -1. QXOR 1. 0. Q+
;
: Q+- ( q n --- q1) 0< IF QNEGATE THEN ;
: QABS ( q --- qabs) DUP Q+- ;
: Q- ( q1 q2 --- q3 ) QNEGATE Q+ ;
: D>Q ( d --- q ) DUP >R DABS 0 0 R> Q+- ;
HEX
: <Q# ( q1 --- q1) <# ;
: Q#> ( uq1 --- addr n2)
2DROP 2DROP HLD @ PAD OVER - ;
: Q# ( uq1 --- uq2 )
BASE @ S>D DUM/MOD 2ROT D>S 9 OVER <
IF 7 + THEN 30 + HOLD
;
: Q#S ( uq --- 0 0 0 0 )
BEGIN Q# QDUP Q0= UNTIL
;
DECIMAL
: Q.R ( q n --- )
DEPTH 5 < ABORT" EMPTY STACK"
>R DUP >R QABS
<Q# Q#S R> SIGN Q#>
R> OVER - SPACES TYPE
;
: Q. ( q --- ) 0 Q.R SPACE ;
: Q? ( addr --- ) Q@ Q. ;
: MD/MOD ( q d1 --- d2 d3)
2DUP >R >R 2 PICK >R \ keep d1 and sign of q
>R >R QABS R> R> DABS UMD/MOD ( udmod udquot)
2SWAP R@ ?DNEGATE ( udquot dmod)
R> R> R@ SWAP >R XOR 0< \ find sign
IF R> R> D+ 2SWAP DNEGATE 1. D- ( dmod dquot)
ELSE R> R> 2DROP 2SWAP
THEN
;
: D/MOD ( d1 d2 --- d3 d4)
>R >R D>Q R> R> MD/MOD
;
: D/ ( d1 d2 --- d3 ) D/MOD 2SWAP 2DROP ;
: DMOD ( d1 d2 --- d3 ) D/MOD 2DROP ;
: DM* ( d1 d2 --- q)
DUP 3 PICK XOR >R
DABS 2SWAP DABS UMD* 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 >R ABS 0 0 0 R> Q+- ;
: UQN* ( uq un --- uq1)
>R R@ S>D UMD* 2SWAP
2ROT R> S>D UMD* Q+
;
: QCONVERT ( q1 adr1 --- q2 adr2 )
BEGIN
1+ DUP >R C@ BASE @ DIGIT
WHILE >R BASE @ UQN* R> S>Q Q+ R>
REPEAT DROP R>
;
: Q ( --- q ) \ Puts a quad# on stack. Usage: Q -1234567890 <cr>
BL WORD 0 0 ROT 0 0 ROT
DUP 1+ C@ ASCII - =
IF -1 DPL ! 1+ ELSE 0 DPL ! THEN
QCONVERT DROP DPL @ Q+-
;