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