--
--	Inmos Libraries
--	Copyright (C) 1988, 1989, 1990, 1991, 1993  Inmos Limited
--
--	This library is free software; you can redistribute it and/or
--	modify it under the terms of the GNU Lesser General Public
--	License as published by the Free Software Foundation; either
--	version 2 of the License, or (at your option) any later version.
--
--	This library is distributed in the hope that it will be useful,
--	but WITHOUT ANY WARRANTY; without even the implied warranty of
--	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--	Lesser General Public License for more details.
--
--	You should have received a copy of the GNU Lesser General Public
--	License along with this library; if not, write to the Free Software
--	Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
--

--** @module forall

#IF (TARGET.BITS.PER.WORD = 32)

--{{{  #options and #comments
#OPTION "E V"  -- no compiler libs, no vector space
#COMMENT "TA compiler library, V1.2 06/04/90"
#COMMENT "(c) Copyright INMOS Limited 1988"
--}}}

#PRAGMA TRANSLATE IEEE64OP "IEEE64OP%O"

#INCLUDE "realvals.inc"

--{{{  IEEE64OP   -- TA
BOOL,REAL64 FUNCTION IEEE64OP (VAL REAL64 X, VAL INT RoundMode, Op,
                               VAL REAL64 Yp)

  -- Beta-3 (11may87)
  -- Range checking of Op and RoundMode added 16-sep-87

  BOOL Error:
  REAL64 Result:
  VALOF
    #PRAGMA TRANSLATE RealIMul "RealIMul%CHK"
    #PRAGMA TRANSLATE RealIDiv "RealIDiv%CHK"
    #USE "rimul"  --  13-Sep-07
    #USE "ridiv"  --  13-Sep-07
    #INCLUDE "endian.inc"  --  4-Sep-07
    --{{{  DEFs
    --{{{  IEEE Double length constants for 32 bit implementation
    VAL DBiggestFinite.hi IS #7FEFFFFF :
    VAL DBiggestFinite.lo IS #FFFFFFFF :
    --}}}
    --{{{  NaNs
    --  These are the values of nans returned by the IMS T800
    VAL ZeroZeroDivNaN.hi  IS #7FF80000 :
    VAL InfInfDivNaN.hi    IS #7FF40000 :
    VAL ZeroInfMulNaN.hi   IS #7FF20000 :
    VAL AddSubInfInfNaN.hi IS #7FF10000 :
    VAL NegSqrtNaN.hi      IS #7FF08000 :
    VAL Real64to32NaN.hi   IS #7FF04000 :
    VAL RemInfNaN.hi       IS #7FF00800 :
    VAL RemZeroNaN.hi      IS #7FF00400 :
    --}}}
    --}}}
    [2]INT Result RETYPES Result :
    VAL [2]INT X RETYPES X :
    VAL [2]INT Yp RETYPES Yp :
    INT Xexp, Yexp :
    [2] INT Xfrac :
    PLACE Xfrac IN WORKSPACE :
    [2] INT Yfrac :
    PLACE Yfrac IN WORKSPACE :
    INT Carry, Guard, Places :
    [2] INT Ans :
    PLACE Ans IN WORKSPACE :
    [2] INT Y :
    PLACE Y IN WORKSPACE :
    VAL INT Sign IS SignBit :
    SEQ
      --{{{  range check
      IF
        ((Op < 0) OR (Op > 3)) OR ((RoundMode < 0) OR (RoundMode > 3))
          CAUSEERROR ()
        TRUE
          SKIP
      --}}}
      --{{{  Unpack operands
      --{{{  Seperate mantissa and exponents
      IF
        Op = Sub              --get minus Y
          Y [hi] := Yp [hi] >< Sign
        TRUE                  --use plus Y
          Y [hi] := Yp [hi]
      Y [lo] := Yp [lo]
      
      Xfrac [hi],  Xfrac [lo] := SHIFTLEFT ( X [hi],  X [lo],  DRealShift)
      Yfrac [hi],  Yfrac [lo] := SHIFTLEFT ( Y [hi],  Yp [lo],  DRealShift)
      
      Xexp := (X [hi] >> DRealExpSh) /\ DRealExp
      Yexp := (Y [hi] >> DRealExpSh) /\ DRealExp
      --}}}
      
      Ans [lo] := 0
      Carry := 0                          --assume not normal case
      Error := FALSE                      --assume not normal case
      IF
        (Xexp <> DRealExp) AND (Yexp <> DRealExp)
          --{{{  zeros or real nos
          IF
            (Xexp <> 0) AND (Yexp <> 0)
              --{{{  both normal nos
              SEQ                                  --normal case
                Carry := 1
                Xfrac [hi] := Xfrac [hi] \/ Sign
                Yfrac [hi] := Yfrac [hi] \/ Sign
              --}}}
            ((Xexp \/ Xfrac [hi]) \/ Xfrac [lo]) = 0
              --{{{  X is zero
              IF
                ((Yexp \/ Yfrac [hi]) \/ Yfrac [lo]) = 0--both zero
                  IF
                    Op < Mul                       --add/sub
                      IF
                        RoundMode = RM
                          SEQ
                            Ans [lo] := 0
                            Ans [hi] := X [hi] \/ Y [hi]
                        TRUE
                          SEQ
                            Ans [lo] := 0
                            Ans [hi] := X [hi] /\ Y [hi]
                    Op = Mul
                      Ans [hi] := X [hi] >< Y [hi]    --signed zero
                    TRUE                           --div
                      SEQ
                        Ans [hi] := ZeroZeroDivNaN.hi
                        Ans [lo] := 0
                        Error := TRUE
                Op < Mul                           --result is Y
                  SEQ
                    Ans [hi] := Y [hi]
                    Ans [lo] := Y [lo]
                TRUE                                 --mul or div
                  Ans [hi] := (X [hi] >< Y [hi]) /\ Sign--zero
              --}}}
            ((Yexp \/ Yfrac [hi]) \/ Yfrac [lo]) = 0
              --{{{  Y is zero
              IF
                Op < Mul                           --add/sub
                  SEQ
                    Ans [hi] := X [hi]
                    Ans [lo] := X [lo]
                Op = Mul
                  Ans [hi] := (X [hi] >< Y [hi]) /\ Sign--zero
                TRUE                               --div by zero
                  SEQ
                    Ans [hi] := ((X [hi] >< Y [hi]) /\ Sign) \/ DRealInf--infinity
                    Error := TRUE
              --}}}
            TRUE
              --{{{  one or both are denormalised
              -- Put in implicit MSB
              -- Normalise any denormaliseds and correct their exponents if op is
              -- multiply or divide leave unormal for add and sub
              SEQ
                Carry := 1                         --work to do
                IF
                  Xexp <> 0                        --set leading bit
                    Xfrac [hi] := Xfrac [hi] \/ Sign
                  TRUE                             --set correct exponent
                    IF
                      Op > Sub
                        SEQ
                          Places,  Xfrac [hi],  Xfrac [lo] := NORMALISE ( Xfrac [hi], Xfrac [lo])
                          Xexp := 1 - Places
                      TRUE
                        Xexp := 1
                IF
                  Yexp <> 0
                    Yfrac [hi] := Yfrac [hi] \/ Sign
                  TRUE
                    IF
                      Op > Sub
                        SEQ
                          Places,  Yfrac [hi],  Yfrac [lo] := NORMALISE ( Yfrac [hi], Yfrac [lo])
                          Yexp := 1 - Places
                      TRUE
                        Yexp := 1
              --}}}
          --}}}
        TRUE
          --{{{  one or other inf/NAN
          SEQ
            Error := TRUE
            Xfrac [hi] := Xfrac [hi] /\ (~Sign)      --clear top bits
            Yfrac [hi] := Yfrac [hi] /\ (~Sign)
            IF
              (Xexp = DRealExp) AND (Yexp = DRealExp)
                --{{{  both inf/NaN
                IF
                  (((Xfrac [hi] \/ Xfrac [lo]) \/ Yfrac [hi]) \/ Yfrac [lo]) <> 0
                    SEQ
                      Guard, Places := LONGDIFF (Xfrac[lo], Yfrac[lo], 0)
                      Guard, Places := LONGDIFF (Xfrac[hi], Yfrac[hi], Guard)
                      IF
                        Places < 0
                          Ans := Y
                        TRUE
                          Ans := X
                      IF
                        Op < Mul
                          SKIP
                        TRUE
                          Ans [hi] := (Ans [hi] /\ (~Sign)) \/ ((X [hi] >< Y [hi]) /\ Sign)
                  (Op < Mul) AND (((X [hi] >< Y [hi]) /\ Sign) = 0)--add/sub same inf
                    Ans [hi] := X [hi]
                  Op = Mul
                    Ans [hi] := ((X [hi] >< Y [hi]) /\ Sign) \/ DRealInf--infinity
                  TRUE                             --add/sub/div
                    SEQ
                      IF
                        Op = Div
                          Ans [hi]:= InfInfDivNaN.hi
                        TRUE
                          Ans [hi] := AddSubInfInfNaN.hi
                      Ans [lo]:= 0
                --}}}
              Xexp = DRealExp
                --{{{  X is inf/NaN
                IF
                  (Op < Mul)   -- inf +- finite  or  nan +- finite
                    Ans := X
                  (Xfrac [hi] \/ Xfrac [lo]) <> 0  -- nan */ finite
                    SEQ
                      Ans [lo] := X [lo]
                      Ans [hi] := X [hi] >< (Y [hi] /\ Sign)
                  Op = Mul
                    IF
                      ((Yexp \/ Yfrac [hi]) \/ Yfrac [lo]) = 0--mul by zero
                        SEQ
                          Ans [hi] := ZeroInfMulNaN.hi
                          Ans [lo] := 0
                      TRUE                        --inf times normal
                        Ans [hi] := ((X [hi] >< Y [hi]) /\ Sign) \/ DRealInf--infinity
                  TRUE
                    Ans [hi] := ((X [hi] >< Y [hi]) /\ Sign) \/ DRealInf--infinity
                --}}}
              (Yfrac [hi] \/ Yfrac [lo]) <> 0
                --{{{  Y is NaN
                IF
                  (Op < Mul)    -- finite +- nan
                    Ans := Y
                  TRUE          -- finite */ nan
                    SEQ
                      Ans [hi] := Y [hi] >< (X [hi] /\ Sign)     --keep NaN (may be - if sub)
                      Ans [lo] := Y [lo]
                --}}}
              TRUE
                --{{{  Y is inf
                IF
                  Op < Mul                        --add/sub
                    SEQ
                      Ans [hi] := Y [hi]
                      Ans [lo] := Y [lo]
                  Op = Mul
                    IF
                      ((Xexp \/ Xfrac [hi]) \/ Xfrac [lo]) = 0--mul by zero
                        SEQ
                          Ans [hi] := ZeroInfMulNaN.hi
                          Ans [lo] := 0
                      TRUE                        --inf times normal
                        Ans [hi] := ((X [hi] >< Y [hi]) /\ Sign) \/ DRealInf--infinity
                  TRUE                            --div
                    Ans [hi] := (X [hi] >< Y [hi]) /\ Sign
                --}}}
          --}}}
      --}}}
      --{{{  evaluate
      IF
        Carry = 0
          --{{{  Answer is set up
          SEQ
            Result [hi] := Ans [hi]
            Result [lo] := Ans [lo]
          --}}}
        TRUE
          --{{{  Do an operation
          SEQ
            IF
              --{{{  add or subtract
              Op < Mul                          --add/sub to do
                SEQ
                  Places := Xexp - Yexp
                  --{{{  Align Mantissas
                  IF
                    Places = 0
                      Guard := 0                -- correctly aligned
                    Places > 0
                      --{{{  shift Y
                      IF
                        Places > ((3 * BitsPerWord) - (DBitsInFrac + 1))
                          --{{{  shift Y over a long distance
                          IF
                            Places > (DBitsInFrac + 1)
                              --{{{  Total loss of significance
                              SEQ
                                Yfrac [hi] := 0
                                Yfrac [lo] := 0
                                Guard := 1      -- there was something in Yfrac as Y <> 0
                              --}}}
                            TRUE
                              --{{{  Save some significance
                              -- Some of the bits will be shifted out of the register triplet
                              -- and so need to be ORed into the guard/sticky register it is
                              -- safe to use the whole of the lower part of the fraction and
                              -- OR it if for a particular length machine, the above conditional
                              -- is true and
                              -- 2*BitsPerWord > DBitsInFrac ie 2*16 > 24 and 2*32 > 52,
                              SEQ
                                Carry := Yfrac [lo]      -- Bits that might be lost
                                Yfrac [lo],  Guard := SHIFTRIGHT ( Yfrac [hi],  Yfrac [lo],  Places - BitsPerWord)
                              
                                Guard := Guard \/ Carry
                                Yfrac [hi] := 0
                              --}}}
                          --}}}
                        TRUE
                          --{{{  shift Y
                          SEQ
                            Carry,  Guard := SHIFTRIGHT ( Yfrac [lo],  0,  Places)
                            IF
                              Places > BitsPerWord
                                SEQ
                                  Yexp,  Carry := SHIFTRIGHT ( Yfrac [hi],  0,  Places - BitsPerWord)
                                  Guard := Guard \/ Carry
                              TRUE
                                SKIP
                            Yfrac [hi],  Yfrac [lo] := SHIFTRIGHT ( Yfrac [hi],  Yfrac [lo],  Places)
                          
                          --}}}
                      --}}}
                    TRUE
                      --{{{  shift X
                      IF
                        Places < (-((3 * BitsPerWord) - (DBitsInFrac + 1)))
                          --{{{  shift X over a long distance
                          SEQ
                            IF
                              Places < (-(DBitsInFrac + 1))
                                --{{{  Total loss of significance
                                SEQ
                                  Xfrac [hi] := 0
                                  Xfrac [lo] := 0
                                  Guard := 1      -- there was something in Xfrac as X <> 0
                                  Xexp := Yexp
                                --}}}
                              TRUE
                                --{{{  Save some significance
                                SEQ
                                  Carry := Xfrac [lo]       -- Bits that might be lost
                                  Xfrac [lo],  Guard := SHIFTRIGHT ( Xfrac [hi],  Carry,  (-Places) - BitsPerWord)
                                  Guard := Guard \/ Carry
                                  Xfrac [hi] := 0
                                  Xexp := Yexp
                                --}}}
                          --}}}
                        TRUE
                          --{{{  shift X
                          SEQ
                            Xexp := Yexp            --set largest exp
                            Carry,  Guard := SHIFTRIGHT ( Xfrac [lo],  0,  -Places)
                            IF
                              Places < (-BitsPerWord)
                                SEQ
                                  Yexp,  Carry := SHIFTRIGHT ( Xfrac [hi],  0,  (-Places) - BitsPerWord)
                                  Guard := Guard \/ Carry
                              TRUE
                                SKIP
                            Xfrac [hi],  Xfrac [lo] := SHIFTRIGHT ( Xfrac [hi],  Xfrac [lo],  -Places)
                          
                          --}}}
                      --}}}
                  --}}}
                  IF
                    ((X [hi] >< Y [hi]) /\ Sign) = 0
                      --{{{  add magnitudes
                      SEQ
                        -- Answer is always same sign as X and Y
                        Ans [hi] := X [hi] /\ Sign
                        Carry,  Xfrac [lo] := LONGSUM ( Xfrac [lo],  Yfrac [lo],  0)
                        Carry,  Xfrac [hi] := LONGSUM ( Xfrac [hi],  Yfrac [hi],  Carry)
                        IF
                          Carry <> 0                 --inc exponent
                            SEQ
                              Xexp := Xexp + 1       -- Overflow deals with itself
                              Carry,  Guard := SHIFTRIGHT ( Xfrac [lo],  Guard,  1)
                      
                              Xfrac [hi],  Xfrac [lo] := SHIFTRIGHT ( Xfrac [hi],  Xfrac [lo], 1)
                          Xexp = 1              --check normalisation
                            IF
                              (Xfrac [hi] /\ Sign) = 0
                                Xexp := 0       --still denormalised
                              TRUE
                                SKIP            --not denormalised
                          TRUE
                            SKIP
                      --}}}
                    TRUE
                      --{{{  sub magnitudes
                      SEQ
                        Carry,  Guard := LONGDIFF ( 0,  Guard,  0)
                        Places,  Ans [lo] := LONGDIFF ( Xfrac [lo],  Yfrac [lo],  Carry)
                        Places,  Ans [hi] := LONGDIFF ( Xfrac [hi],  Yfrac [hi],  Places)
                        -- Answer may have sign of either X or Y
                        -- dependant on their magnitudes
                        --{{{  Has sign change occured ?
                        IF
                          Places = 0                   --correct
                            SEQ
                              Xfrac [hi] := Ans [hi]
                              Xfrac [lo] := Ans [lo]
                              Ans [hi] := X [hi] /\ Sign -- Positive
                          TRUE                         --must negate
                            SEQ
                              Ans [hi] := Y [hi] /\ Sign --flip sign of answer
                              -- if sign is flipped we know they were almost aligned
                              -- so no borrow involved
                              Carry,  Xfrac [lo] := LONGDIFF ( Yfrac [lo],  Xfrac [lo],  Carry)
                              Carry,  Xfrac [hi] := LONGDIFF ( Yfrac [hi],  Xfrac [hi],  Carry)
                        --}}}
                        IF
                          (Xfrac [hi] /\ Sign) <> 0     --normalised
                            SKIP
                          ((Xfrac [hi] \/ Xfrac [lo]) \/ Guard) = 0--result is zero
                            IF
                              RoundMode = RM
                                SEQ
                                  Xexp := 0        -- -0
                                  Ans [hi] := Sign
                              TRUE
                                SEQ
                                  Xexp := 0        -- +0
                                  Ans [hi] := 0
                          Xexp > 1
                            --{{{  not yet denormalised
                            SEQ
                              Places,  Xfrac [hi],  Carry := NORMALISE ( Xfrac [hi],  Xfrac [lo])
                            
                              Xexp := Xexp - Places
                              IF
                                Xexp > 0            --still normal
                                  Xfrac [lo],  Guard := SHIFTLEFT ( Xfrac [lo],  Guard,  Places)
                            
                                TRUE                --gone denormalised
                                  SEQ
                                    Xfrac [hi],  Carry := SHIFTRIGHT ( Xfrac [hi],  0,  1 - Xexp)
                            
                                    Xfrac [lo],  Guard := SHIFTLEFT ( Xfrac [lo],  Guard,  Places - (1 - Xexp))
                            
                                    Xexp := 0
                            --}}}
                          TRUE                     --already denormalised
                            Xexp := 0
                      --}}}
              --}}}
              --{{{  multiply or division
              TRUE                                 --is mul/div
                SEQ
                  Ans [hi] := (X [hi] >< Y [hi]) /\ Sign--get sign of answer
                  IF
                    --{{{  Mulitiply
                    Op = Mul                       --do multiply
                      SEQ
                        Xexp := (Xexp + Yexp) + (1 - DRealXcess)
                        Xfrac[hi], Xfrac[lo],  Guard := RealIMul ( Xfrac,  Yfrac)
                    --}}}
                    --{{{  Division
                    TRUE                           --do divide
                      SEQ
                        Xexp := (Xexp - Yexp) + DRealXcess
                        Xfrac [hi],  Xfrac [lo] := SHIFTRIGHT ( Xfrac [hi],  Xfrac [lo],  1)
                    
                        Guard := 0
                        Xfrac [hi],  Xfrac [lo],  Guard := RealIDiv (Xfrac [hi],  Xfrac [lo],  Guard,  Yfrac)
                        Carry := 0
                        Xfrac [lo],  Guard,  Carry := RealIDiv (Xfrac [lo],  Guard,  Carry,  Yfrac)
                        IF
                          Carry = 0
                            SKIP
                          TRUE                   --set sticky bits
                            Guard := Guard \/ 1
                    --}}}
                  --{{{  Normalise
                  Places,  Xfrac [hi],  Carry := NORMALISE ( Xfrac [hi],  Xfrac [lo])
                  IF
                    Places > BitsPerWord
                      Xfrac [hi] := Xfrac [hi] \/ (Guard >> ((2 * BitsPerWord) - Places))
                    TRUE
                      SKIP
                  Xfrac [lo],  Guard := SHIFTLEFT ( Xfrac [lo],  Guard,  Places)
                  Xexp := Xexp - Places
                  --}}}
                  --{{{  Correct after normalisation
                  IF
                    --{{{  Overflow
                    Xexp >= DRealExp                --overflow
                      Xexp := DRealExp
                    --}}}
                    --{{{  Correct range
                    Xexp > 0                       --correct range
                      SKIP
                    --}}}
                    --{{{  Denormalised to insignificance
                    Xexp < (-(DBitsInFrac - 1))
                      SEQ
                        Xfrac [lo] := 0
                        Xfrac [hi] := 0
                        Guard := 1      -- cannot actually be zero so set guard for rounding
                        Xexp := 0
                    --}}}
                    --{{{  Denormalised
                    TRUE                           --denormalised
                      SEQ
                        Places := (Xfrac [lo] /\ (DRealRBit \/ DRealXcess)) \/ Guard
                        IF
                          Xexp < (-(BitsPerWord - 2))
                            SEQ
                              Places := Places \/ Xfrac [lo] -- Bug fix 42
                              Xfrac [lo],  Guard := SHIFTRIGHT ( Xfrac [hi],  Xfrac [lo], (-Xexp) - (BitsPerWord - 1))
                              Xfrac [hi] := 0
                          TRUE
                            SEQ
                              Carry,  Guard := SHIFTRIGHT ( Xfrac [lo],  Guard,  1 - Xexp)
                              Xfrac [hi],  Xfrac [lo] := SHIFTRIGHT ( Xfrac [hi],  Xfrac [lo], 1 - Xexp)
                        Xexp := 0
                        Guard := Guard \/ Places
                    --}}}
                  --}}}
              --}}}
            --{{{  round & pack result
            IF
              Xexp < DRealExp                      --still in range
                SEQ
                  Places := Xfrac [lo]             --save round bits
                  Xfrac [hi],  Xfrac [lo] := SHIFTRIGHT ( Xfrac [hi] /\ (~Sign), Xfrac [lo],  DRealShift)
                  Carry,  Xexp := SHIFTRIGHT ( Xexp,  0,  DRealShift + 1)
                  Xfrac [hi] := Xfrac [hi] \/ Xexp
                  IF
                    RoundMode = RN
                      --{{{  round as before
                      IF
                        (Places /\ DRealRBit) = 0      --round bit not set
                          SKIP
                        ((Guard \/ (Places /\ DRealXcess)) \/ (Xfrac [lo] /\ 1)) = 0--round down
                          SKIP
                        TRUE                           --round up/even
                          SEQ
                            -- Overflow deals with itself
                            Carry,  Xfrac [lo] := LONGSUM ( Xfrac [lo],  1,  0)
                            Carry,  Xfrac [hi] := LONGSUM ( Xfrac [hi],  0,  Carry)
                      --}}}
                    TRUE
                      --{{{  round as mode
                      IF
                        ((RoundMode = RM) AND (Ans [hi] = 0)) OR
                          (((RoundMode = RP) AND (Ans [hi] <> 0)) OR
                            (RoundMode = RZ))  -- RM and +ve, RP and -ve, RZ
                          SKIP -- truncate
                        ((Places /\ DRealExp) \/ Guard) = 0
                          SKIP  -- no round up
                        TRUE
                          SEQ
                            Carry,  Xfrac [lo] := LONGSUM ( Xfrac [lo],  1,  0)
                            Carry,  Xfrac [hi] := LONGSUM ( Xfrac [hi],  0,  Carry)
                      --}}}
                  Error := (Xfrac [hi] = DRealInf)   -- Overflow
                  Result [hi] := Ans [hi] \/ Xfrac [hi]
                  Result [lo] := Xfrac [lo]
              -- RM and unrounded +inf , RP and unrounded -inf, RZ and unrounded  inf
              ((RoundMode = RM) AND (Ans [hi] = 0)) OR
                (((RoundMode = RP) AND (Ans [hi] <> 0)) OR
                  (RoundMode = RZ))
                SEQ
                  Result [hi] := Ans [hi] \/ DBiggestFinite.hi
                  Result [lo] := DBiggestFinite.lo
                  Error := TRUE  -- Overflow
              TRUE                                 --OVERFLOW to infinity
                SEQ
                  Result [hi] := Ans [hi] \/ DRealInf
                  Result [lo] := 0
                  Error := TRUE  -- Overflow
            --}}}
          --}}}
      --}}}
    RESULT Error, Result
:
--}}}

#ENDIF


#IF (TARGET.BITS.PER.WORD = 16)

--{{{  #OPTION and #COMMENT
#OPTION "E V"  -- no compiler libs, no vector space
#COMMENT "T2 compiler library, V1.2 06/04/90"
#COMMENT "(c) Copyright INMOS Limited 1988"
--}}}

--{{{  #PRAGMA TRANSLATE
#PRAGMA TRANSLATE IEEE64OP "IEEE64OP%O"
--}}}

#INCLUDE "realvals.inc"

--{{{  IEEE64OP   -- T2
BOOL, REAL64 FUNCTION IEEE64OP (VAL REAL64 X, VAL INT RoundMode, Op,
                                VAL REAL64 Yp)

  -- Beta-3 (11may87)  Function version (10 Jun 87)
  -- Range check added for halt version 16-sep-87
  -- flagged

  REAL64 Result :
  BOOL Error :
  VALOF
    #INCLUDE "nan16.inc"
    --{{{  IEEE Quad length constants for 16 bit implementation
    VAL DRealExpSh  IS     4 :
    VAL DRealInf    IS #7FF0 :
    VAL BiggestFinite IS [#FFFF, #FFFF, #FFFF, #7FEF] :
    --}}}
    --{{{  #USE "occamutl.lib"
    #PRAGMA TRANSLATE QRealIMul "QRealIMul%CHK"
    #PRAGMA TRANSLATE QRealIDiv "QRealIDiv%CHK"
    #PRAGMA TRANSLATE QUADNORMALISE "QUADNORMALISE%CHK"
    #PRAGMA TRANSLATE QUADSHIFTLEFT "QUADSHIFTLEFT%CHK"
    #PRAGMA TRANSLATE QUADSHIFTRIGHT "QUADSHIFTRIGHT%CHK"
    #USE "occamutl.lib"  --  6-Apr-90
    --}}}

    [4]INT Result RETYPES Result :
    VAL [4]INT X RETYPES X :
    VAL [4]INT Yp RETYPES Yp :
    [4] INT Y :
    PLACE Y IN WORKSPACE :
    [4] INT Ans :
    PLACE Ans IN WORKSPACE :
    INT Xexp :
    [4] INT Xfrac :
    PLACE Xfrac IN WORKSPACE :
    INT Yexp :
    [4] INT Yfrac :
    PLACE Yfrac IN WORKSPACE :
    INT Carry, Guard, Guard2, Places :
    VAL INT Sign IS SignBit :
    SEQ
      --{{{  range check
      IF
        ((Op < 0) OR (Op > 3)) OR ((RoundMode < 0) OR (RoundMode > 3))
          CAUSEERROR()
        TRUE
          SKIP
      --}}}
      --{{{  Unpack operands
      --{{{  Separate mantissa and exponents
      IF
        Op = Sub              --get minus Y
          Y[3] := Yp[3] >< Sign
        TRUE                  --use plus Y
          Y[3] := Yp[3]
      Y[0] := Yp[0]
      Y[1] := Yp[1]
      Y[2] := Yp[2]
      
      Xfrac[3],  Carry := SHIFTLEFT ( X[3],  X[2],  DRealShift)
      Xfrac[2],  Carry := SHIFTLEFT ( X[2],  X[1],  DRealShift)
      Xfrac[1],  Xfrac[0] := SHIFTLEFT ( X[1],  X[0],  DRealShift)
      Yfrac[3],  Carry := SHIFTLEFT ( Y[3],  Y[2],  DRealShift)
      Yfrac[2],  Carry := SHIFTLEFT ( Y[2],  Y[1],  DRealShift)
      Yfrac[1],  Yfrac[0] := SHIFTLEFT ( Y[1],  Y[0],  DRealShift)
      
      Xexp := (X[3] >> DRealExpSh) /\ DRealExp
      Yexp := (Y[3] >> DRealExpSh) /\ DRealExp
      --}}}
      
      Ans[0] := 0
      Ans[1] := 0
      Ans[2] := 0
      Carry := 0                          --assume not normal case
      Error := FALSE                      --assume no error
      IF
        (Xexp <> DRealExp) AND (Yexp <> DRealExp)
          --{{{  zeros or real nos
          IF
            (Xexp <> 0) AND (Yexp <> 0)
              --{{{  both normal nos
              SEQ                                  --normal case
                Carry := 1
                Xfrac[3] := Xfrac[3] \/ Sign
                Yfrac[3] := Yfrac[3] \/ Sign
              --}}}
            ((((Xexp \/ Xfrac[3]) \/ Xfrac[2]) \/ Xfrac[1]) \/ Xfrac[0]) = 0
              --{{{  X is zero
              IF
                ((((Yexp \/ Yfrac[3]) \/ Yfrac[2]) \/ Yfrac[1]) \/ Yfrac[0]) = 0--both zero
                  IF
                    Op < Mul                       --add/sub
                      IF
                        RoundMode = RM
                          Ans [3] := X [3] \/ Y [3]
                        TRUE
                          Ans [3] := X [3] /\ Y [3]
                    Op = Mul
                      Ans[3] := X[3] >< Y[3]       --signed zero
                    TRUE                           --div/rem
                      SEQ
                        Ans := ZeroZeroDivNaN.64
                        Error := TRUE
                Op < Mul                           --result is Y
                  Ans := Y
                TRUE                               --mul or div
                  Ans[3] := (X[3] >< Y[3]) /\ Sign --zero
              --}}}
            ((((Yexp \/ Yfrac[3]) \/ Yfrac[2]) \/ Yfrac[1]) \/ Yfrac[0]) = 0
              --{{{  Y is zero
              IF
                Op < Mul                           --add/sub
                  Ans := X
                Op = Mul
                  Ans[3] := (X[3] >< Y[3]) /\ Sign --zero
                TRUE                               --div by zero
                  SEQ
                    Ans[3] := ((X[3] >< Y[3]) /\ Sign) \/ DRealInf--infinity
                    Error := TRUE
              --}}}
            TRUE
              --{{{  one or both are denormalised
              -- Put in implicit MSB
              -- Normalise any denormaliseds and correct their exponents if op is
              -- multiply, divide or rem leave unormal for add and sub
              SEQ
                Carry := 1                         --work to do
                IF
                  Xexp <> 0                        --set leading bit
                    Xfrac[3] := Xfrac[3] \/ Sign
                  TRUE                             --set correct exponent
                    IF
                      Op > Sub
                        [4]INT temp.Xfrac :
                        SEQ
                          temp.Xfrac := Xfrac
                          QUADNORMALISE (Places, Xfrac, Guard, temp.Xfrac, 0)
                          Xexp := 1 - Places
                      TRUE
                        Xexp := 1
                IF
                  Yexp <> 0
                    Yfrac[3] := Yfrac[3] \/ Sign
                  TRUE
                    IF
                      Op > Sub
                        [4]INT temp.Yfrac :
                        SEQ
                          temp.Yfrac := Yfrac
                          QUADNORMALISE (Places, Yfrac, Guard, temp.Yfrac, 0)
                          Yexp := 1 - Places
                      TRUE
                        Yexp := 1
              --}}}
          --}}}
        TRUE
          --{{{  one or other inf/NaN
          SEQ
            Xfrac[3] := Xfrac[3] /\ (~Sign)        --clear top bits
            Yfrac[3] := Yfrac[3] /\ (~Sign)
            Error := TRUE
            IF
              (Xexp = DRealExp) AND (Yexp = DRealExp)
                --{{{  both inf/NaN
                IF
                  ((((Xfrac[3]\/Xfrac[2])\/Xfrac[1])\/Xfrac[0]) \/
                   (((Yfrac[3]\/Yfrac[2])\/Yfrac[1])\/Yfrac[0])) <> 0
                    SEQ
                      Guard, Places := LONGDIFF (Xfrac[0], Yfrac[0], 0)
                      Guard, Places := LONGDIFF (Xfrac[1], Yfrac[1], Guard)
                      Guard, Places := LONGDIFF (Xfrac[2], Yfrac[2], Guard)
                      Guard, Places := LONGDIFF (Xfrac[3], Yfrac[3], Guard)
                      IF
                        Places < 0
                          Ans := Y
                        TRUE
                          Ans := X
                      IF
                        Op < Mul
                          SKIP
                        TRUE
                          Ans [3] := (Ans [3] /\ (~Sign)) \/ ((X [3] >< Y [3]) /\ Sign)
                  (Op < Mul) AND (((X[3]><Y[3])/\Sign) = 0)  --add/sub same inf
                    Ans[3] := X[3]
                  Op = Mul
                    Ans[3] := ((X[3]><Y[3])/\Sign) \/ DRealInf      --infinity
                  TRUE                             --add/sub/div/rem
                    IF
                      Op = Div
                        Ans := InfInfDivNaN.64
                      TRUE
                        Ans := AddSubInfInfNaN.64
                --}}}
              Xexp = DRealExp
                --{{{  X is inf/NaN
                IF
                  (Op < Mul)                      --add sub inf nan
                    SEQ
                      Ans[3] := X[3]
                      Ans[2] := X[2]
                      Ans[1] := X[1]
                      Ans[0] := X[0]
                  ((((Xfrac[3] \/ Xfrac[2]) \/ Xfrac[1]) \/ Xfrac[0]) <> 0) -- mul div nan
                    SEQ
                      Ans [3] := X [3] >< (Y [3] /\ Sign)
                      Ans [2] := X [2]
                      Ans [1] := X [1]
                      Ans [0] := X [0]
                  Op = Mul
                    IF
                      ((((Yexp \/ Yfrac[3]) \/ Yfrac[2]) \/ Yfrac[1]) \/ Yfrac[0]) = 0--mul by zero
                        Ans := ZeroInfMulNaN.64
                      TRUE                        --inf times normal
                        Ans[3] := ((X[3] >< Y[3]) /\ Sign) \/ DRealInf--infinity
                  TRUE                            --div
                    Ans[3] := ((X[3] >< Y[3]) /\ Sign) \/ DRealInf  --infinity
                --}}}
              (((Yfrac[3] \/ Yfrac[2]) \/ Yfrac[1]) \/ Yfrac[0]) <> 0
                --{{{  Y is NaN
                IF
                  Op < Mul
                    Ans := Y                --keep NaN
                  TRUE
                    SEQ
                      Ans[3] := Y[3] >< (X [3] /\ Sign)
                      Ans[2] := Y[2]
                      Ans[1] := Y[1]
                      Ans[0] := Y[0]
                --}}}
              TRUE
                --{{{  Y is inf
                IF
                  Op < Mul                        --add/sub
                    SEQ
                      Ans[3] := Y[3]
                      Ans[2] := Y[2]
                      Ans[1] := Y[1]
                      Ans[0] := Y[0]
                  Op = Mul
                    IF
                      ((((Xexp \/ Xfrac[3]) \/ Xfrac[2]) \/ Xfrac[1]) \/ Xfrac[0]) = 0--mul by zero
                        Ans := ZeroInfMulNaN.64
                      TRUE                        --inf times normal
                        Ans[3] := ((X[3] >< Y[3]) /\ Sign) \/ DRealInf--infinity
                  TRUE                            --div
                    Ans[3] := (X[3] >< Y[3]) /\ Sign
                --}}}
          --}}}
      --}}}
      --{{{  evaluate
      IF
        Carry = 0
          --{{{  Answer is set up
          Result := Ans
          --}}}
        TRUE
          --{{{  Do an operation
          SEQ
            IF
              --{{{  add or subtract
              Op < Mul                          --add/sub to do
                SEQ
                  Places := Xexp - Yexp
                  --{{{  Align Mantissas
                  SEQ
                    Guard := 0
                    IF
                      Places = 0
                        SKIP                -- correctly aligned
                      Places > 0
                        --{{{  shift Y
                        IF
                          Places > (DBitsInFrac + 1)
                            --{{{  Total loss of significance
                            SEQ
                              Yfrac[3] := 0
                              Yfrac[2] := 0
                              Yfrac[1] := 0
                              Yfrac[0] := 0
                              Guard := 1     -- wasn't 0
                            --}}}
                          TRUE
                            --{{{  Do Shift
                            SEQ
                              IF
                                Places >= (3 * BitsPerWord)
                                  --{{{  Shift 3 words
                                  SEQ
                                    Guard := (Yfrac[2] \/ Yfrac[1]) \/ Yfrac[0]
                                    Yfrac[0] := Yfrac[3]
                                    Yfrac[1] := 0
                                    Yfrac[2] := 0
                                    Yfrac[3] := 0
                                  --}}}
                                Places >= (2 * BitsPerWord)
                                  --{{{  Shift 2 words
                                  SEQ
                                    Guard := Yfrac[1] \/ Yfrac[0]
                                    Yfrac[0] := Yfrac[2]
                                    Yfrac[1] := Yfrac[3]
                                    Yfrac[2] := 0
                                    Yfrac[3] := 0
                                  --}}}
                                Places >= BitsPerWord
                                  --{{{  Shift 1 word
                                  SEQ
                                    Guard := Yfrac[0]
                                    Yfrac[0] := Yfrac[1]
                                    Yfrac[1] := Yfrac[2]
                                    Yfrac[2] := Yfrac[3]
                                    Yfrac[3] := 0
                                  --}}}
                                TRUE
                                  SKIP
                              --{{{  Shift remaining bits
                              Places := Places /\ (BitsPerWord - 1)          -- take remainder
                              Yexp,  Carry := SHIFTRIGHT ( Yfrac[0],  0,  Places)
                              Guard := Guard \/ Carry
                              Carry,  Yfrac[0] := SHIFTRIGHT ( Yfrac[1],  Yfrac[0],  Places)
                              Carry,  Yfrac[1] := SHIFTRIGHT ( Yfrac[2],  Yfrac[1],  Places)
                              Yfrac[3],  Yfrac[2] := SHIFTRIGHT ( Yfrac[3],  Yfrac[2],  Places)
                              --}}}
                            --}}}
                        --}}}
                      TRUE
                        --{{{  shift X
                        SEQ
                          Xexp := Yexp     -- Set to greater exponent
                          Places := -Places   --switch sign to +ve
                          IF
                            Places > (DBitsInFrac + 1)
                              --{{{  Total loss of significance
                              SEQ
                                Xfrac[3] := 0
                                Xfrac[2] := 0
                                Xfrac[1] := 0
                                Xfrac[0] := 0
                                Guard := 1    -- wasn't 0
                              --}}}
                            TRUE
                              --{{{  Do Shift
                              SEQ
                                IF
                                  Places >= (3 * BitsPerWord)
                                    --{{{  Shift 3 words
                                    SEQ
                                      Guard := (Xfrac[2] \/ Xfrac[1]) \/ Xfrac[0]
                                      Xfrac[0] := Xfrac[3]
                                      Xfrac[1] := 0
                                      Xfrac[2] := 0
                                      Xfrac[3] := 0
                                    --}}}
                                  Places >= (2 * BitsPerWord)
                                    --{{{  Shift 2 words
                                    SEQ
                                      Guard := Xfrac[1] \/ Xfrac[0]
                                      Xfrac[0] := Xfrac[2]
                                      Xfrac[1] := Xfrac[3]
                                      Xfrac[2] := 0
                                      Xfrac[3] := 0
                                    --}}}
                                  Places >= BitsPerWord
                                    --{{{  Shift 1 word
                                    SEQ
                                      Guard := Xfrac[0]
                                      Xfrac[0] := Xfrac[1]
                                      Xfrac[1] := Xfrac[2]
                                      Xfrac[2] := Xfrac[3]
                                      Xfrac[3] := 0
                                    --}}}
                                  TRUE
                                    SKIP
                                --{{{  Shift remaining bits
                                Places := Places /\ (BitsPerWord - 1)
                                Yexp,  Carry := SHIFTRIGHT ( Xfrac[0],  0,  Places)
                                Guard := Guard \/ Carry
                                Carry,  Xfrac[0] := SHIFTRIGHT ( Xfrac[1],  Xfrac[0],  Places)
                                Carry,  Xfrac[1] := SHIFTRIGHT ( Xfrac[2],  Xfrac[1],  Places)
                                Xfrac[3],  Xfrac[2] := SHIFTRIGHT ( Xfrac[3],  Xfrac[2],  Places)
                                --}}}
                              --}}}
                        --}}}
                  --}}}
                  IF
                    ((X[3] >< Y[3]) /\ Sign) = 0
                      --{{{  add magnitudes
                      SEQ
                        -- Answer is always same sign as X and Y
                        Ans[3] := X[3] /\ Sign
                        Carry,  Xfrac[0] := LONGSUM ( Xfrac[0],  Yfrac[0],  0)
                        Carry,  Xfrac[1] := LONGSUM ( Xfrac[1],  Yfrac[1],  Carry)
                        Carry,  Xfrac[2] := LONGSUM ( Xfrac[2],  Yfrac[2],  Carry)
                        Carry,  Xfrac[3] := LONGSUM ( Xfrac[3],  Yfrac[3],  Carry)
                        IF
                          Carry <> 0                 --inc exponent
                            SEQ
                              Xexp := Xexp + 1       -- Overflow deals with itself
                              Carry,  Yexp := SHIFTRIGHT ( Xfrac[0],  Guard,  1)
                              Guard := Guard \/ Yexp
                              Carry,  Xfrac[0] := SHIFTRIGHT ( Xfrac[1],  Xfrac[0],  1)
                              Carry,  Xfrac[1] := SHIFTRIGHT ( Xfrac[2],  Xfrac[1],  1)
                              Xfrac[3],  Xfrac[2] := SHIFTRIGHT ( Xfrac[3],  Xfrac[2],  1)
                          Xexp = 1              --check normalisation
                            IF
                              (Xfrac[3] /\ Sign) = 0
                                Xexp := 0       --still denormalised
                              TRUE
                                SKIP            --not denormalised
                          TRUE
                            SKIP
                      --}}}
                    TRUE
                      --{{{  sub magnitudes
                      SEQ
                        Carry,  Guard := LONGDIFF ( 0,  Guard,  0)
                        Places,  Ans[0] := LONGDIFF ( Xfrac[0],  Yfrac[0],  Carry)
                        Places,  Ans[1] := LONGDIFF ( Xfrac[1],  Yfrac[1],  Places)
                        Places,  Ans[2] := LONGDIFF ( Xfrac[2],  Yfrac[2],  Places)
                        Places,  Ans[3] := LONGDIFF ( Xfrac[3],  Yfrac[3],  Places)
                        -- Answer may have sign of either X or Y
                        -- dependant on their magnitudes
                        --{{{  Has sign change occured ?
                        IF
                          Places = 0                   --correct
                            SEQ
                              Xfrac[3] := Ans[3]
                              Xfrac[2] := Ans[2]
                              Xfrac[1] := Ans[1]
                              Xfrac[0] := Ans[0]
                              Ans[3] := X[3] /\ Sign   -- Positive
                          TRUE                         --must negate
                            SEQ
                              Ans[3] := Y[3] /\ Sign   --flip sign of answer
                              -- if sign is flipped we know they were almost aligned
                              -- so no borrow involved
                              Carry,  Xfrac[0] := LONGDIFF ( Yfrac[0],  Xfrac[0],  Carry)
                              Carry,  Xfrac[1] := LONGDIFF ( Yfrac[1],  Xfrac[1],  Carry)
                              Carry,  Xfrac[2] := LONGDIFF ( Yfrac[2],  Xfrac[2],  Carry)
                              Carry,  Xfrac[3] := LONGDIFF ( Yfrac[3],  Xfrac[3],  Carry)
                        --}}}
                        IF
                          (Xfrac[3] /\ Sign) <> 0      --normalised
                            SEQ
                          ((((Xfrac[3] \/ Xfrac[2]) \/ Xfrac[1]) \/ Xfrac[0]) \/ Guard) = 0--result is zero
                            IF
                              RoundMode = RM
                                SEQ
                                  Xexp := 0
                                  Ans [3] := Sign -- -0
                              TRUE
                                SEQ
                                  Xexp := 0
                                  Ans [3] := 0    -- 0
                          Xexp > 1
                            --{{{  not yet denormalised
                            SEQ
                              IF
                                (Xfrac[3] \/ Xfrac[2]) <> 0
                                  Places,  Yexp,  Carry := NORMALISE ( Xfrac[3],  Xfrac[2])
                                TRUE
                                  SEQ
                                    Places,  Yexp,  Carry := NORMALISE ( Xfrac[1],  Xfrac[0])
                                    Places := Places + (2 * BitsPerWord)
                              Xexp := Xexp - Places
                            
                              [4]INT temp.Xfrac :
                              INT    temp.Guard :
                              SEQ
                                temp.Xfrac := Xfrac
                                temp.Guard := Guard
                                IF
                                  Xexp > 0            --still normal
                                    QUADSHIFTLEFT (Xfrac, Guard, temp.Xfrac, temp.Guard, Places)
                                  TRUE                --gone denormalised
                                    SEQ
                                      QUADSHIFTLEFT (Xfrac, Guard, temp.Xfrac, temp.Guard,
                                                     Places - (1 - Xexp))
                                      Xexp := 0
                            --}}}
                          TRUE                     --already denormalised
                            Xexp := 0
                      --}}}
              --}}}
              --{{{  multiply or division
              TRUE                                 --is mul/div
                SEQ
                  Ans[3] := (X[3] >< Y[3]) /\ Sign --get sign of answer
                  IF
                    --{{{  Mulitiply
                    Op = Mul                       --do multiply
                      SEQ
                        Xexp := (Xexp + Yexp) + (1 - DRealXcess)
                        QRealIMul (Xfrac, Guard, Yfrac[3], Yfrac[2],
                               Yfrac[1], Yfrac[0])
                    --}}}
                    --{{{  Division
                    TRUE                           --do divide
                      SEQ
                        -- Now always normalised
                        Xexp := (Xexp - Yexp) + DRealXcess
                        Carry,  Xfrac[0] := SHIFTRIGHT ( Xfrac[1],  Xfrac[0],  1)
                        Carry,  Xfrac[1] := SHIFTRIGHT ( Xfrac[2],  Xfrac[1],  1)
                        Xfrac[3],  Xfrac[2] := SHIFTRIGHT ( Xfrac[3],  Xfrac[2],  1)
                        Xfrac[3],  Xfrac[2],  Xfrac[1],  Xfrac[0],  Guard := QRealIDiv (Xfrac[3],  Xfrac[2],  Xfrac[1],  Xfrac[0],  0,  Yfrac)
                        Xfrac[2],  Xfrac[1],  Xfrac[0],  Guard,  Guard2 := QRealIDiv (Xfrac[2],  Xfrac[1],  Xfrac[0],  Guard,  0,  Yfrac)
                        Xfrac[1],  Xfrac[0],  Guard,  Guard2,  Places := QRealIDiv (Xfrac[1],  Xfrac[0],  Guard,  Guard2,  0,  Yfrac)
                        Xfrac[0],  Guard,  Guard2,  Places,  Carry := QRealIDiv (Xfrac[0],  Guard,  Guard2,  Places,  0,  Yfrac)
                        IF
                          ((Guard2 \/ Places) \/ Carry) = 0
                            SKIP
                          TRUE                   --set sticky bits
                            Guard := Guard \/ 1
                    --}}}
                  --{{{  Normalise
                  IF
                    (Xfrac[3] \/ Xfrac[2]) <> 0
                      Places,  Yexp,  Carry := NORMALISE ( Xfrac[3],  Xfrac[2])
                    TRUE
                      SEQ
                        Places,  Yexp,  Carry := NORMALISE ( Xfrac[1],  Xfrac[0])
                        Places := Places + (2 * BitsPerWord)
                  
                  [4]INT temp.Xfrac :
                  INT    temp.Guard :
                  SEQ
                    temp.Xfrac := Xfrac
                    temp.Guard := Guard
                    QUADSHIFTLEFT (Xfrac, Guard, temp.Xfrac, temp.Guard, Places)
                  
                  Xexp := Xexp - Places
                  --}}}
                  --{{{  Postnormalise
                  IF
                    Xexp >= DRealExp                --overflow
                      Xexp := DRealExp
                    Xexp > 0                       --correct range
                      SKIP
                    Xexp < (-(DBitsInFrac - 1)) -- Whoops
                      SEQ
                        Xfrac[0] := 0
                        Xfrac[1] := 0
                        Xfrac[2] := 0
                        Xfrac[3] := 0
                        Guard := 1    -- not a 0 result
                        Xexp := 0
                    TRUE                           --denormalised
                      [4]INT temp.Xfrac :
                      INT    temp.Guard :
                      SEQ
                        temp.Xfrac := Xfrac
                        temp.Guard := Guard
                        --all bits being shifted out are gathered in Guard
                        QUADSHIFTRIGHT (Xfrac, Guard, temp.Xfrac, temp.Guard, 1 - Xexp)
                        Xexp := 0
                  --}}}
              --}}}
            --{{{  round & pack result
            IF
              Xexp < DRealExp                      --still in range
                SEQ
                  Places := Xfrac[0]              --save round bits
                  Carry,  Xfrac[0] := SHIFTRIGHT ( Xfrac[1],  Xfrac[0],  DRealShift)
                  Carry,  Xfrac[1] := SHIFTRIGHT ( Xfrac[2],  Xfrac[1],  DRealShift)
                  Xfrac[3],  Xfrac[2] := SHIFTRIGHT (Xfrac[3] /\ (~Sign),
                                                         Xfrac[2],  DRealShift)
                  Carry,  Xexp := SHIFTRIGHT ( Xexp,  0,  DRealShift + 1)
                  Xfrac[3] := Xfrac[3] \/ Xexp
                  IF
                    RoundMode = RN
                      --{{{  as before
                      IF
                        (Places /\ DRealRBit) = 0      --round bit not set
                          SKIP
                        ((Guard \/ (Places /\ DRealXcess)) \/ (Xfrac[0] /\ 1)) = 0--round down
                          SKIP
                        TRUE                           --round up/even
                          SEQ
                            -- Overflow deals with itself
                            Carry,  Xfrac[0] := LONGSUM ( Xfrac[0],  1,  0)
                            Carry,  Xfrac[1] := LONGSUM ( Xfrac[1],  0,  Carry)
                            Carry,  Xfrac[2] := LONGSUM ( Xfrac[2],  0,  Carry)
                            Carry,  Xfrac[3] := LONGSUM ( Xfrac[3],  0,  Carry)
                      --}}}
                    ((RoundMode = RM) AND (Ans [3] = 0)) OR
                      (((RoundMode = RP) AND (Ans [3] <> 0)) OR
                        (RoundMode = RZ))
                      SKIP -- truncate
                    TRUE
                      IF
                        ((Places /\ DRealExp) \/ Guard) = 0
                          SKIP  -- no round up
                        TRUE
                          SEQ
                            Carry,  Xfrac [0] := LONGSUM ( Xfrac [0],  1,  0)
                            Carry,  Xfrac [1] := LONGSUM ( Xfrac [1],  0,  Carry)
                            Carry,  Xfrac [2] := LONGSUM ( Xfrac [2],  0,  Carry)
                            Carry,  Xfrac [3] := LONGSUM ( Xfrac [3],  0,  Carry)
                  Error := (Xfrac [3] = DRealInf) -- Overflow
                  Result[3] := Ans[3] \/ Xfrac[3]
                  Result[2] := Xfrac[2]
                  Result[1] := Xfrac[1]
                  Result[0] := Xfrac[0]
              ((RoundMode = RM) AND (Ans [3] = 0)) OR
                (((RoundMode = RP) AND (Ans [3] <> 0)) OR
                  (RoundMode = RZ))
                SEQ
                  Result [3] := Ans [3] \/ BiggestFinite [3]
                  Result [2] := BiggestFinite [2]
                  Result [1] := BiggestFinite [1]
                  Result [0] := BiggestFinite [0]
                  Error := TRUE -- Overflow
              TRUE                                 --OVERFLOW to infinity
                SEQ
                  Result[3] := Ans[3] \/ DRealInf
                  Result[2] := 0
                  Result[1] := 0
                  Result[0] := 0
                  Error := TRUE -- Overflow
            --}}}
          --}}}
      --}}}
    RESULT Error, Result
:
--}}}

#ENDIF
