diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_vfpt.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_vfpt.adb | 690 |
1 files changed, 0 insertions, 690 deletions
diff --git a/gcc-4.8/gcc/ada/exp_vfpt.adb b/gcc-4.8/gcc/ada/exp_vfpt.adb deleted file mode 100644 index 82d2fe16e..000000000 --- a/gcc-4.8/gcc/ada/exp_vfpt.adb +++ /dev/null @@ -1,690 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |