path: root/gcc/ada/exp_vfpt.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ V F P T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1997-2012, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Einfo;    use Einfo;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Rtsfind;  use Rtsfind;
with Sem_Res;  use Sem_Res;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Tbuild;   use Tbuild;
with Urealp;   use Urealp;
with Eval_Fat; use Eval_Fat;

package body Exp_VFpt is

   --  Vax floating point format (from Vax Architecture Reference Manual
   --  version 6):

   --  Float F:
   --  --------

   --   1 1
   --   5 4             7 6            0
   --  +-+---------------+--------------+
   --  |S|     exp       |   fraction   |  A
   --  +-+---------------+--------------+
   --  |             fraction           |  A + 2
   --  +--------------------------------+

   --  bit 15 is the sign bit,
   --  bits 14:7 is the excess 128 binary exponent,
   --  bits 6:0 and 31:16 the normalized 24-bit fraction with the redundant
   --    most significant fraction bit not represented.

   --  An exponent value of 0 together with a sign bit of 0, is taken to
   --  indicate that the datum has a value of 0. Exponent values of 1 through
   --  255 indicate true binary exponents of -127 to +127. An exponent value
   --  of 0, together with a sign bit of 1, is taken as reserved.

   --  Note that fraction bits are not continuous in memory, VAX is little
   --  endian (LSB first).

   --  Float D:
   --  --------

   --   1 1
   --   5 4             7 6            0
   --  +-+---------------+--------------+
   --  |S|     exp       |   fraction   |  A
   --  +-+---------------+--------------+
   --  |             fraction           |  A + 2
   --  +--------------------------------+
   --  |             fraction           |  A + 4
   --  +--------------------------------+
   --  |             fraction (low)     |  A + 6
   --  +--------------------------------+

   --  Note that the fraction bits are not continuous in memory. Bytes in a
   --  words are stored using little endianness, but words are stored using
   --  big endianness (PDP endian)

   --  Like Float F but with 55 bits for the fraction.

   --  Float G:
   --  --------

   --   1 1
   --   5 4                   4 3      0
   --  +-+---------------------+--------+
   --  |S|     exp             |  fract |  A
   --  +-+---------------------+--------+
   --  |             fraction           |  A + 2
   --  +--------------------------------+
   --  |             fraction           |  A + 4
   --  +--------------------------------+
   --  |             fraction (low)     |  A + 6
   --  +--------------------------------+

   --  Exponent values of 1 through 2047 indicate true binary exponents of
   --  -1023 to +1023.

   --  Main differences compared to IEEE 754:

   --  * No denormalized numbers
   --  * No infinity
   --  * No NaN
   --  * No -0.0
   --  * Reserved values (exp = 0, sign = 1)
   --  * Vax mantissa represent values [0.5, 1)
   --  * Bias is shifted by 1 (for single float: 128 on Vax, 127 on IEEE)

   VAXFF_Digits : constant := 6;
   VAXDF_Digits : constant := 9;
   VAXGF_Digits : constant := 15;

   ----------------------
   -- Expand_Vax_Arith --
   ----------------------

   procedure Expand_Vax_Arith (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Typ   : constant Entity_Id  := Base_Type (Etype (N));
      Typc  : Character;
      Atyp  : Entity_Id;
      Func  : RE_Id;
      Args  : List_Id;

   begin
      --  Get arithmetic type, note that we do D stuff in G

      if Digits_Value (Typ) = VAXFF_Digits then
         Typc := 'F';
         Atyp := RTE (RE_F);
      else
         Typc := 'G';
         Atyp := RTE (RE_G);
      end if;

      case Nkind (N) is

         when N_Op_Abs =>
            if Typc = 'F' then
               Func := RE_Abs_F;
            else
               Func := RE_Abs_G;
            end if;

         when N_Op_Add =>
            if Typc = 'F' then
               Func := RE_Add_F;
            else
               Func := RE_Add_G;
            end if;

         when N_Op_Divide =>
            if Typc = 'F' then
               Func := RE_Div_F;
            else
               Func := RE_Div_G;
            end if;

         when N_Op_Multiply =>
            if Typc = 'F' then
               Func := RE_Mul_F;
            else
               Func := RE_Mul_G;
            end if;

         when N_Op_Minus =>
            if Typc = 'F' then
               Func := RE_Neg_F;
            else
               Func := RE_Neg_G;
            end if;

         when N_Op_Subtract =>
            if Typc = 'F' then
               Func := RE_Sub_F;
            else
               Func := RE_Sub_G;
            end if;

         when others =>
            Func := RE_Null;
            raise Program_Error;

      end case;

      Args := New_List;

      if Nkind (N) in N_Binary_Op then
         Append_To (Args,
           Convert_To (Atyp, Left_Opnd (N)));
      end if;

      Append_To (Args,
        Convert_To (Atyp, Right_Opnd (N)));

      Rewrite (N,
        Convert_To (Typ,
          Make_Function_Call (Loc,
            Name => New_Occurrence_Of (RTE (Func), Loc),
            Parameter_Associations => Args)));

      Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
   end Expand_Vax_Arith;

   ---------------------------
   -- Expand_Vax_Comparison --
   ---------------------------

   procedure Expand_Vax_Comparison (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Typ   : constant Entity_Id  := Base_Type (Etype (Left_Opnd (N)));
      Typc  : Character;
      Func  : RE_Id;
      Atyp  : Entity_Id;
      Revrs : Boolean := False;
      Args  : List_Id;

   begin
      --  Get arithmetic type, note that we do D stuff in G

      if Digits_Value (Typ) = VAXFF_Digits then
         Typc := 'F';
         Atyp := RTE (RE_F);
      else
         Typc := 'G';
         Atyp := RTE (RE_G);
      end if;

      case Nkind (N) is

         when N_Op_Eq =>
            if Typc = 'F' then
               Func := RE_Eq_F;
            else
               Func := RE_Eq_G;
            end if;

         when N_Op_Ge =>
            if Typc = 'F' then
               Func := RE_Le_F;
            else
               Func := RE_Le_G;
            end if;

            Revrs := True;

         when N_Op_Gt =>
            if Typc = 'F' then
               Func := RE_Lt_F;
            else
               Func := RE_Lt_G;
            end if;

            Revrs := True;

         when N_Op_Le =>
            if Typc = 'F' then
               Func := RE_Le_F;
            else
               Func := RE_Le_G;
            end if;

         when N_Op_Lt =>
            if Typc = 'F' then
               Func := RE_Lt_F;
            else
               Func := RE_Lt_G;
            end if;

         when N_Op_Ne =>
            if Typc = 'F' then
               Func := RE_Ne_F;
            else
               Func := RE_Ne_G;
            end if;

         when others =>
            Func := RE_Null;
            raise Program_Error;

      end case;

      if not Revrs then
         Args := New_List (
           Convert_To (Atyp, Left_Opnd  (N)),
           Convert_To (Atyp, Right_Opnd (N)));

      else
         Args := New_List (
           Convert_To (Atyp, Right_Opnd (N)),
           Convert_To (Atyp, Left_Opnd  (N)));
      end if;

      Rewrite (N,
        Make_Function_Call (Loc,
          Name => New_Occurrence_Of (RTE (Func), Loc),
          Parameter_Associations => Args));

      Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
   end Expand_Vax_Comparison;

   ---------------------------
   -- Expand_Vax_Conversion --
   ---------------------------

   procedure Expand_Vax_Conversion (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Expr  : constant Node_Id    := Expression (N);
      S_Typ : constant Entity_Id  := Base_Type (Etype (Expr));
      T_Typ : constant Entity_Id  := Base_Type (Etype (N));

      CallS : RE_Id;
      CallT : RE_Id;
      Func  : RE_Id;

      function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
      --  Given one of the two types T, determines the corresponding call
      --  type, i.e. the type to be used for the call (or the result of
      --  the call). The actual operand is converted to (or from) this type.
      --  Otyp is the other type, which is useful in figuring out the result.
      --  The result returned is the RE_Id value for the type entity.

      function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
      --  Find the predefined integer type that has the same size as the
      --  fixed-point type T, for use in fixed/float conversions.

      ---------------
      -- Call_Type --
      ---------------

      function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
      begin
         --  Vax float formats

         if Vax_Float (T) then
            if Digits_Value (T) = VAXFF_Digits then
               return RE_F;

            elsif Digits_Value (T) = VAXGF_Digits then
               return RE_G;

            --  For D_Float, leave it as D float if the other operand is
            --  G_Float, since this is the one conversion that is properly
            --  supported for D_Float, but otherwise, use G_Float.

            else pragma Assert (Digits_Value (T) = VAXDF_Digits);

               if Vax_Float (Otyp)
                 and then Digits_Value (Otyp) = VAXGF_Digits
               then
                  return RE_D;
               else
                  return RE_G;
               end if;
            end if;

         --  For all discrete types, use 64-bit integer

         elsif Is_Discrete_Type (T) then
            return RE_Q;

         --  For all real types (other than Vax float format), we use the
         --  IEEE float-type which corresponds in length to the other type
         --  (which is Vax Float).

         else pragma Assert (Is_Real_Type (T));

            if Digits_Value (Otyp) = VAXFF_Digits then
               return RE_S;
            else
               return RE_T;
            end if;
         end if;
      end Call_Type;

      -------------------------------------------------
      -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
      -------------------------------------------------

      function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
      begin
         if Esize (T) = Esize (Standard_Long_Long_Integer) then
            return Standard_Long_Long_Integer;
         elsif Esize (T) = Esize (Standard_Long_Integer) then
            return  Standard_Long_Integer;
         else
            return Standard_Integer;
         end if;
      end Equivalent_Integer_Type;

   --  Start of processing for Expand_Vax_Conversion;

   begin
      --  If input and output are the same Vax type, we change the
      --  conversion to be an unchecked conversion and that's it.

      if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
        and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
      then
         Rewrite (N,
           Unchecked_Convert_To (T_Typ, Expr));

      --  Case of conversion of fixed-point type to Vax_Float type

      elsif Is_Fixed_Point_Type (S_Typ) then

         --  If Conversion_OK set, then we introduce an intermediate IEEE
         --  target type since we are expecting the code generator to handle
         --  the case of integer to IEEE float.

         if Conversion_OK (N) then
            Rewrite (N,
              Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));

         --  Otherwise, convert the scaled integer value to the target type,
         --  and multiply by 'Small of type.

         else
            Rewrite (N,
               Make_Op_Multiply (Loc,
                 Left_Opnd =>
                   Make_Type_Conversion (Loc,
                     Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
                     Expression   =>
                       Unchecked_Convert_To (
                         Equivalent_Integer_Type (S_Typ), Expr)),
                 Right_Opnd =>
                   Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
         end if;

      --  Case of conversion of Vax_Float type to fixed-point type

      elsif Is_Fixed_Point_Type (T_Typ) then

         --  If Conversion_OK set, then we introduce an intermediate IEEE
         --  target type, since we are expecting the code generator to handle
         --  the case of IEEE float to integer.

         if Conversion_OK (N) then
            Rewrite (N,
              OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));

         --  Otherwise, multiply value by 'small of type, and convert to the
         --  corresponding integer type.

         else
            Rewrite (N,
              Unchecked_Convert_To (T_Typ,
                Make_Type_Conversion (Loc,
                  Subtype_Mark =>
                    New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
                  Expression =>
                    Make_Op_Multiply (Loc,
                      Left_Opnd => Expr,
                      Right_Opnd =>
                        Make_Real_Literal (Loc,
                          Realval => Ureal_1 / Small_Value (T_Typ))))));
         end if;

      --  All other cases

      else
         --  Compute types for call

         CallS := Call_Type (S_Typ, T_Typ);
         CallT := Call_Type (T_Typ, S_Typ);

         --  Get function and its types

         if CallS = RE_D and then CallT = RE_G then
            Func := RE_D_To_G;

         elsif CallS = RE_G and then CallT = RE_D then
            Func := RE_G_To_D;

         elsif CallS = RE_G and then CallT = RE_F then
            Func := RE_G_To_F;

         elsif CallS = RE_F and then CallT = RE_G then
            Func := RE_F_To_G;

         elsif CallS = RE_F and then CallT = RE_S then
            Func := RE_F_To_S;

         elsif CallS = RE_S and then CallT = RE_F then
            Func := RE_S_To_F;

         elsif CallS = RE_G and then CallT = RE_T then
            Func := RE_G_To_T;

         elsif CallS = RE_T and then CallT = RE_G then
            Func := RE_T_To_G;

         elsif CallS = RE_F and then CallT = RE_Q then
            Func := RE_F_To_Q;

         elsif CallS = RE_Q and then CallT = RE_F then
            Func := RE_Q_To_F;

         elsif CallS = RE_G and then CallT = RE_Q then
            Func := RE_G_To_Q;

         else pragma Assert (CallS = RE_Q and then CallT = RE_G);
            Func := RE_Q_To_G;
         end if;

         Rewrite (N,
           Convert_To (T_Typ,
             Make_Function_Call (Loc,
               Name => New_Occurrence_Of (RTE (Func), Loc),
               Parameter_Associations => New_List (
                 Convert_To (RTE (CallS), Expr)))));
      end if;

      Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);
   end Expand_Vax_Conversion;

   -------------------------------
   -- Expand_Vax_Foreign_Return --
   -------------------------------

   procedure Expand_Vax_Foreign_Return (N : Node_Id) is
      Loc  : constant Source_Ptr := Sloc (N);
      Typ  : constant Entity_Id  := Base_Type (Etype (N));
      Func : RE_Id;
      Args : List_Id;
      Atyp : Entity_Id;
      Rtyp : constant Entity_Id  := Etype (N);

   begin
      if Digits_Value (Typ) = VAXFF_Digits then
         Func := RE_Return_F;
         Atyp := RTE (RE_F);
      elsif Digits_Value (Typ) = VAXDF_Digits then
         Func := RE_Return_D;
         Atyp := RTE (RE_D);
      else pragma Assert (Digits_Value (Typ) = VAXGF_Digits);
         Func := RE_Return_G;
         Atyp := RTE (RE_G);
      end if;

      Args := New_List (Convert_To (Atyp, N));

      Rewrite (N,
        Convert_To (Rtyp,
          Make_Function_Call (Loc,
            Name                   => New_Occurrence_Of (RTE (Func), Loc),
            Parameter_Associations => Args)));

      Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
   end Expand_Vax_Foreign_Return;

   --------------------------------
   -- Vax_Real_Literal_As_Signed --
   --------------------------------

   function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint is
      Btyp     : constant Entity_Id :=
                   Base_Type (Underlying_Type (Etype (N)));

      Value    : constant Ureal := Realval (N);
      Negative : Boolean;
      Fraction : UI;
      Exponent : UI;
      Res      : UI;

      Exponent_Size : Uint;
      --  Number of bits for the exponent

      Fraction_Size : Uint;
      --  Number of bits for the fraction

      Uintp_Mark : constant Uintp.Save_Mark := Mark;
      --  Use the mark & release feature to delete temporaries
   begin
      --  Extract the sign now

      Negative := UR_Is_Negative (Value);

      --  Decompose the number

      Decompose_Int (Btyp, abs Value, Fraction, Exponent, Round_Even);

      --  Number of bits for the fraction, leading fraction bit is implicit

      Fraction_Size := Machine_Mantissa_Value (Btyp) - Int'(1);

      --  Number of bits for the exponent (one bit for the sign)

      Exponent_Size := RM_Size (Btyp) - Fraction_Size - Int'(1);

      if Fraction = Uint_0 then
         --  Handle zero

         Res := Uint_0;

      elsif Exponent <= -(Uint_2 ** (Exponent_Size - 1)) then
         --  Underflow

         Res := Uint_0;
      else
         --  Check for overflow

         pragma Assert (Exponent < Uint_2 ** (Exponent_Size - 1));

         --  MSB of the fraction must be 1

         pragma Assert (Fraction / Uint_2 ** Fraction_Size = Uint_1);

         --  Remove the redudant most significant fraction bit

         Fraction := Fraction - Uint_2 ** Fraction_Size;

         --  Build the fraction part. Note that this field is in mixed
         --  endianness: words are stored using little endianness, while bytes
         --  in words are stored using big endianness.

         Res := Uint_0;
         for I in 1 .. UI_To_Int (RM_Size (Btyp)) / 16 loop
            Res := (Res * (Uint_2 ** 16)) + (Fraction mod (Uint_2 ** 16));
            Fraction := Fraction / (Uint_2 ** 16);
         end loop;

         --  The sign bit

         if Negative then
            Res := Res + Int (2**15);
         end if;

         --  The exponent

         Res := Res + (Exponent + Uint_2 ** (Exponent_Size - 1))
           * Uint_2 ** (15 - Exponent_Size);

         --  Until now, we have created an unsigned number, but an underlying
         --  type is a signed type. Convert to a signed number to avoid
         --  overflow in gigi.

         if Res >= Uint_2 ** (Exponent_Size + Fraction_Size) then
            Res := Res - Uint_2 ** (Exponent_Size + Fraction_Size + 1);
         end if;
      end if;

      Release_And_Save (Uintp_Mark, Res);

      return Res;
   end Get_Vax_Real_Literal_As_Signed;

   ----------------------
   -- Expand_Vax_Valid --
   ----------------------

   procedure Expand_Vax_Valid (N : Node_Id) is
      Loc  : constant Source_Ptr := Sloc (N);
      Pref : constant Node_Id    := Prefix (N);
      Ptyp : constant Entity_Id  := Root_Type (Etype (Pref));
      Rtyp : constant Entity_Id  := Etype (N);
      Vtyp : RE_Id;
      Func : RE_Id;

   begin
      if Digits_Value (Ptyp) = VAXFF_Digits then
         Func := RE_Valid_F;
         Vtyp := RE_F;
      elsif Digits_Value (Ptyp) = VAXDF_Digits then
         Func := RE_Valid_D;
         Vtyp := RE_D;
      else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits);
         Func := RE_Valid_G;
         Vtyp := RE_G;
      end if;

      Rewrite (N,
        Convert_To (Rtyp,
          Make_Function_Call (Loc,
            Name                   => New_Occurrence_Of (RTE (Func), Loc),
            Parameter_Associations => New_List (
              Convert_To (RTE (Vtyp), Pref)))));

      Analyze_And_Resolve (N);
   end Expand_Vax_Valid;

end Exp_VFpt;