diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7438dabe57ec..9195cb018c58 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2013-10-10 Robert Dewar + + * sem_ch13.adb (Analyze_Aspect_Specifications): For Address + attribute, consider it to be set in source, because of aliasing + considerations. + (Analyze_Attribute_Definition_Clause): For the + purpose of warning on overlays, take into account the aspect case. + +2013-10-10 Robert Dewar + + * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, a-cforse.ads, + a-cofove.ads: Minor reformatting. + +2013-10-10 Arnaud Charlet + + * gnat_ugn.texi: Remove obsolete mention to -laddr2line. + +2013-10-10 Ed Schonberg + + * exp_ch4.adb (Expand_N_Case_Expression): Indicate that the + generated variable used as a target of the expression needs + no initialization. + +2013-10-10 Jose Ruiz + + * exp_util.adb (Corresponding_Runtime_Package): Remove the condition + related to No_Dynamic_Attachment which was wrong. Protected types + with interrupt handlers (when not using a restricted profile) + are always treated as protected types with entries, regardless + of the No_Dynamic_Attachment restriction. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Simplify the code + using the result of Corresponding_Runtime_Package. + (Install_Private_Data_Declarations): When having + static handlers and a non restricted profile, we use the + type Static_Interrupt_Protection always, so we removed an + extra wrong condition looking at the No_Dynamic_Attachment + restriction. Simplify the code using the result of + Corresponding_Runtime_Package. + (Make_Initialize_Protection): Simplify the code using + the result of Corresponding_Runtime_Package. + (Install_Private_Data_Declaration): The No_Dynamic_Attachment + restriction has nothing to do with static handlers. Remove the extra + erroneous condition that was creating the wrong data type. + +2013-10-10 Hristian Kirtchev + + * sem_util.adb (Is_Object_Reference): Attribute + 'Old produces an object reference. + * gnat_rm.texi: Define accessibility level of + X'Update(...) result. + 2013-10-10 Yannick Moy * gnat_rm.texi, a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 0442fe60aaf5..b15b2425e4dc 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -51,7 +51,7 @@ -- function Left (Container : List; Position : Cursor) return List; -- function Right (Container : List; Position : Cursor) return List; --- See subprogram specifications that follow for details. +-- See subprogram specifications that follow for details generic type Element_Type is private; diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 2f1e7bbdaf07..dbfcb82e9dc0 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -51,7 +51,7 @@ -- function Left (Container : Map; Position : Cursor) return Map; -- function Right (Container : Map; Position : Cursor) return Map; --- See detailed specifications for these subprograms. +-- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index 147a332ed528..c0103cbe0f44 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -51,7 +51,7 @@ -- function Left (Container : Set; Position : Cursor) return Set; -- function Right (Container : Set; Position : Cursor) return Set; --- See detailed specifications for these subprograms. +-- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index ca6db020013e..2ddbd90a1ab7 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -53,7 +53,7 @@ -- function Left (Container : Map; Position : Cursor) return Map; -- function Right (Container : Map; Position : Cursor) return Map; --- See detailed specifications for these subprograms. +-- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index 7f9316186e68..1d8cdf667861 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -52,7 +52,7 @@ -- function Left (Container : Set; Position : Cursor) return Set; -- function Right (Container : Set; Position : Cursor) return Set; --- See detailed specifications for these subprograms. +-- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 58e7b8b2c7b5..604ed8d356b7 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -50,7 +50,7 @@ -- function Left (Container : Vector; Position : Cursor) return Vector; -- function Right (Container : Vector; Position : Cursor) return Vector; --- See detailed specifications for these subprograms. +-- See detailed specifications for these subprograms with Ada.Containers; use Ada.Containers; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0802f2dfa517..234e206e9265 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4891,6 +4891,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Cstmt : Node_Id; + Decl : Node_Id; Tnn : Entity_Id; Pnn : Entity_Id; Actions : List_Id; @@ -4967,10 +4968,15 @@ package body Exp_Ch4 is end if; Tnn := Make_Temporary (Loc, 'T'); - Append_To (Actions, - Make_Object_Declaration (Loc, + + -- Create declaration for target of expression, and indicate that it + -- does not require initialization. + + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Tnn, - Object_Definition => New_Occurrence_Of (Ttyp, Loc))); + Object_Definition => New_Occurrence_Of (Ttyp, Loc)); + Set_No_Initialization (Decl); + Append_To (Actions, Decl); -- Now process the alternatives diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 16e83091529b..6f437923483b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8987,8 +8987,6 @@ package body Exp_Ch9 is (Prot_Typ, Cdecls, Loc); begin - -- Could this be simplified using Corresponding_Runtime_Package??? - if Has_Attach_Handler (Prot_Typ) then Ritem := First_Rep_Item (Prot_Typ); while Present (Ritem) loop @@ -9000,47 +8998,40 @@ package body Exp_Ch9 is Next_Rep_Item (Ritem); end loop; + end if; - if Restricted_Profile then - if Has_Entries (Prot_Typ) then - Protection_Subtype := - New_Reference_To (RTE (RE_Protection_Entry), Loc); - else - Protection_Subtype := - New_Reference_To (RTE (RE_Protection), Loc); - end if; + -- Determine the proper protection type. There are two special + -- cases: 1) when the protected type has dynamic interrupt + -- handlers, and 2) when it has static handlers and we use a + -- restricted profile. - else - Protection_Subtype := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To - (RTE (RE_Static_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Entry_Count_Expr, - Make_Integer_Literal (Loc, Num_Attach_Handler)))); - end if; + if Has_Attach_Handler (Prot_Typ) + and then not Restricted_Profile + then + Protection_Subtype := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Static_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Entry_Count_Expr, + Make_Integer_Literal (Loc, Num_Attach_Handler)))); elsif Has_Interrupt_Handler (Prot_Typ) and then not Restriction_Active (No_Dynamic_Attachment) then Protection_Subtype := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To - (RTE (RE_Dynamic_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List (Entry_Count_Expr))); + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Dynamic_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List (Entry_Count_Expr))); - -- Type has explicit entries or generated primitive entry wrappers - - elsif Has_Entries (Prot_Typ) - or else (Ada_Version >= Ada_2005 - and then Present (Interface_List (N))) - then + else case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => Protection_Subtype := @@ -9056,13 +9047,13 @@ package body Exp_Ch9 is Protection_Subtype := New_Reference_To (RTE (RE_Protection_Entry), Loc); + when System_Tasking_Protected_Objects => + Protection_Subtype := + New_Reference_To (RTE (RE_Protection), Loc); + when others => raise Program_Error; end case; - - else - Protection_Subtype := - New_Reference_To (RTE (RE_Protection), Loc); end if; Object_Comp := @@ -13095,7 +13086,6 @@ package body Exp_Ch9 is if Has_Attach_Handler (Conc_Typ) and then not Restricted_Profile - and then not Restriction_Active (No_Dynamic_Attachment) then Prot_Typ := RE_Static_Interrupt_Protection; @@ -13104,14 +13094,7 @@ package body Exp_Ch9 is then Prot_Typ := RE_Dynamic_Interrupt_Protection; - -- The type has explicit entries or generated primitive entry - -- wrappers. - - elsif Has_Entries (Conc_Typ) - or else - (Ada_Version >= Ada_2005 - and then Present (Interface_List (Parent (Conc_Typ)))) - then + else case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => Prot_Typ := RE_Protection_Entries; @@ -13119,12 +13102,12 @@ package body Exp_Ch9 is when System_Tasking_Protected_Objects_Single_Entry => Prot_Typ := RE_Protection_Entry; + when System_Tasking_Protected_Objects => + Prot_Typ := RE_Protection; + when others => raise Program_Error; end case; - - else - Prot_Typ := RE_Protection; end if; -- Generate: @@ -13659,91 +13642,104 @@ package body Exp_Ch9 is -- considered equivalent to a protected type with entries in the -- context of dispatching select statements. - if Has_Entry - or else Has_Interfaces (Protect_Rec) - or else - ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) - and then not Restriction_Active (No_Dynamic_Attachment)) - then - declare - Pkg_Id : constant RTU_Id := - Corresponding_Runtime_Package (Ptyp); + -- Protected types with interrupt handlers (when not using a + -- restricted profile) are also considered equivalent to protected + -- types with entries. The types which are used + -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection) + -- are derived from Protection_Entries. - Called_Subp : RE_Id; + declare + Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); + Called_Subp : RE_Id; - begin - case Pkg_Id is - when System_Tasking_Protected_Objects_Entries => - Called_Subp := RE_Initialize_Protection_Entries; + begin + case Pkg_Id is + when System_Tasking_Protected_Objects_Entries => + Called_Subp := RE_Initialize_Protection_Entries; - when System_Tasking_Protected_Objects => - Called_Subp := RE_Initialize_Protection; + -- Argument Compiler_Info - when System_Tasking_Protected_Objects_Single_Entry => - Called_Subp := RE_Initialize_Protection_Entry; - - when others => - raise Program_Error; - end case; - - if Has_Entry - or else not Restricted - or else Has_Interfaces (Protect_Rec) - then Append_To (Args, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Attribute_Name => Name_Address)); - end if; - -- Entry_Bodies parameter. This is a pointer to an array of - -- pointers to the entry body procedures and barrier functions - -- of the object. If the protected type has no entries this - -- object will not exist, in this case, pass a null. + when System_Tasking_Protected_Objects_Single_Entry => + Called_Subp := RE_Initialize_Protection_Entry; - if Has_Entry then - P_Arr := Entry_Bodies_Array (Ptyp); + -- Argument Compiler_Info Append_To (Args, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, Loc), + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + + when System_Tasking_Protected_Objects => + Called_Subp := RE_Initialize_Protection; + + when others => + raise Program_Error; + end case; + + -- Entry_Bodies parameter. This is a pointer to an array of + -- pointers to the entry body procedures and barrier functions of + -- the object. If the protected type has no entries this object + -- will not exist, in this case, pass a null (it can happen when + -- there are protected interrupt handlers or interfaces). + + if Has_Entry then + P_Arr := Entry_Bodies_Array (Ptyp); + + -- Argument Entry_Body (for single entry) or Entry_Bodies (for + -- multiple entries). + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + if Pkg_Id = System_Tasking_Protected_Objects_Entries then + + -- Find index mapping function (clumsy but ok for now) + + while Ekind (P_Arr) /= E_Function loop + Next_Entity (P_Arr); + end loop; + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), Attribute_Name => Name_Unrestricted_Access)); - - if Pkg_Id = System_Tasking_Protected_Objects_Entries then - - -- Find index mapping function (clumsy but ok for now) - - while Ekind (P_Arr) /= E_Function loop - Next_Entity (P_Arr); - end loop; - - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, Loc), - Attribute_Name => Name_Unrestricted_Access)); - end if; - - elsif Pkg_Id = - System_Tasking_Protected_Objects_Single_Entry - then - Append_To (Args, Make_Null (Loc)); - - elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then - Append_To (Args, Make_Null (Loc)); - Append_To (Args, Make_Null (Loc)); end if; - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (Called_Subp), Loc), - Parameter_Associations => Args)); - end; - else + elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then + -- This is the case where we have a protected object with + -- interfaces and no entries, and the single entry restriction + -- is in effect. We pass a null pointer for the entry + -- parameter because there is no actual entry. + + Append_To (Args, Make_Null (Loc)); + + elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then + -- This is the case where we have a protected object with no + -- entries and: + -- - either interrupt handlers with non restricted profile, + -- - or interfaces + -- Note that the types which are used for interrupt handlers + -- (Static/Dynamic_Interrupt_Protection) are derived from + -- Protection_Entries. We pass two null pointers because there + -- is no actual entry, and the initialization procedure needs + -- both Entry_Bodies and Find_Body_Index. + + Append_To (Args, Make_Null (Loc)); + Append_To (Args, Make_Null (Loc)); + end if; + Append_To (L, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), + Name => New_Reference_To (RTE (Called_Subp), Loc), Parameter_Associations => Args)); - end if; + end; end if; if Has_Attach_Handler (Ptyp) then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ca8bc9839ab4..795aaf417ad4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1631,10 +1631,15 @@ package body Exp_Util is -- node to recognize this case. or else Present (Interface_List (Parent (Typ))) - or else - (((Has_Attach_Handler (Typ) and then not Restricted_Profile) - or else Has_Interrupt_Handler (Typ)) - and then not Restriction_Active (No_Dynamic_Attachment)) + + -- Protected types with interrupt handlers (when not using a + -- restricted profile) are also considered equivalent to + -- protected types with entries. The types which are used + -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection) + -- are derived from Protection_Entries. + + or else (Has_Attach_Handler (Typ) and then not Restricted_Profile) + or else Has_Interrupt_Handler (Typ) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 6dfda7554d31..3c46f641adc8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8829,6 +8829,8 @@ kept in mind when considering efficiency. The @code{Update} attribute cannot be applied to prefixes of a limited type, and cannot reference discriminants in the case of a record type. +The accessibility level of an Update attribute result object is defined +as for an aggregate. In the record case, no component can be mentioned more than once. In the array case, two overlapping ranges can appear in the aggregate, diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index b058251bbe89..49065727c0ff 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21738,7 +21738,7 @@ end STB; @end smallexample @smallexample -$ gnatmake -g .\stb -bargs -E -largs -lgnat -laddr2line -lintl +$ gnatmake -g .\stb -bargs -E $ stb 0040149F in stb.p1 at stb.adb:8 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index dbae07551979..f9e23f7dd87c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1593,6 +1593,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- For case of address aspect, we don't consider that we + -- know the entity is never set in the source, since it is + -- is likely aliasing is occurring. + + -- Note: one might think that the analysis of the resulting + -- attribute definition clause would take care of that, but + -- that's not the case since it won't be from source. + + if A_Id = Aspect_Address then + Set_Never_Set_In_Source (E, False); + end if; + -- Construct the attribute definition clause Aitem := @@ -3474,7 +3486,8 @@ package body Sem_Ch13 is -- and alignment of the overlaying variable. We defer this -- check till after code generation to take full advantage -- of the annotation done by the back end. This entry is - -- only made if the address clause comes from source. + -- only made if the address clause comes from source or + -- from an aspect clause (which is still from source). -- If the entity has a generic type, the check will be -- performed in the instance if the actual type justifies @@ -3482,7 +3495,8 @@ package body Sem_Ch13 is -- prevent spurious warnings. if Address_Clause_Overlay_Warnings - and then Comes_From_Source (N) + and then (Comes_From_Source (N) + or else From_Aspect_Specification (N)) and then Present (O_Ent) and then Is_Object (O_Ent) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index dcad44f1bbae..db09d05de27c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8863,10 +8863,12 @@ package body Sem_Util is when N_Function_Call => return Etype (N) /= Standard_Void_Type; - -- Attributes 'Input and 'Result produce objects + -- Attributes 'Input, 'Old and 'Result produce objects when N_Attribute_Reference => - return Nam_In (Attribute_Name (N), Name_Input, Name_Result); + return + Nam_In + (Attribute_Name (N), Name_Input, Name_Old, Name_Result); when N_Selected_Component => return