aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/exp_vfpt.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/exp_vfpt.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/exp_vfpt.adb690
1 files changed, 690 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/exp_vfpt.adb b/gcc-4.8.3/gcc/ada/exp_vfpt.adb
new file mode 100644
index 000000000..82d2fe16e
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/exp_vfpt.adb
@@ -0,0 +1,690 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 in little endian format, but words are stored using
+ -- big endian format (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;