diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e43c701f2eb..826d174b81a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2014-11-20 Robert Dewar + + * inline.adb, sem_util.adb: Minor reformatting. + +2014-11-20 Pierre-Marie Derodat + + * uintp.h (UI_Eq): Declare. + * urealp.h (Norm_Den): Declare. + (Norm_Num): Declare. + * exp_dbug.adb (Is_Handled_Scale_Factor): New. + (Get_Encoded_Name): Do not output ___XF GNAT encodings + for fixed-point types when these can be handled by GCC's DWARF + back-end. + +2014-11-20 Thomas Quinot + + * sem_ch13.db (Inherit_Aspects_At_Freeze_Point): Inherit parent + SSO even if set through a pragma Default_Scalar_Storage_Order. + * freeze.adb (Set_SSO_From_Default): For a type extension, + do not let the default SSO override the parent SSO. + * gnat_rm.texi: document the above + 2014-11-20 Robert Dewar * a-stream.ads, a-reatim.ads, a-calend.ads, sinfo.ads, s-crtl.ads, diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 0d30f421e5b..fde8c78ac43 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -133,6 +133,10 @@ package body Exp_Dbug is -- Determine whether the bounds of E match the size of the type. This is -- used to determine whether encoding is required for a discrete type. + function Is_Handled_Scale_Factor (U : Ureal) return Boolean; + -- Determine whether the back-end can handle some scale factor. When it + -- cannot, we have to output a GNAT encoding for the correspondig type. + procedure Output_Homonym_Numbers_Suffix; -- If homonym numbers are stored, then output them into Name_Buffer @@ -535,6 +539,27 @@ package body Exp_Dbug is return Make_Null_Statement (Loc); end Debug_Renaming_Declaration; + ----------------------------- + -- Is_Handled_Scale_Factor -- + ----------------------------- + + function Is_Handled_Scale_Factor (U : Ureal) return Boolean is + begin + -- Keep in sync with gigi (see E_*_Fixed_Point_Type handling in + -- decl.c:gnat_to_gnu_entity). + if UI_Eq (Numerator (U), Uint_1) then + if Rbase (U) = 2 + or else Rbase (U) = 10 + then + return True; + end if; + end if; + + return + (UI_Is_In_Int_Range (Norm_Num (U)) + and then UI_Is_In_Int_Range (Norm_Den (U))); + end Is_Handled_Scale_Factor; + ---------------------- -- Get_Encoded_Name -- ---------------------- @@ -593,9 +618,14 @@ package body Exp_Dbug is Has_Suffix := True; - -- Fixed-point case + -- Fixed-point case: generate GNAT encodings when asked to or when we + -- know the back-end will not be able to handle the scale factor. - if Is_Fixed_Point_Type (E) then + if Is_Fixed_Point_Type (E) + and then + (GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal + or else not Is_Handled_Scale_Factor (Small_Value (E))) + then Get_External_Name (E, True, "XF_"); Add_Real_To_Buffer (Delta_Value (E)); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 85a9cbc5743..6d366f050f9 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -7695,8 +7695,17 @@ package body Freeze is procedure Set_SSO_From_Default (T : Entity_Id) is begin - if (Is_Record_Type (T) or else Is_Array_Type (T)) - and then Is_Base_Type (T) + -- Set default SSO for an array or record base type, except in the case + -- of a type extension (which always inherits the SSO of its parent + -- type). + + if Is_Base_Type (T) + and then (Is_Array_Type (T) + or else + (Is_Record_Type (T) + and then not (Is_Tagged_Type (T) + and then + Is_Derived_Type (T)))) then if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) or else diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e0f6b3fcf3b..0320a0b46d0 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -2552,10 +2552,12 @@ pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First); @noindent Normally if no explicit @code{Scalar_Storage_Order} is given for a record -type or array type, then the scalar storage order defaults to the ordinary -default for the target. But this default may be overridden using this pragma. -The pragma may appear as a configuration pragma, or locally within a package -spec or declarative part. In the latter case, it applies to all subsequent +type or array type, then the scalar storage order defaults to the native +order for the target. However, this default may be overridden using +this pragma (except for derived tagged types, which always default to +inheriting the scalar storage order of their parent). The pragma may +appear as a configuration pragma, or locally within a package spec or +declarative part. In the latter case, it applies to all subsequent types declared within that package spec or declarative part. If this pragma is used as a configuration pragma which appears within a diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 9e97e8305fe..d5e9ae99e8d 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1655,8 +1655,7 @@ package body Inline is Body_To_Inline := Copy_Separate_Tree (N); end if; - -- Remove all aspects/pragmas that have no meaining in an inlined - -- body. + -- Remove all aspects/pragmas that have no meaning in an inlined body Remove_Aspects_And_Pragmas (Body_To_Inline); @@ -3938,25 +3937,6 @@ package body Inline is Append_New_Elmt (N, To => Backend_Calls); end Register_Backend_Call; - -------------------------- - -- Remove_Dead_Instance -- - -------------------------- - - procedure Remove_Dead_Instance (N : Node_Id) is - J : Int; - - begin - J := 0; - while J <= Pending_Instantiations.Last loop - if Pending_Instantiations.Table (J).Inst_Node = N then - Pending_Instantiations.Table (J).Inst_Node := Empty; - return; - end if; - - J := J + 1; - end loop; - end Remove_Dead_Instance; - -------------------------------- -- Remove_Aspects_And_Pragmas -- -------------------------------- @@ -4016,4 +3996,23 @@ package body Inline is Remove_Items (Declarations (Body_Decl)); end Remove_Aspects_And_Pragmas; + -------------------------- + -- Remove_Dead_Instance -- + -------------------------- + + procedure Remove_Dead_Instance (N : Node_Id) is + J : Int; + + begin + J := 0; + while J <= Pending_Instantiations.Last loop + if Pending_Instantiations.Table (J).Inst_Node = N then + Pending_Instantiations.Table (J).Inst_Node := Empty; + return; + end if; + + J := J + 1; + end loop; + end Remove_Dead_Instance; + end Inline; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2ca48ef46dd..9c119a35f8b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3035,7 +3035,8 @@ package body Sem_Ch13 is -- evaluation of this aspect should be delayed to the -- freeze point (why???) - if No (Expr) or else Is_True (Static_Boolean (Expr)) + if No (Expr) + or else Is_True (Static_Boolean (Expr)) then Set_Uses_Lock_Free (E); end if; @@ -3725,8 +3726,7 @@ package body Sem_Ch13 is end if; end if; - if not Check_Primitive_Function (Subp) - then + if not Check_Primitive_Function (Subp) then Illegal_Indexing ("Indexing aspect requires a function that applies to type&"); return; @@ -3798,7 +3798,8 @@ package body Sem_Ch13 is ("variable indexing must return a reference type"); return; - elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) + elsif Is_Access_Constant + (Etype (First_Discriminant (Ret_Type))) then Illegal_Indexing ("variable indexing must return an access to variable"); @@ -10882,7 +10883,7 @@ package body Sem_Ch13 is Set_Has_Volatile_Components (Imp_Bas_Typ); end if; - -- Finalize_Storage_Only. + -- Finalize_Storage_Only if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False) and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only) @@ -10900,12 +10901,9 @@ package body Sem_Ch13 is Set_Universal_Aliasing (Imp_Bas_Typ); end if; - -- Record type specific aspects + -- Bit_Order if Is_Record_Type (Typ) then - - -- Bit_Order - if not Has_Rep_Item (Typ, Name_Bit_Order, False) and then Has_Rep_Item (Typ, Name_Bit_Order) then @@ -10913,15 +10911,29 @@ package body Sem_Ch13 is Reverse_Bit_Order (Entity (Name (Get_Rep_Item (Typ, Name_Bit_Order))))); end if; + end if; - -- Scalar_Storage_Order + -- Scalar_Storage_Order (first subtypes only) + + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) + and then + Is_First_Subtype (Typ) + then + + -- For a type extension, always inherit from parent; otherwise + -- inherit if no default applies. Note: we do not check for + -- an explicit rep item on the parent type when inheriting, + -- because the parent SSO may itself have been set by default. if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False) - and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order) + and then (Is_Tagged_Type (Bas_Typ) + or else + not (SSO_Set_Low_By_Default (Bas_Typ) + or else + SSO_Set_High_By_Default (Bas_Typ))) then Set_Reverse_Storage_Order (Bas_Typ, - Reverse_Storage_Order (Entity (Name - (Get_Rep_Item (Typ, Name_Scalar_Storage_Order))))); + Reverse_Storage_Order (First_Subtype (Etype (Bas_Typ)))); -- Clear default SSO indications, since the inherited aspect -- which was set explicitly overrides the default. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ba2135daa70..45d306600ad 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5966,10 +5966,10 @@ package body Sem_Util is -- no longer a source construct, but it must still be recognized. elsif Comes_From_Source (Decl) - or else (Nkind_In (Decl, N_Subprogram_Body, - N_Subprogram_Declaration) - and then Is_Expression_Function - (Defining_Entity (Decl))) + or else + (Nkind_In (Decl, N_Subprogram_Body, + N_Subprogram_Declaration) + and then Is_Expression_Function (Defining_Entity (Decl))) then exit; end if; diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h index b950a88cbfb..1f4e7a3e7bf 100644 --- a/gcc/ada/uintp.h +++ b/gcc/ada/uintp.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, 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- * @@ -79,6 +79,10 @@ typedef struct {const int *Array; Vector_Template *Bounds; } #define Vector_To_Uint uintp__vector_to_uint extern Uint Vector_To_Uint (Int_Vector, Boolean); +/* Compare integer values for equality. */ +#define UI_Eq uintp__ui_eq +extern Boolean UI_Eq (Uint, Uint); + /* Compare integer values for less than. */ #define UI_Lt uintp__ui_lt extern Boolean UI_Lt (Uint, Uint); diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h index fbb87608133..b8ddc172f83 100644 --- a/gcc/ada/urealp.h +++ b/gcc/ada/urealp.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, 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- * @@ -41,6 +41,12 @@ extern Uint Denominator (Ureal); #define Rbase urealp__rbase extern Nat Rbase (Ureal); +#define Norm_Den urealp__norm_den +extern Uint Norm_Den (Ureal); + +#define Norm_Num urealp__norm_num +extern Uint Norm_Num (Ureal); + #define UR_Is_Negative urealp__ur_is_negative extern Boolean UR_Is_Negative (Ureal);