home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / dmath.seq < prev    next >
Encoding:
Text File  |  1990-04-16  |  3.6 KB  |  143 lines
  1. \                   DOUBLE PRECISION ARITHMETIC
  2. \                         BY S. Y. TANG
  3. \ Double precision arithmetic with some quad precision arithmetic
  4. \ using codes by Robert Smith and public domain MVP-MATH by
  5. \ Kooperman modified to give floored division in accordance with the
  6. \ Forth-83 standard.
  7. \ Naming convention used is: U indicates unsigned, D double, Q quad
  8. \ and M mixed double and quad.
  9. \ Usage of this package is subject to the conditions specified by R. Smith
  10. \ and Kooperman.
  11. \
  12. \ If you have any questions contact
  13. \                         S. Y. Tang
  14. \                         3236 Round Hill Dr
  15. \                         Hayward, Ca 94542
  16.  
  17. \ Modified for compatibility with DMULDIV.SEQ by Jack Brown 041690
  18. \ Deleted UMD/MOD , D*  and renamed  UDM* to UMD* as in DMULDIV.SEQ
  19.  
  20. \ CR .( DMATH.SEQ requires loading of  DMULDIV.SEQ  first.   )
  21. \ CR .( DMULDIV.SEQ is from SMITH.ZIP and is placed in  \FPC\TOOLS\ )
  22. \ CR .( by F-PC 3.5 INSTALL program )
  23.  
  24. : DUM/MOD   ( uq1 ud1 --- ud2 uqq)
  25.    >R >R 0 0 R> R> 2DUP >R >R
  26.    UMD/MOD  R> R> 2SWAP  >R >R UMD/MOD  R> R>
  27. ;
  28. : D>S   ( d --- n)   DROP  ;
  29.  
  30. : QDUP   ( q --- q q)   2OVER 2OVER ;
  31.  
  32. : Q0<   ( q --- flag)   >R 2DROP 2DROP R> 0< ;
  33.  
  34. : Q0=   ( q --- flag)   OR OR OR 0= ;
  35.  
  36. : Q@   ( addr --- q )
  37.    DUP 4 + 2@ ROT 2@
  38. ;
  39. : Q!   ( q addr --- )
  40.    DUP >R 2!  R> 4 + 2!
  41. ;
  42.  
  43. : DXOR   ( d1 d2 --- d3 )
  44.    >R SWAP >R  XOR  R> R> XOR
  45. ;
  46. : QXOR   ( q1 q2 --- q3)
  47.    >R >R 2SWAP >R >R DXOR R> R> R> R> DXOR
  48. ;
  49. : ADC   ( n1 n2 carry.in --- n3 carry.out)
  50.    >R 0 ROT 0 D+  R> IF 1 0 D+ THEN
  51. ;
  52. : DADC   ( d1 d2 carry.in --- d3 carry.out)
  53.    SWAP >R ROT >R ADC R> R> ROT ADC
  54. ;
  55. : QADC   ( q1 q2 carry.in --- q3 carry.out)
  56.    -ROT >R >R >R 2SWAP R> -ROT >R >R DADC
  57.    R> R> ROT R> R> ROT DADC
  58. ;
  59. : Q+   ( q1 q2 --- q3)  0 QADC DROP ;
  60.  
  61. : QNEGATE   ( q1 --- -q1)
  62.    -1. -1. QXOR   1. 0. Q+
  63. ;
  64. : Q+-   ( q n --- q1)    0< IF QNEGATE THEN ;
  65.  
  66. : QABS   ( q --- qabs)   DUP Q+- ;
  67.  
  68. : Q-   ( q1 q2 --- q3 )   QNEGATE Q+ ;
  69.  
  70. : D>Q   ( d --- q )   DUP >R DABS 0 0 R> Q+- ;
  71.  
  72. HEX
  73.  
  74. : <Q#   ( q1 --- q1)   <#  ;
  75.  
  76. : Q#>   ( uq1 --- addr n2)
  77.    2DROP 2DROP   HLD @  PAD OVER - ;
  78.  
  79. : Q#   ( uq1 --- uq2 )
  80.    BASE @ S>D  DUM/MOD   2ROT   D>S   9 OVER <
  81.    IF 7 + THEN  30 + HOLD
  82. ;
  83. : Q#S   ( uq --- 0 0 0 0 )
  84.    BEGIN Q# QDUP Q0= UNTIL
  85. ;
  86.  
  87. DECIMAL
  88.  
  89. : Q.R   ( q n --- )
  90.    DEPTH 5 < ABORT" EMPTY STACK"
  91.    >R DUP >R QABS
  92.    <Q# Q#S R> SIGN Q#>
  93.    R> OVER - SPACES TYPE
  94. ;
  95. : Q.   ( q --- )   0 Q.R SPACE ;
  96.  
  97. : Q?   ( addr --- )   Q@ Q. ;
  98.  
  99. : MD/MOD  ( q d1 --- d2 d3)
  100.    2DUP >R >R 2 PICK >R     \ keep d1 and sign of q
  101.    >R >R QABS R> R> DABS UMD/MOD    ( udmod udquot)
  102.    2SWAP R@ ?DNEGATE                ( udquot dmod)
  103.    R> R> R@ SWAP >R XOR 0<             \ find sign
  104.    IF R> R> D+  2SWAP DNEGATE 1. D-   ( dmod dquot)
  105.    ELSE R> R> 2DROP 2SWAP
  106.    THEN
  107. ;
  108. : D/MOD   ( d1 d2 --- d3 d4)
  109.    >R >R   D>Q  R> R>  MD/MOD
  110. ;
  111. : D/     ( d1 d2 --- d3 )    D/MOD  2SWAP 2DROP ;
  112.  
  113. : DMOD   ( d1 d2 --- d3 )    D/MOD 2DROP ;
  114.  
  115. : DM*   ( d1 d2 --- q)
  116.    DUP 3 PICK XOR >R
  117.    DABS 2SWAP DABS UMD* R> Q+-
  118. ;
  119. : D*/MOD   ( d1 d2 d3 --- d4 d5 )  >R >R DM* R> R> MD/MOD ;
  120.  
  121. : D*/   ( d1 d2 d3 --- d4 )  D*/MOD 2SWAP 2DROP ;
  122.  
  123. : S>Q   ( n --- q) DUP >R ABS 0 0 0 R> Q+- ;
  124.  
  125. : UQN*   ( uq un --- uq1)
  126.    >R R@ S>D UMD* 2SWAP
  127.    2ROT R> S>D UMD* Q+
  128. ;
  129. : QCONVERT   ( q1 adr1 --- q2 adr2 )
  130.    BEGIN
  131.    1+ DUP >R C@ BASE @ DIGIT
  132.      WHILE >R BASE @ UQN* R> S>Q Q+ R>
  133.    REPEAT DROP R>
  134. ;
  135. : Q   ( --- q ) \ Puts a quad# on stack. Usage: Q -1234567890 <cr>
  136.    BL WORD 0 0 ROT 0 0 ROT
  137.    DUP 1+ C@ ASCII - =
  138.    IF -1 DPL ! 1+ ELSE 0 DPL ! THEN
  139.    QCONVERT DROP DPL @ Q+-
  140. ;
  141.  
  142.  
  143.