From e5f2c03ceabe47ad4fc3162efb328508d74e78a6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 14:18:09 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Ed Schonberg * sem_prag.adb: Code clean up. 2015-10-20 Hristian Kirtchev * exp_ch6.adb (Expand_N_Extended_Return_Statement): Code cleanup. (Make_Build_In_Place_Call_In_Object_Declaration): Update the parameter profile. Code cleanup. Request debug info for the object renaming declaration. (Move_Activation_Chain): Add new formal parameter and update the comment on usage. * exp_ch6.ads (Make_Build_In_Place_Call_In_Object_Declaration): Update the parameter profile and comment on usage. * sem_util.ads, sem_util.adb (Remove_Overloaded_Entity): New routine, currently unused. From-SVN: r229067 --- gcc/ada/ChangeLog | 17 +++ gcc/ada/exp_ch6.adb | 291 +++++++++++++++++++++---------------------- gcc/ada/exp_ch6.ads | 2 +- gcc/ada/sem_prag.adb | 1 + gcc/ada/sem_util.adb | 100 +++++++++++++++ gcc/ada/sem_util.ads | 18 ++- 6 files changed, 272 insertions(+), 157 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ee17ba0c63..e32bac43c41 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2015-10-20 Ed Schonberg + + * sem_prag.adb: Code clean up. + +2015-10-20 Hristian Kirtchev + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Code cleanup. + (Make_Build_In_Place_Call_In_Object_Declaration): Update the + parameter profile. Code cleanup. Request debug info for the + object renaming declaration. + (Move_Activation_Chain): Add new formal parameter and update the + comment on usage. + * exp_ch6.ads (Make_Build_In_Place_Call_In_Object_Declaration): + Update the parameter profile and comment on usage. + * sem_util.ads, sem_util.adb (Remove_Overloaded_Entity): New routine, + currently unused. + 2015-10-20 Ed Schonberg * sem_ch13.adb (Analyze_One_Aspect, case diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index be7f72917e7..792208a3806 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3942,22 +3942,6 @@ package body Exp_Ch6 is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Par_Func : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Result_Subt : constant Entity_Id := Etype (Par_Func); - Ret_Obj_Id : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); - - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Par_Func); - - Exp : Node_Id; - HSS : Node_Id; - Result : Node_Id; - Return_Stmt : Node_Id; - Stmts : List_Id; - function Build_Heap_Allocator (Temp_Id : Entity_Id; Temp_Typ : Entity_Id; @@ -3991,12 +3975,15 @@ package body Exp_Ch6 is -- temporary. Func_Id is the enclosing function. Ret_Typ is the return -- type of Func_Id. Alloc_Expr is the actual allocator. - function Move_Activation_Chain return Node_Id; + function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain -- with parameters: -- From current activation chain -- To activation chain passed in by the caller -- New_Master master passed in by the caller + -- + -- Func_Id is the entity of the function where the extended return + -- statement appears. -------------------------- -- Build_Heap_Allocator -- @@ -4158,7 +4145,7 @@ package body Exp_Ch6 is -- Move_Activation_Chain -- --------------------------- - function Move_Activation_Chain return Node_Id is + function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is begin return Make_Procedure_Call_Statement (Loc, @@ -4176,14 +4163,31 @@ package body Exp_Ch6 is -- Destination chain New_Occurrence_Of - (Build_In_Place_Formal (Par_Func, BIP_Activation_Chain), Loc), + (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc), -- New master New_Occurrence_Of - (Build_In_Place_Formal (Par_Func, BIP_Task_Master), Loc))); + (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc))); end Move_Activation_Chain; + -- Local variables + + Func_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Is_BIP_Func : constant Boolean := + Is_Build_In_Place_Function (Func_Id); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + Ret_Typ : constant Entity_Id := Etype (Func_Id); + + Exp : Node_Id; + HSS : Node_Id; + Result : Node_Id; + Return_Stmt : Node_Id; + Stmts : List_Id; + -- Start of processing for Expand_N_Extended_Return_Statement begin @@ -4207,9 +4211,7 @@ package body Exp_Ch6 is -- with the scope finalizer. There is one flag per each return object -- in case of multiple returns. - if Is_Build_In_Place - and then Needs_Finalization (Etype (Ret_Obj_Id)) - then + if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then declare Flag_Decl : Node_Id; Flag_Id : Entity_Id; @@ -4218,7 +4220,7 @@ package body Exp_Ch6 is begin -- Recover the function body - Func_Bod := Unit_Declaration_Node (Par_Func); + Func_Bod := Unit_Declaration_Node (Func_Id); if Nkind (Func_Bod) = N_Subprogram_Declaration then Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); @@ -4253,7 +4255,7 @@ package body Exp_Ch6 is -- built in place (though we plan to do so eventually). if Present (HSS) - or else Is_Composite_Type (Result_Subt) + or else Is_Composite_Type (Ret_Typ) or else No (Exp) then if No (HSS) then @@ -4279,9 +4281,8 @@ package body Exp_Ch6 is -- result to be built in place, though that's necessarily true for -- the case of result types with task parts. - if Is_Build_In_Place - and then Has_Task (Result_Subt) - then + if Is_BIP_Func and then Has_Task (Ret_Typ) then + -- The return expression is an aggregate for a complex type which -- contains tasks. This particular case is left unexpanded since -- the regular expansion would insert all temporaries and @@ -4295,16 +4296,14 @@ package body Exp_Ch6 is -- contain tasks. if Has_Task (Etype (Ret_Obj_Id)) then - Append_To (Stmts, Move_Activation_Chain); + Append_To (Stmts, Move_Activation_Chain (Func_Id)); end if; end if; -- Update the state of the function right before the object is -- returned. - if Is_Build_In_Place - and then Needs_Finalization (Etype (Ret_Obj_Id)) - then + if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then declare Flag_Id : constant Entity_Id := Status_Flag_Or_Transient_Decl (Ret_Obj_Id); @@ -4354,7 +4353,7 @@ package body Exp_Ch6 is -- build-in-place function, and that function is responsible for -- the allocation of the return object. - if Is_Build_In_Place + if Is_BIP_Func and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration then pragma Assert @@ -4366,7 +4365,7 @@ package body Exp_Ch6 is Set_By_Ref (Return_Stmt); - elsif Is_Build_In_Place then + elsif Is_BIP_Func then -- Locate the implicit access parameter associated with the -- caller-supplied return object and convert the return @@ -4390,17 +4389,13 @@ package body Exp_Ch6 is -- ... declare - Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Ret_Obj_Decl); - Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); - Return_Obj_Expr : constant Node_Id := - Expression (Ret_Obj_Decl); - Constr_Result : constant Boolean := - Is_Constrained (Result_Subt); - Obj_Alloc_Formal : Entity_Id; - Object_Access : Entity_Id; - Obj_Acc_Deref : Node_Id; + Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl); + Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id); + Init_Assignment : Node_Id := Empty; + Obj_Acc_Formal : Entity_Id; + Obj_Acc_Deref : Node_Id; + Obj_Alloc_Formal : Entity_Id; begin -- Build-in-place results must be returned by reference @@ -4409,8 +4404,8 @@ package body Exp_Ch6 is -- Retrieve the implicit access parameter passed by the caller - Object_Access := - Build_In_Place_Formal (Par_Func, BIP_Object_Access); + Obj_Acc_Formal := + Build_In_Place_Formal (Func_Id, BIP_Object_Access); -- If the return object's declaration includes an expression -- and the declaration isn't marked as No_Initialization, then @@ -4428,16 +4423,16 @@ package body Exp_Ch6 is -- is a nonlimited descendant of a limited interface (the -- interface has no assignment operation). - if Present (Return_Obj_Expr) + if Present (Ret_Obj_Expr) and then not No_Initialization (Ret_Obj_Decl) - and then not Is_Interface (Return_Obj_Typ) + and then not Is_Interface (Ret_Obj_Typ) then Init_Assignment := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); + Name => New_Occurrence_Of (Ret_Obj_Id, Loc), + Expression => Relocate_Node (Ret_Obj_Expr)); - Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); Set_No_Ctrl_Actions (Init_Assignment); @@ -4446,14 +4441,14 @@ package body Exp_Ch6 is Set_Expression (Ret_Obj_Decl, Empty); - if Is_Class_Wide_Type (Etype (Return_Obj_Id)) + if Is_Class_Wide_Type (Etype (Ret_Obj_Id)) and then not Is_Class_Wide_Type (Etype (Expression (Init_Assignment))) then Rewrite (Expression (Init_Assignment), Make_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of (Etype (Return_Obj_Id), Loc), + New_Occurrence_Of (Etype (Ret_Obj_Id), Loc), Expression => Relocate_Node (Expression (Init_Assignment)))); end if; @@ -4464,8 +4459,8 @@ package body Exp_Ch6 is -- the different forms of allocation (this is true for -- unconstrained and tagged result subtypes). - if Constr_Result - and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) + if Is_Constrained (Ret_Typ) + and then not Is_Tagged_Type (Underlying_Type (Ret_Typ)) then Insert_After (Ret_Obj_Decl, Init_Assignment); end if; @@ -4490,11 +4485,11 @@ package body Exp_Ch6 is -- called in dispatching contexts and must be handled similarly -- to functions with a class-wide result. - if not Constr_Result - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) + if not Is_Constrained (Ret_Typ) + or else Is_Tagged_Type (Underlying_Type (Ret_Typ)) then Obj_Alloc_Formal := - Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); + Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); declare Pool_Id : constant Entity_Id := @@ -4529,7 +4524,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => - New_Occurrence_Of (Return_Obj_Typ, Loc))); + New_Occurrence_Of (Ret_Obj_Typ, Loc))); Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); @@ -4553,7 +4548,7 @@ package body Exp_Ch6 is -- global heap. If there's an initialization expression, -- then create these as initialized allocators. - if Present (Return_Obj_Expr) + if Present (Ret_Obj_Expr) and then not No_Initialization (Ret_Obj_Decl) then -- Always use the type of the expression for the @@ -4570,9 +4565,8 @@ package body Exp_Ch6 is Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of - (Etype (Return_Obj_Expr), Loc), - Expression => - New_Copy_Tree (Return_Obj_Expr))); + (Etype (Ret_Obj_Expr), Loc), + Expression => New_Copy_Tree (Ret_Obj_Expr))); else -- If the function returns a class-wide type we cannot @@ -4580,17 +4574,17 @@ package body Exp_Ch6 is -- use the type of the expression, which must be an -- aggregate of a definite type. - if Is_Class_Wide_Type (Return_Obj_Typ) then + if Is_Class_Wide_Type (Ret_Obj_Typ) then Heap_Allocator := Make_Allocator (Loc, Expression => New_Occurrence_Of - (Etype (Return_Obj_Expr), Loc)); + (Etype (Ret_Obj_Expr), Loc)); else Heap_Allocator := Make_Allocator (Loc, Expression => - New_Occurrence_Of (Return_Obj_Typ, Loc)); + New_Occurrence_Of (Ret_Obj_Typ, Loc)); end if; -- If the object requires default initialization then @@ -4622,7 +4616,7 @@ package body Exp_Ch6 is Make_Explicit_Dereference (Loc, New_Occurrence_Of (Build_In_Place_Formal - (Par_Func, BIP_Storage_Pool), Loc))); + (Func_Id, BIP_Storage_Pool), Loc))); Set_Storage_Pool (Pool_Allocator, Pool_Id); Set_Procedure_To_Call (Pool_Allocator, RTE (RE_Allocate_Any)); @@ -4675,10 +4669,10 @@ package body Exp_Ch6 is -- statement, past the point where these flags are -- normally set. - Set_Sec_Stack_Needed_For_Return (Par_Func); + Set_Sec_Stack_Needed_For_Return (Func_Id); Set_Sec_Stack_Needed_For_Return (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Par_Func); + Set_Uses_Sec_Stack (Func_Id); Set_Uses_Sec_Stack (Return_Statement_Entity (N)); -- Create an if statement to test the BIP_Alloc_Form @@ -4719,7 +4713,7 @@ package body Exp_Ch6 is Subtype_Mark => New_Occurrence_Of (Ref_Type, Loc), Expression => - New_Occurrence_Of (Object_Access, Loc)))), + New_Occurrence_Of (Obj_Acc_Formal, Loc)))), Elsif_Parts => New_List ( Make_Elsif_Part (Loc, @@ -4752,8 +4746,8 @@ package body Exp_Ch6 is Build_Heap_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, - Func_Id => Par_Func, - Ret_Typ => Return_Obj_Typ, + Func_Id => Func_Id, + Ret_Typ => Ret_Obj_Typ, Alloc_Expr => Heap_Allocator)))), Else_Statements => New_List ( @@ -4761,8 +4755,8 @@ package body Exp_Ch6 is Build_Heap_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, - Func_Id => Par_Func, - Ret_Typ => Return_Obj_Typ, + Func_Id => Func_Id, + Ret_Typ => Ret_Obj_Typ, Alloc_Expr => Pool_Allocator))); -- If a separate initialization assignment was created @@ -4778,8 +4772,7 @@ package body Exp_Ch6 is Make_Explicit_Dereference (Loc, Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); - Set_Etype - (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Append_To (Then_Statements (Alloc_If_Stmt), Init_Assignment); @@ -4790,7 +4783,7 @@ package body Exp_Ch6 is -- Remember the local access object for use in the -- dereference of the renaming created below. - Object_Access := Alloc_Obj_Id; + Obj_Acc_Formal := Alloc_Obj_Id; end; end if; @@ -4800,17 +4793,16 @@ package body Exp_Ch6 is Obj_Acc_Deref := Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Object_Access, Loc)); + Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); Rewrite (Ret_Obj_Decl, Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, + Defining_Identifier => Ret_Obj_Id, Access_Definition => Empty, - Subtype_Mark => - New_Occurrence_Of (Return_Obj_Typ, Loc), + Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc), Name => Obj_Acc_Deref)); - Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); + Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref); end; end if; @@ -8789,14 +8781,14 @@ package body Exp_Ch6 is ---------------------------------------------------- procedure Make_Build_In_Place_Call_In_Object_Declaration - (Object_Decl : Node_Id; + (Obj_Decl : Node_Id; Function_Call : Node_Id) is - Loc : Source_Ptr; - Obj_Def_Id : constant Entity_Id := - Defining_Identifier (Object_Decl); - Enclosing_Func : constant Entity_Id := - Enclosing_Subprogram (Obj_Def_Id); + Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); + Loc : constant Source_Ptr := Sloc (Function_Call); + Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); + Call_Deref : Node_Id; Caller_Object : Node_Id; Def_Id : Entity_Id; @@ -8835,8 +8827,6 @@ package body Exp_Ch6 is Set_Is_Expanded_Build_In_Place_Call (Func_Call); - Loc := Sloc (Function_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8878,11 +8868,11 @@ package body Exp_Ch6 is -- cause freezing. if Definite - and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) then - Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); + Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); else - Insert_Action (Object_Decl, Ptr_Typ_Decl); + Insert_Action (Obj_Decl, Ptr_Typ_Decl); end if; -- Force immediate freezing of Ptr_Typ because Res_Decl will be @@ -8907,18 +8897,18 @@ package body Exp_Ch6 is -- aggregate return object, when the call result should really be -- directly built in place in the aggregate and not in a temporary. ???) - if Is_Return_Object (Defining_Identifier (Object_Decl)) then + if Is_Return_Object (Defining_Identifier (Obj_Decl)) then Pass_Caller_Acc := True; -- When the enclosing function has a BIP_Alloc_Form formal then we -- pass it along to the callee (such as when the enclosing function -- has an unconstrained or tagged result type). - if Needs_BIP_Alloc_Form (Enclosing_Func) then + if Needs_BIP_Alloc_Form (Encl_Func) then if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Actual := - New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Storage_Pool), Loc); + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Storage_Pool), Loc); -- The build-in-place pool formal is not built on e.g. ZFP @@ -8931,8 +8921,7 @@ package body Exp_Ch6 is Function_Id => Function_Id, Alloc_Form_Exp => New_Occurrence_Of - (Build_In_Place_Formal - (Enclosing_Func, BIP_Alloc_Form), Loc), + (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), Pool_Actual => Pool_Actual); -- Otherwise, if enclosing function has a definite result subtype, @@ -8943,27 +8932,27 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; - if Needs_BIP_Finalization_Master (Enclosing_Func) then + if Needs_BIP_Finalization_Master (Encl_Func) then Fmaster_Actual := New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Finalization_Master), Loc); + (Encl_Func, BIP_Finalization_Master), Loc); end if; -- Retrieve the BIPacc formal from the enclosing function and convert -- it to the access type of the callee's BIP_Object_Access formal. Caller_Object := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype - (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), - Loc), - Expression => - New_Occurrence_Of - (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), - Loc)); + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype + (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), + Loc), + Expression => + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), + Loc)); -- In the definite case, add an implicit actual to the function call -- that provides access to the declared object. An unchecked conversion @@ -8990,7 +8979,7 @@ package body Exp_Ch6 is -- the secondary stack is destroyed after each library unload. This is -- a hybrid mechanism where a stack-allocated object lives on the heap. - elsif Is_Library_Level_Entity (Defining_Identifier (Object_Decl)) + elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl)) and then not Restriction_Active (No_Implicit_Heap_Allocations) then Add_Unconstrained_Actuals_To_Build_In_Place_Call @@ -9024,7 +9013,7 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); Caller_Object := Empty; - Establish_Transient_Scope (Object_Decl, Sec_Stack => True); + Establish_Transient_Scope (Obj_Decl, Sec_Stack => True); end if; -- Pass along any finalization master actual, which is needed in the @@ -9036,7 +9025,7 @@ package body Exp_Ch6 is Func_Id => Function_Id, Master_Exp => Fmaster_Actual); - if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement + if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) then -- Here we're passing along the master that was passed in to this @@ -9045,8 +9034,8 @@ package body Exp_Ch6 is Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Master_Actual => - New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Task_Master), Loc)); + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); else Add_Task_Actuals_To_Build_In_Place_Call @@ -9079,7 +9068,7 @@ package body Exp_Ch6 is -- the object as having no initialization. if Definite - and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) then -- The related object declaration is encased in a transient block -- because the build-in-place function call contains at least one @@ -9093,14 +9082,12 @@ package body Exp_Ch6 is -- which prompted the generation of the transient block. To resolve -- this scenario, store the build-in-place call. - if Scope_Is_Transient - and then Node_To_Be_Wrapped = Object_Decl - then + if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); end if; - Set_Expression (Object_Decl, Empty); - Set_No_Initialization (Object_Decl); + Set_Expression (Obj_Decl, Empty); + Set_No_Initialization (Obj_Decl); -- In case of an indefinite result subtype, or if the call is the -- return expression of an enclosing BIP function, rewrite the object @@ -9111,20 +9098,28 @@ package body Exp_Ch6 is else Call_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Def_Id, Loc)); - - Loc := Sloc (Object_Decl); - Rewrite (Object_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'D'), - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Make_Explicit_Dereference (Obj_Loc, + Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); + + Rewrite (Obj_Decl, + Make_Object_Renaming_Declaration (Obj_Loc, + Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc), Name => Call_Deref)); - Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); + Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); + + -- If the original entity comes from source, then mark the new + -- entity as needing debug information, even though it's defined + -- by a generated renaming that does not come from source, so that + -- the Materialize_Entity flag will be set on the entity when + -- Debug_Renaming_Declaration is called during analysis. + + if Comes_From_Source (Obj_Def_Id) then + Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); + end if; - Analyze (Object_Decl); + Analyze (Obj_Decl); -- Replace the internal identifier of the renaming declaration's -- entity with identifier of the original object entity. We also have @@ -9138,31 +9133,27 @@ package body Exp_Ch6 is -- corrupted. Finally, the homonym chain must be preserved as well. declare - Renaming_Def_Id : constant Entity_Id := - Defining_Identifier (Object_Decl); - Next_Entity_Temp : constant Entity_Id := - Next_Entity (Renaming_Def_Id); + Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Next_Id : constant Entity_Id := Next_Entity (Ren_Id); + begin - Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); + Set_Chars (Ren_Id, Chars (Obj_Def_Id)); -- Swap next entity links in preparation for exchanging entities - Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); - Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); - Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); + Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id)); + Set_Next_Entity (Obj_Def_Id, Next_Id); + Set_Homonym (Ren_Id, Homonym (Obj_Def_Id)); - Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); + Exchange_Entities (Ren_Id, Obj_Def_Id); -- Preserve source indication of original declaration, so that -- xref information is properly generated for the right entity. - Preserve_Comes_From_Source - (Object_Decl, Original_Node (Object_Decl)); - - Preserve_Comes_From_Source - (Obj_Def_Id, Original_Node (Object_Decl)); + Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl)); + Preserve_Comes_From_Source (Obj_Def_Id, Original_Node (Obj_Decl)); - Set_Comes_From_Source (Renaming_Def_Id, False); + Set_Comes_From_Source (Ren_Id, False); end; end if; @@ -9174,8 +9165,8 @@ package body Exp_Ch6 is -- improve this treatment when build-in-place functions with class-wide -- results are implemented. ??? - if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then - Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); + if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then + Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt); end if; end Make_Build_In_Place_Call_In_Object_Declaration; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 5cbcc965cf4..1cc993f509e 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -178,7 +178,7 @@ package Exp_Ch6 is -- call. procedure Make_Build_In_Place_Call_In_Object_Declaration - (Object_Decl : Node_Id; + (Obj_Decl : Node_Id; Function_Call : Node_Id); -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that -- occurs as the expression initializing an object declaration by diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 149c7798bcf..fa00f620506 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -25211,6 +25211,7 @@ package body Sem_Prag is Root_Typ := Etype (F); if Is_Access_Type (Etype (F)) then + Root_Typ := Designated_Type (Root_Typ); New_Typ := Make_Defining_Identifier (Loc, Chars => diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e0c857b1177..a6eb50c52b7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16961,6 +16961,106 @@ package body Sem_Util is end if; end Remove_Homonym; + ------------------------------ + -- Remove_Overloaded_Entity -- + ------------------------------ + + procedure Remove_Overloaded_Entity (Id : Entity_Id) is + procedure Remove_Primitive_Of (Typ : Entity_Id); + -- Remove primitive subprogram Id from the list of primitives that + -- belong to type Typ. + + ------------------------- + -- Remove_Primitive_Of -- + ------------------------- + + procedure Remove_Primitive_Of (Typ : Entity_Id) is + Prims : Elist_Id; + + begin + if Is_Tagged_Type (Typ) then + Prims := Direct_Primitive_Operations (Typ); + + if Present (Prims) then + Remove (Prims, Id); + end if; + end if; + end Remove_Primitive_Of; + + -- Local variables + + Scop : constant Entity_Id := Scope (Id); + Formal : Entity_Id; + Prev_Id : Entity_Id; + + -- Start of processing for Remove_Overloaded_Entity + + begin + -- Remove the entity from the homonym chain. When the entity is the + -- head of the chain, associate the entry in the name table with its + -- homonym effectively making it the new head of the chain. + + if Current_Entity (Id) = Id then + Set_Name_Entity_Id (Chars (Id), Homonym (Id)); + + -- Otherwise link the previous and next homonyms + + else + Prev_Id := Current_Entity (Id); + while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop + Prev_Id := Homonym (Prev_Id); + end loop; + + Set_Homonym (Prev_Id, Homonym (Id)); + end if; + + -- Remove the entity from the scope entity chain. When the entity is + -- the head of the chain, set the next entity as the new head of the + -- chain. + + if First_Entity (Scop) = Id then + Prev_Id := Empty; + Set_First_Entity (Scop, Next_Entity (Id)); + + -- Otherwise the entity is either in the middle of the chain or it acts + -- as its tail. Traverse and link the previous and next entities. + + else + Prev_Id := First_Entity (Scop); + while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop + Next_Entity (Prev_Id); + end loop; + + Set_Next_Entity (Prev_Id, Next_Entity (Id)); + end if; + + -- Handle the case where the entity acts as the tail of the scope entity + -- chain. + + if Last_Entity (Scop) = Id then + Set_Last_Entity (Scop, Prev_Id); + end if; + + -- The entity denotes a primitive subprogram. Remove it from the list of + -- primitives of the associated controlling type. + + if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then + Formal := First_Formal (Id); + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Remove_Primitive_Of (Etype (Formal)); + exit; + end if; + + Next_Formal (Formal); + end loop; + + if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then + Remove_Primitive_Of (Etype (Id)); + end if; + end if; + end Remove_Overloaded_Entity; + --------------------- -- Rep_To_Pos_Flag -- --------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 872bdedf388..c0bf234ce70 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1781,12 +1781,6 @@ package Sem_Util is -- convenience, qualified expressions applied to object names are also -- allowed as actuals for this function. - function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; - -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, - -- or overrides an inherited dispatching primitive S2, the original - -- corresponding operation of S is the original corresponding operation of - -- S2. Otherwise, it is S itself. - function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id; -- Retrieve the name of aspect or pragma N taking into account a possible -- rewrite and whether the pragma is generated from an aspect as the names @@ -1799,6 +1793,12 @@ package Sem_Util is -- Type_Invariant -> Name_uType_Invariant -- Type_Invariant'Class -> Name_uType_Invariant + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; + -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, + -- or overrides an inherited dispatching primitive S2, the original + -- corresponding operation of S is the original corresponding operation of + -- S2. Otherwise, it is S itself. + function Policy_In_Effect (Policy : Name_Id) return Name_Id; -- Given a policy, return the policy identifier associated with it. If no -- such policy is in effect, the value returned is No_Name. @@ -1845,6 +1845,12 @@ package Sem_Util is procedure Remove_Homonym (E : Entity_Id); -- Removes E from the homonym chain + procedure Remove_Overloaded_Entity (Id : Entity_Id); + -- Remove arbitrary entity Id from the homonym chain, the scope chain and + -- the primitive operations list of the associated controlling type. NOTE: + -- the removal performed by this routine does not affect the visibility of + -- existing homonyms. + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id; -- This is used to construct the second argument in a call to Rep_To_Pos -- which is Standard_True if range checks are enabled (E is an entity to -- 2.30.2