home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / tutor / l5p080 < prev    next >
Encoding:
Text File  |  1990-07-15  |  3.9 KB  |  102 lines
  1.        ╔════════════════════════════════════════════════════╗
  2.        ║ Lesson 5 Part 080  F-PC 3.5 Tutorial by Jack Brown ║
  3.        ╚════════════════════════════════════════════════════╝
  4.  
  5. \ Type this into or obtain a copy of JBFXPT03.SEQ
  6. \ FLOAD DMULDIV.SEQ then FLOAD DMATH.SEQ finally FLOAD JBFXPT03.SEQ
  7. \ Some unsigned double aritmetic words built on those in DMULDIV.SEQ
  8. \ These are not required for the fixed point word set.
  9. : UD/MOD ( ud1 ud2 -- udr udq )  0 0 2SWAP UMD/MOD   ;
  10. : UD/    ( ud1 ud2 -- udq )      UD/MOD  2SWAP 2DROP ;
  11. : UDMOD  ( ud1 ud2 -- udr )      UD/MOD  2DROP       ;
  12. VARIABLE FDPL  \ Holds fixed radix point.
  13. \ Fetch current position radix point
  14. : FPLACES ( -- n)
  15.           FDPL @ ;
  16. \ Sets the position of radix point for fixed point words.
  17.  : FIXED ( n -- )
  18.         0 MAX 5 MIN FDPL ! ;  \ Remove restriction if you wish.
  19. 3 FIXED
  20. \ Display fixed point number with current decimal setting.
  21. : X. ( xn -- )
  22.      TUCK DABS
  23.      <#  BL HOLD FPLACES 0 ?DO # LOOP
  24.          ASCII . HOLD #S   ROT SIGN  #> TYPE ;
  25. \ Usage:  123.45  FIX
  26. \ Converts double number or a single number entered at the
  27. \ at the terminal to a fixed point number.  To compile a fixed
  28. \ point number in a : definition use the sequence.
  29. \   ....  [ 123.45 FIX ] DLITERAL  ....
  30. : FIX ( dn|n -- fn )
  31.       DPL @ 0<
  32.       IF  S>D DPL OFF THEN
  33.       DPL @ DUP FPLACES <
  34.       IF    FPLACES SWAP
  35.             ?DO BASE @ S>D D* LOOP
  36.       ELSE  FPLACES >
  37.             IF 2DROP TRUE ABORT" Out of range." THEN
  38.       THEN  ;
  39. \ Renamed to make more readable programs.
  40. : X+    ( x1 x2 -- xsum)         D+        ;
  41. : X-    ( x1 x2 -- xdif)         D-        ;
  42. : XDROP ( x1 --)                 2DROP     ;
  43. : XSWAP ( x1 x2 -- x2 x1 )       2SWAP     ;
  44. : XOVER ( x1 x2 -- x1 x2 x1 )    2OVER     ;
  45. : XDUP  ( x1 -- x1 x1 )          2DUP      ;
  46. : XROT  ( x1 x2 x3 -- x2 x3 x1 ) 2ROT      ;
  47. : -XROT ( x1 x2 x3 -- x3 x1 x2 ) 2ROT 2ROT ;
  48. : XVARIABLE  2VARIABLE ;   : X!  2! ;
  49. : XCONSTANT  2CONSTANT ;   : X@  2@ ;
  50.  \ Multiply two fixed point numbers producing a fixed point product.
  51. : X*   ( x1 x2 -- x1*x2 )
  52.        DUP 3 PICK XOR >R     \ Save sign
  53.        DABS 2SWAP DABS      \ ux2 ux1
  54.        UMD*                 \ uqxproduct
  55.        FPLACES 0 ?DO
  56.        BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
  57.        LOOP
  58.        R> -ROT         \ Save sign
  59. \      2DROP           \ Use this line for no overflow checking.
  60. \      Comment out the line below and use above for no overflow check.
  61.        D0=  NOT ABORT" Fixed point multiply overflow!"
  62.        ?DNEGATE  ;
  63. \ Divide two fixed point numbers leaving fixed pt quotient.
  64. \ Modified to use
  65. : X/   ( x1 x2 -- xquot=x1/x2 )
  66.         DUP 3 PICK XOR >R           \ Save sign
  67.         DABS >R >R DABS             \ ux1   save divisor
  68.         0 0                         \ uqx1   extend to quad.
  69.         FPLACES 0
  70.         ?DO BASE @ UQN* LOOP        \ Scale dividend
  71.         R> R> UMD/MOD               \ uxrem uxquot
  72.         2SWAP 2DROP
  73.         R> ?DNEGATE ;
  74. \ Multiply two fixed point numbers producing a double fixed point
  75. \  product.
  76. : XM*   ( x1 x2 -- xd=x1*x2 )
  77.        DUP 3 PICK XOR >R     \ Save sign
  78.        DABS 2SWAP DABS      \ ux2 ux1
  79.        UMD*                 \ uqxproduct
  80.        FPLACES 0 ?DO
  81.        BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
  82.        LOOP
  83.        R> Q+- ;
  84. \ Divide double fixed point number by fixed point number
  85. \ leaving fixed pt quotient.
  86. : XM/   ( xd1 x2 -- xquot=x1/x2 )
  87.         DUP 3 PICK XOR >R           \ Save sign
  88.         DABS >R >R QABS             \ uxd1   save divisor
  89.         FPLACES 0
  90.         ?DO BASE @ UQN* LOOP        \ Scale dividend
  91.         R> R> UMD/MOD               \ uxrem uxquot
  92.         2SWAP 2DROP
  93.         R> ?DNEGATE ;
  94. \ Display double fixed point number with current decimal setting.
  95. : XD. ( xd -- )
  96.      DUP >R
  97.      <Q#  BL HOLD FPLACES  0 ?DO Q# LOOP
  98.          ASCII . HOLD
  99.          Q#S   R> SIGN  Q#>
  100.      TYPE ;
  101. \ (Please Move to Lesson 5 Part 090
  102.