       ͻ
        Lesson 5 Part 080  F-PC 3.5 Tutorial by Jack Brown 
       ͼ

\ Type this into or obtain a copy of JBFXPT03.SEQ
\ FLOAD DMULDIV.SEQ then FLOAD DMATH.SEQ finally FLOAD JBFXPT03.SEQ
\ Some unsigned double aritmetic words built on those in DMULDIV.SEQ
\ These are not required for the fixed point word set.
: UD/MOD ( ud1 ud2 -- udr udq )  0 0 2SWAP UMD/MOD   ;
: UD/    ( ud1 ud2 -- udq )      UD/MOD  2SWAP 2DROP ;
: UDMOD  ( ud1 ud2 -- udr )      UD/MOD  2DROP       ;
VARIABLE FDPL  \ Holds fixed radix point.
\ Fetch current position radix point
: FPLACES ( -- n)
          FDPL @ ;
\ Sets the position of radix point for fixed point words.
 : FIXED ( n -- )
        0 MAX 5 MIN FDPL ! ;  \ Remove restriction if you wish.
3 FIXED
\ Display fixed point number with current decimal setting.
: X. ( xn -- )
     TUCK DABS
     <#  BL HOLD FPLACES 0 ?DO # LOOP
         ASCII . HOLD #S   ROT SIGN  #> TYPE ;
\ Usage:  123.45  FIX
\ Converts double number or a single number entered at the
\ at the terminal to a fixed point number.  To compile a fixed
\ point number in a : definition use the sequence.
\   ....  [ 123.45 FIX ] DLITERAL  ....
: FIX ( dn|n -- fn )
      DPL @ 0<
      IF  S>D DPL OFF THEN
      DPL @ DUP FPLACES <
      IF    FPLACES SWAP
            ?DO BASE @ S>D D* LOOP
      ELSE  FPLACES >
            IF 2DROP TRUE ABORT" Out of range." THEN
      THEN  ;
\ Renamed to make more readable programs.
: X+    ( x1 x2 -- xsum)         D+        ;
: X-    ( x1 x2 -- xdif)         D-        ;
: XDROP ( x1 --)                 2DROP     ;
: XSWAP ( x1 x2 -- x2 x1 )       2SWAP     ;
: XOVER ( x1 x2 -- x1 x2 x1 )    2OVER     ;
: XDUP  ( x1 -- x1 x1 )          2DUP      ;
: XROT  ( x1 x2 x3 -- x2 x3 x1 ) 2ROT      ;
: -XROT ( x1 x2 x3 -- x3 x1 x2 ) 2ROT 2ROT ;
: XVARIABLE  2VARIABLE ;   : X!  2! ;
: XCONSTANT  2CONSTANT ;   : X@  2@ ;
 \ Multiply two fixed point numbers producing a fixed point product.
: X*   ( x1 x2 -- x1*x2 )
       DUP 3 PICK XOR >R     \ Save sign
       DABS 2SWAP DABS      \ ux2 ux1
       UMD*                 \ uqxproduct
       FPLACES 0 ?DO
       BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
       LOOP
       R> -ROT         \ Save sign
\      2DROP           \ Use this line for no overflow checking.
\      Comment out the line below and use above for no overflow check.
       D0=  NOT ABORT" Fixed point multiply overflow!"
       ?DNEGATE  ;
\ Divide two fixed point numbers leaving fixed pt quotient.
\ Modified to use
: X/   ( x1 x2 -- xquot=x1/x2 )
        DUP 3 PICK XOR >R           \ Save sign
        DABS >R >R DABS             \ ux1   save divisor
        0 0                         \ uqx1   extend to quad.
        FPLACES 0
        ?DO BASE @ UQN* LOOP        \ Scale dividend
        R> R> UMD/MOD               \ uxrem uxquot
        2SWAP 2DROP
        R> ?DNEGATE ;
\ Multiply two fixed point numbers producing a double fixed point
\  product.
: XM*   ( x1 x2 -- xd=x1*x2 )
       DUP 3 PICK XOR >R     \ Save sign
       DABS 2SWAP DABS      \ ux2 ux1
       UMD*                 \ uqxproduct
       FPLACES 0 ?DO
       BASE @ S>D  DUM/MOD 2ROT 2DROP  \ scale product.
       LOOP
       R> Q+- ;
\ Divide double fixed point number by fixed point number
\ leaving fixed pt quotient.
: XM/   ( xd1 x2 -- xquot=x1/x2 )
        DUP 3 PICK XOR >R           \ Save sign
        DABS >R >R QABS             \ uxd1   save divisor
        FPLACES 0
        ?DO BASE @ UQN* LOOP        \ Scale dividend
        R> R> UMD/MOD               \ uxrem uxquot
        2SWAP 2DROP
        R> ?DNEGATE ;
\ Display double fixed point number with current decimal setting.
: XD. ( xd -- )
     DUP >R
     <Q#  BL HOLD FPLACES  0 ?DO Q# LOOP
         ASCII . HOLD
         Q#S   R> SIGN  Q#>
     TYPE ;
\ (Please Move to Lesson 5 Part 090
