home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / jbfxpt03.seq < prev    next >
Encoding:
Text File  |  1990-04-16  |  4.7 KB  |  141 lines
  1. \ Program Name:  FIXPOINT
  2. \ File Name:     JBFXPT03.SEQ
  3. \ Author:        Jack W Brown
  4. \ Original Date: November 21, 1987
  5. \ Last Modified: April 16, 1990
  6. \ Function:      Fixed radix point Arithmetic operators
  7. \                and a few additional double and quad operators.
  8.  
  9. \ Notes:         Requires DMULDIV.SEQ from SMITH.ZIP
  10. \                Requires DMATH.SEQ   provided.
  11.  
  12. \ Revision History:
  13.  
  14. \ JWB 11-09-88  Converted from PF Forth to Zimmer F-PC
  15. \ JWB 02-27-89  Converted to Forth 83 floored double division.
  16. \ JWB 03-05-89  Modified to build on base of DMATH.SEQ from TANG.ARC
  17. \ JWB 03-05-89  Removed duplications with DMATH.SEQ
  18. \ JWB 03-05-89  Renamed operators to X+ X- X* X/ etc from F+ F- etc
  19. \ JWB 03-05-89  Operators now work using current system radix
  20. \ JWB 03-05-89  Added mixed mode operators XM* and XM/  XD.
  21. \ JWB 04-16-90  Changed UDM* to UMD* for compatibility with DMULDIV.SEQ
  22. \ JWB 04-16-90  Requires modified DMATH.SEQ which is provided.
  23.  
  24. CR .( FLOAD DMULDIV.SEQ  first  )
  25. CR .( FLOAD DMATH.SEQ    second )
  26. CR .( FLOAD JBFXPT03.SEQ third  )
  27.  
  28. \ Some unsigned double aritmetic words built on those in DMULDIV.SEQ
  29. \ These are not required for the fixed point word set.
  30.  
  31. : UD/MOD ( ud1 ud2 -- udr udq )  0 0 2SWAP UMD/MOD   ;
  32. : UD/    ( ud1 ud2 -- udq )      UD/MOD  2SWAP 2DROP ;
  33. : UDMOD  ( ud1 ud2 -- udr )      UD/MOD  2DROP       ;
  34.  
  35. VARIABLE FDPL  \ Holds fixed radix point.
  36.  
  37. \ Fetch current position radix point
  38. : FPLACES ( -- n)
  39.           FDPL @ ;
  40.  
  41. \ Sets the position of radix point for fixed point words.
  42.  : FIXED ( n -- )
  43.         0 MAX 5 MIN FDPL ! ;  \ Remove restriction if you wish.
  44.  
  45. 3 FIXED
  46.  
  47. \ Display fixed point number with current decimal setting.
  48. : X. ( xn -- )
  49.      TUCK DABS
  50.      <#  BL HOLD FPLACES 0 ?DO # LOOP
  51.          ASCII . HOLD
  52.          #S   ROT SIGN  #>
  53.      TYPE ;
  54.  
  55. \ Usage:  123.45  FIX
  56. \ Converts double number or a single number entered at the
  57. \ at the terminal to a fixed point number.  To compile a fixed
  58. \ point number in a : definition use the sequence.
  59. \   ....  [ 123.45 FIX ] DLITERAL  ....
  60. : FIX ( dn|n -- fn )
  61.       DPL @ 0<
  62.       IF  S>D DPL OFF THEN
  63.       DPL @ DUP FPLACES <
  64.       IF    FPLACES SWAP
  65.             ?DO BASE @ S>D D* LOOP
  66.       ELSE  FPLACES >
  67.             IF 2DROP TRUE ABORT" Out of range." THEN
  68.       THEN  ;
  69.  
  70. \ Renamed to make more readable programs.
  71. : X+    ( x1 x2 -- xsum)         D+        ;
  72. : X-    ( x1 x2 -- xdif)         D-        ;
  73. : XDROP ( x1 --)                 2DROP     ;
  74. : XSWAP ( x1 x2 -- x2 x1 )       2SWAP     ;
  75. : XOVER ( x1 x2 -- x1 x2 x1 )    2OVER     ;
  76. : XDUP  ( x1 -- x1 x1 )          2DUP      ;
  77. : XROT  ( x1 x2 x3 -- x2 x3 x1 ) 2ROT      ;
  78. : -XROT ( x1 x2 x3 -- x3 x1 x2 ) 2ROT 2ROT ;
  79.  
  80. : XVARIABLE  2VARIABLE ;   : X!  2! ;
  81. : XCONSTANT  2CONSTANT ;   : X@  2@ ;
  82.  
  83.  \ Multiply two fixed point numbers producing a fixed point product.
  84. : X*   ( x1 x2 -- x1*x2 )
  85.        DUP 3 PICK XOR >R     \ Save sign
  86.        DABS 2SWAP DABS      \ ux2 ux1
  87.        UMD*                 \ uqxproduct
  88.        FPLACES 0 ?DO
  89.        BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
  90.        LOOP
  91.        R> -ROT         \ Save sign
  92. \      2DROP           \ Use this line for no overflow checking.
  93. \      Comment out the line below and use above for no overflow check.
  94.        D0=  NOT ABORT" Fixed point multiply overflow!"
  95.        ?DNEGATE  ;
  96.  
  97. \ Divide two fixed point numbers leaving fixed pt quotient.
  98. \ Modified to use
  99. : X/   ( x1 x2 -- xquot=x1/x2 )
  100.         DUP 3 PICK XOR >R           \ Save sign
  101.         DABS >R >R DABS             \ ux1   save divisor
  102.         0 0                         \ uqx1   extend to quad.
  103.         FPLACES 0
  104.         ?DO BASE @ UQN* LOOP        \ Scale dividend
  105.         R> R> UMD/MOD               \ uxrem uxquot
  106.         2SWAP 2DROP
  107.         R> ?DNEGATE ;
  108.  
  109. \ Multiply two fixed point numbers producing a double fixed point
  110. \  product.
  111. : XM*   ( x1 x2 -- xd=x1*x2 )
  112.        DUP 3 PICK XOR >R     \ Save sign
  113.        DABS 2SWAP DABS      \ ux2 ux1
  114.        UMD*                 \ uqxproduct
  115.        FPLACES 0 ?DO
  116.        BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
  117.        LOOP
  118.        R> Q+- ;
  119.  
  120.  
  121. \ Divide double fixed point number by fixed point number
  122. \ leaving fixed pt quotient.
  123. : XM/   ( xd1 x2 -- xquot=x1/x2 )
  124.         DUP 3 PICK XOR >R           \ Save sign
  125.         DABS >R >R QABS             \ uxd1   save divisor
  126.         FPLACES 0
  127.         ?DO BASE @ UQN* LOOP        \ Scale dividend
  128.         R> R> UMD/MOD               \ uxrem uxquot
  129.         2SWAP 2DROP
  130.         R> ?DNEGATE ;
  131.  
  132.  
  133. \ Display double fixed point number with current decimal setting.
  134. : XD. ( xd -- )
  135.      DUP >R
  136.      <Q#  BL HOLD FPLACES  0 ?DO Q# LOOP
  137.          ASCII . HOLD
  138.          Q#S   R> SIGN  Q#>
  139.      TYPE ;
  140.  
  141.