--
--	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
--

#IF (TARGET.BITS.PER.WORD = 32) AND (NOT DEFINED(TARGET.HAS.FPU))

--{{{  #options and #comments
#OPTION "E V"  -- no compiler libs, no vector space
#COMMENT "TA compiler library, V1.5 07/12/92"
#COMMENT "(c) Copyright INMOS Limited 1988"
--}}}

--{{{  #PRAGMA TRANSLATE
#PRAGMA TRANSLATE REAL32REMERR "REAL32REMERR%CHK"
--}}}

#INCLUDE "realvals.inc"

--{{{  
REAL32 FUNCTION REAL32REMERR (VAL REAL32 X, Y)

  --{{{  specification
  -- Purpose:  To calculate IEEE definition of X REM Y, but using occam
  --           error rules.
  -- Returned: X REM Y
  -- In:       X - numerator
  -- In:       Y - denominator
  -- Notes:    For the definition of REM see ANSI/IEEE 754-1985, Section 5.1:
  --           "When Y <> 0, the remainder R = X REM Y is defined regardless
  --           of the rounding mode by the mathematical relation R = X - Y * N,
  --           where N is the integer nearest the exact value X/Y; whenever
  --           | N - X/Y | = 0.5, then N is even.  Thus, the remainder is always
  --           exact.  If R = 0, its sign shall be that of X."
  --           The relation R = X - ( Y * nearest integer( X/Y ) ) shows that
  --           the sign of Y cannot affect R.
  --           An error occurs if, 
  --             (i)    Y is zero
  --             (ii)   at least one of X or Y is an infinity or a NaN
  --}}}
  --{{{  history
  -- Beta-3 (7may87)
  -- HALT V1.1 21-Feb-89; STOP V1.2 24-Feb-89; UNDEFINED V1.1 21-Feb-89.
  -- Cleaned up parts of the code ( eg lonesome SEQs -> SKIPs ) and
  -- merged all error modes; V1.3 7-Apr-90 SRH
  -- Changed the name of some variables to make the code clearer by avoiding
  -- multiple use of the same variable for different meanings; also added
  -- in extra comments. V1.4 26-Oct-90 SRH
  -- Moved position of CAUSEERRORs to the beginning of branches to allow
  -- compiler to do dead code elimination; V1.5, 7-Dec-92 SRH
  --}}}

  REAL32 Result:
  VALOF
    #INCLUDE "nan32.inc"
    INT Result RETYPES Result :
    VAL INT X RETYPES X :
    VAL INT Y RETYPES Y :
    --{{{  variables
    INT Xexp, Xfrac, Yexp, Yfrac, Shift, Guard, Places, Ans, Borrow, dummy :
    BOOL special.case :
    VAL INT Sign IS SignBit :
    --}}}
    SEQ
      --{{{  unpack operands
      --{{{  unpack operands
      Xexp,  Xfrac := SHIFTLEFT ( 0,  X << 1,  RealShift)
      Xfrac := Xfrac >> 1                 --room for leading bit
      Yexp,  Yfrac := SHIFTLEFT ( 0,  Y << 1,  RealShift)
      Yfrac := Yfrac >> 1                 --room for leading bit
      --}}}
      --{{{  determine special cases
      special.case := TRUE                --assume not normal case
      IF
        (Xexp <> RealExp) AND (Yexp <> RealExp)  --normal or zeros
          --{{{  
          IF
            (Xexp <> 0) AND (Yexp <> 0)   --normal case
              --{{{  
              SEQ
                special.case := FALSE
                Xfrac := Xfrac \/ Sign
                Yfrac := Yfrac \/ Sign
              --}}}
            (Yexp \/ Yfrac) = 0           --Y is zero
              --{{{  
              SEQ
                CAUSEERROR()
                Ans := RemZeroNaN.32
              --}}}
            (Xexp \/ Xfrac) = 0           --X is zero
              --{{{  
              Ans := X
              --}}}
            TRUE                          --one or other denormalised
              --{{{  
              SEQ
                special.case := FALSE     --work to do
                IF
                  Xexp <> 0               --set leading bit
                    Xfrac := Xfrac \/ Sign
                  TRUE                    --set correct exponent
                    Xexp := 1
                IF
                  Yexp <> 0               --set leading bit
                    Yfrac := Yfrac \/ Sign
                  TRUE                    --set correct exponent
                    Yexp := 1
              --}}}
          --}}}
        TRUE                              --at least one is inf/NaN
          SEQ
            CAUSEERROR()
            IF
              (Xexp = RealExp) AND (Yexp = RealExp)  --both NaN or inf
                --{{{  
                IF
                  (Xfrac \/ Yfrac) = 0    --both inf
                    Ans := RemInfNaN.32
                  Yfrac > Xfrac           --one a NaN so return larger one
                    Ans := Y
                  TRUE
                    Ans := X
                --}}}
              Xexp = RealExp              --X infinity/NaN
                --{{{  
                IF
                  Xfrac <> 0              --X is NaN
                    Ans := X
                  TRUE                    --rem
                    Ans := RemInfNaN.32
                --}}}
              Yfrac <> 0                  --Y is NaN
                --{{{  
                Ans := Y                  --keep NaN
                --}}}
              TRUE                        --Y infinity
                --{{{  
                Ans := X
                --}}}
      --}}}
      --}}}
      --{{{  evaluate
      IF
        special.case                      --answer set up
          --{{{  
          Result := Ans
          --}}}
        TRUE
          SEQ
            --{{{  calculate remainder
            IF
              Yexp = 1                    --possible denorm RHS
                SEQ                       --normalise RHS
                  Places,  Yfrac,  dummy := NORMALISE ( Yfrac,  0)
                  Yexp := Yexp - Places   --ensure LHS normal too
                  Places,  Xfrac,  dummy := NORMALISE ( Xfrac,  0)
                  Xexp := Xexp - Places
              TRUE
                SKIP
            Ans := X /\ Sign              --note sign of X
            Places := Xexp - Yexp
            IF
              Places >= 0                 --general case
                SEQ
                  Shift := BitsPerWord - (Places /\ (BitsPerWord - 1))
                  Xfrac,  Guard := SHIFTRIGHT ( Xfrac,  0,  Shift)
                  Guard,  Xfrac := LONGDIV ( Xfrac,  Guard,  Yfrac)
                  WHILE Places >= BitsPerWord
                    SEQ
                      Guard,  Xfrac := LONGDIV ( Xfrac,  0,  Yfrac)
                      Places := Places - BitsPerWord
                  IF
                    Xfrac = 0             --divides exactly, i.e. X = Y => answer is zero
                      Xexp := 0
                    TRUE
                      SEQ                 --see if over half
                        Borrow,  Xexp := LONGDIFF ( Yfrac >> 1,  Xfrac,  0)
                        IF
                          (Borrow <> 0) OR ((Xexp = 0) AND ((Guard /\ 1) <> 0))--round up
                            SEQ
                              Ans := Ans >< Sign --negate answer
                              Xfrac := Yfrac MINUS Xfrac
                          TRUE
                            SKIP
                        Xexp := Yexp
              Places = (-1)               --get ans by compare
                SEQ
                  Borrow,  Guard := LONGDIFF ( Yfrac,  Xfrac,  0)
                  IF
                    Borrow = 0            --X is answer
                      SKIP
                    TRUE                  --Y - X is answer
                      SEQ
                        Ans := Ans >< Sign--invert sign
                        Xfrac := Yfrac MINUS (Xfrac >> 1)
                        Xexp := Yexp
              TRUE                        --always X
                SKIP
            Places,  Xfrac,  dummy := NORMALISE ( Xfrac,  0)
            Xexp := Xexp - Places
            IF
              Xexp <= 0                   --gone denorm
                SEQ
                  Xfrac,  Guard := SHIFTRIGHT ( Xfrac,  0,  1 - Xexp)
                  Xexp := 0
              TRUE
                SKIP
            --}}}
            --{{{  pack result
            dummy,  Xfrac := SHIFTRIGHT ( Xexp,  Xfrac << 1,  RealShift + 1)
            Result := Ans \/ Xfrac
            --}}}
      --}}}
    RESULT Result
:
--}}}

#ENDIF


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

--{{{  #options and #comments
#OPTION "E V"  -- no compiler libs, no vector space
#COMMENT "T2 compiler library, V1.3 07/12/92"
#COMMENT "(c) Copyright INMOS Limited 1988"
--}}}  

--{{{  #PRAGMA TRANSLATE
#PRAGMA TRANSLATE REAL32REMERR "REAL32REMERR%CHK"
--}}}  

#INCLUDE "realvals.inc"

--{{{  
REAL32 FUNCTION REAL32REMERR (VAL REAL32 X, Y)

  --{{{  history
  -- Beta-3 (11may87)  Function version (10 Jun 87)
  -- V1.1 21-Feb-89
  -- Cleaned up parts of the code ( eg lonesome SEQs -> SKIPs ) and
  -- merged all error modes; V1.2 7-Apr-90 SRH
  -- Moved position of CAUSEERRORs to the beginning of branches to allow
  -- compiler to do dead code elimination; V1.3, 7-Dec-92 SRH
  --}}}  

  REAL32 Result :
  VALOF
    #INCLUDE "nan16.inc"
    --{{{  #USE "occamutl.lib"
    #PRAGMA TRANSLATE RealIDiv "RealIDiv%CHK"
    #USE "occamutl.lib"  --  6-Apr-90
    --}}}  
    --{{{  IEEE Single length constants for 16 bit implementation
    VAL RealExpSh  IS     7 :
    --VAL BiggestFinite IS [#FFFF, #7F7F] :
    --}}}  
    [2]INT Result RETYPES Result :
    VAL [2]INT X RETYPES X :
    VAL [2]INT Y RETYPES Y :
    INT Xexp :
    [2] INT Xfrac :
    PLACE Xfrac IN WORKSPACE :
    INT Yexp :
    [2] INT Yfrac :
    PLACE Yfrac IN WORKSPACE :
    INT Carry, Guard, Places :
    [2] INT Ans :
    PLACE Ans IN WORKSPACE :
    VAL INT Sign IS SignBit:
    SEQ
      --{{{  Unpack operands
      --{{{  Separate mantissa and exponents

      Xfrac[1],  Xfrac[0] := SHIFTLEFT ( X[1],  X[0],  RealShift)
      Yfrac[1],  Yfrac[0] := SHIFTLEFT ( Y[1],  Y[0],  RealShift)

      Xexp := (X[1] >> RealExpSh) /\ RealExp
      Yexp := (Y[1] >> RealExpSh) /\ RealExp
      --}}}  

      Ans[0] := 0
      Carry := 0                          --assume not normal case
      IF
        (Xexp <> RealExp) AND (Yexp <> RealExp)
          --{{{  zeros or real nos
          IF
            (Xexp <> 0) AND (Yexp <> 0)
              --{{{  both normal nos
              SEQ                                  --normal case
                Carry := 1
                Xfrac[1] := Xfrac[1] \/ Sign
                Yfrac[1] := Yfrac[1] \/ Sign
              --}}}  
            ((Yexp \/ Yfrac[1]) \/ Yfrac[0]) = 0
              --{{{  Y is zero
              SEQ
                CAUSEERROR()
                --Ans := RemZeroNaN.32
              --}}}  
            ((Xexp \/ Xfrac[1]) \/ Xfrac[0]) = 0
              --{{{  X is zero
              Ans := X
              --}}}  
            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[1] := Xfrac[1] \/ Sign
                  TRUE                             --set correct exponent
                    SEQ
                      Places,  Xfrac[1],  Xfrac[0] := NORMALISE ( Xfrac[1],  Xfrac[0])
                      Xexp := 1 - Places
                IF
                  Yexp <> 0
                    Yfrac[1] := Yfrac[1] \/ Sign
                  TRUE
                    SEQ
                      Places,  Yfrac[1],  Yfrac[0] := NORMALISE ( Yfrac[1],  Yfrac[0])
                      Yexp := 1 - Places
              --}}}  
          --}}}  
        TRUE
          --{{{  one or other inf/NaN
          SEQ
            CAUSEERROR()
            --Xfrac[1] := Xfrac[1] /\ (~Sign)        --clear top bit
            --Yfrac[1] := Yfrac[1] /\ (~Sign)
            --IF
              --(Xexp = RealExp) AND (Yexp = RealExp)
                --{{{  both inf/NaN
                --SEQ
                  --Guard, Places := LONGDIFF (Xfrac[0], Yfrac[0], 0)
                  --Guard, Places := LONGDIFF (Xfrac[1], Yfrac[1], Guard)
                  --IF
                    --((Xfrac [1] \/ Xfrac [0]) \/ (Yfrac [1] \/ Yfrac [0])) = 0
                      --Ans := RemInfNaN.32
                    --Places < 0
                      --Ans := Y
                    --TRUE
                      --Ans := X
                --}}}  
              --Xexp = RealExp
                --{{{  X is inf/NaN
                --IF
                  --(Xfrac[1] \/ Xfrac[0]) <> 0
                    --Ans := X
                  --TRUE
                    --Ans := RemInfNaN.32
                --}}}  
              --(Yfrac[1] \/ Yfrac[0]) <> 0
                --{{{  Y is NaN
                --SEQ
                  --Ans[1] := Y[1]                 --keep NaN (may be - if sub)
                  --Ans[0] := Y[0]
                --}}}  
              --TRUE
                --{{{  Y is inf
                --SEQ
                  --Ans[1] := X[1]
                  --Ans[0] := X[0]
                --}}}  
          --}}}  
      --}}}  
      --{{{  evaluate
      IF
        Carry = 0
          --{{{  Answer is set up
          SEQ
            Result[1] := Ans[1]
            Result[0] := Ans[0]
          --}}}  
        TRUE
          --{{{  Do Remainder
          SEQ
            --{{{  find remainder
            SEQ
              -- Denorms already normalised
              Ans[1] := X[1] /\ Sign           --set correct sign
              Places := Xexp - Yexp
              IF
                Places >= 0                    --general case
                  SEQ
                    Carry := Places /\ (BitsPerWord - 1)
                    Guard,  Xexp := SHIFTLEFT ( 0,  Xfrac[1],  Carry)
                    Xfrac[1],  Xfrac[0] := SHIFTLEFT ( Xfrac[1],  Xfrac[0],  Carry)
                    Guard,  Xfrac[1],  Xfrac[0] := RealIDiv (Guard, Xfrac[1],
                                                             Xfrac[0],  Yfrac)
                    Places := Places - Carry
                    WHILE Places > 0
                      SEQ
                        Guard := Xfrac[1]
                        Xfrac[1] := Xfrac[0]
                        Xfrac[0] := 0
                        Carry,  Xexp := LONGDIFF ( Xfrac[1],  Yfrac[1],  0)
                        IF
                          (Guard = 0) AND (Carry <> 0)     -- filter out some 0 quotients
                            SKIP
                          TRUE
                            Guard,  Xfrac[1],  Xfrac[0] := RealIDiv (Guard,
                                                Xfrac[1], Xfrac[0],  Yfrac)
                        Places := Places - BitsPerWord
                    IF
                      (Xfrac[1] \/ Xfrac[0]) = 0     --divides exactly
                        Xexp := 0
                      TRUE
                        SEQ
                          Ans[1],  Ans[0] := SHIFTRIGHT (Yfrac[1],  Yfrac[0],  1)
                          Carry,  Ans[0] := LONGDIFF ( Ans[0],  Xfrac[0],  0)
                          Carry,  Ans[1] := LONGDIFF ( Ans[1], Xfrac[1],  Carry)
                          IF
                            (Carry <> 0) OR (((Ans[1] \/ Ans[0]) = 0) AND
                             ((Guard /\ 1) <> 0))
                              SEQ
                                Ans[1] := (X[1] >< Sign) /\ Sign--negate ans
                                Carry,  Xfrac[0] := LONGDIFF ( Yfrac[0], Xfrac[0],  0)
                                Carry,  Xfrac[1] := LONGDIFF ( Yfrac[1], Xfrac[1],  Carry)
                            TRUE
                              Ans[1] := X[1] /\ Sign        --reset sign
                          Xexp := Yexp
                Places = (-1)                  --half to nearly one
                  SEQ
                    Carry,  Guard := LONGDIFF ( Yfrac[0],  Xfrac[0],  0)
                    Carry,  Guard := LONGDIFF ( Yfrac[1],  Xfrac[1],  Carry)
                    IF
                      Carry = 0                --X is answer
                        SKIP
                      TRUE                     --Y-X is answer
                        SEQ
                          Ans[1] := Ans[1] >< Sign   --invert sign
                          Xfrac[1],  Xfrac[0] := SHIFTRIGHT (Xfrac[1],  Xfrac[0],  1)
                          Carry,  Xfrac[0] := LONGDIFF ( Yfrac[0], Xfrac[0],  0)
                          Carry,  Xfrac[1] := LONGDIFF ( Yfrac[1], Xfrac[1],  Carry)
                          Xexp := Yexp
                TRUE                           --less than half
                  SKIP                         --X is answer
              Guard := 0
              Places,  Xfrac[1],  Xfrac[0] := NORMALISE ( Xfrac[1],  Xfrac[0])
              Xexp := Xexp - Places            --ensure normalised
              IF
                Xexp <= 0                      --gone denorm
                  SEQ
                    Xfrac[1],  Xfrac[0] := SHIFTRIGHT (Xfrac[1],  Xfrac[0],  1 - Xexp)
                    Xexp := 0
                TRUE
                  SKIP
            --}}}  
            --{{{  pack result
            Xfrac[1],  Xfrac[0] := SHIFTRIGHT (Xfrac[1] /\ (~Sign),  Xfrac[0],
                                                                  RealShift)
            Carry,  Xexp := SHIFTRIGHT ( Xexp,  0,  RealShift + 1)
            Xfrac[1] := Xfrac[1] \/ Xexp

            Result[1] := Ans[1] \/ Xfrac[1]
            Result[0] := Xfrac[0]
            --}}}  
          --}}}  
      --}}}  
    RESULT Result
:
--}}}  

#ENDIF
