Skip to content

R
riscv-gcc-1
Commit e5f2c03c by Arnaud Charlet
Options

[multiple changes] 

2015-10-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb: Code clean up.

2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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
parent 58ef3d30
Showing with 272 additions and 157 deletions
gcc/ada/ChangeLog
2015-10-20 Ed Schonberg <schonberg@adacore.com> 2015-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb: Code clean up.
2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <schonberg@adacore.com>
* sem_ch13.adb (Analyze_One_Aspect, case * sem_ch13.adb (Analyze_One_Aspect, case
Aspect_Disable_Controlled): If expander is not active, pre-analyze Aspect_Disable_Controlled): If expander is not active, pre-analyze
expression anyway for ASIS and other tools use. expression anyway for ASIS and other tools use.
......
gcc/ada/exp_ch6.adb
...@@ -3942,22 +3942,6 @@ package body Exp_Ch6 is ...@@ -3942,22 +3942,6 @@ package body Exp_Ch6 is
procedure Expand_N_Extended_Return_Statement (N : Node_Id) is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); 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 function Build_Heap_Allocator
(Temp_Id : Entity_Id; (Temp_Id : Entity_Id;
Temp_Typ : Entity_Id; Temp_Typ : Entity_Id;
...@@ -3991,12 +3975,15 @@ package body Exp_Ch6 is ...@@ -3991,12 +3975,15 @@ package body Exp_Ch6 is
-- temporary. Func_Id is the enclosing function. Ret_Typ is the return -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
-- type of Func_Id. Alloc_Expr is the actual allocator. -- 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 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
-- with parameters: -- with parameters:
-- From current activation chain -- From current activation chain
-- To activation chain passed in by the caller -- To activation chain passed in by the caller
-- New_Master master 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 -- -- Build_Heap_Allocator --
...@@ -4158,7 +4145,7 @@ package body Exp_Ch6 is ...@@ -4158,7 +4145,7 @@ package body Exp_Ch6 is
-- Move_Activation_Chain -- -- Move_Activation_Chain --
--------------------------- ---------------------------
function Move_Activation_Chain return Node_Id is function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is
begin begin
return return
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
...@@ -4176,14 +4163,31 @@ package body Exp_Ch6 is ...@@ -4176,14 +4163,31 @@ package body Exp_Ch6 is
-- Destination chain -- Destination chain
New_Occurrence_Of 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 master
New_Occurrence_Of 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; 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 -- Start of processing for Expand_N_Extended_Return_Statement
begin begin
...@@ -4207,9 +4211,7 @@ package body Exp_Ch6 is ...@@ -4207,9 +4211,7 @@ package body Exp_Ch6 is
-- with the scope finalizer. There is one flag per each return object -- with the scope finalizer. There is one flag per each return object
-- in case of multiple returns. -- in case of multiple returns.
if Is_Build_In_Place if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
and then Needs_Finalization (Etype (Ret_Obj_Id))
then
declare declare
Flag_Decl : Node_Id; Flag_Decl : Node_Id;
Flag_Id : Entity_Id; Flag_Id : Entity_Id;
...@@ -4218,7 +4220,7 @@ package body Exp_Ch6 is ...@@ -4218,7 +4220,7 @@ package body Exp_Ch6 is
begin begin
-- Recover the function body -- 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 if Nkind (Func_Bod) = N_Subprogram_Declaration then
Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
...@@ -4253,7 +4255,7 @@ package body Exp_Ch6 is ...@@ -4253,7 +4255,7 @@ package body Exp_Ch6 is
-- built in place (though we plan to do so eventually). -- built in place (though we plan to do so eventually).
if Present (HSS) if Present (HSS)
or else Is_Composite_Type (Result_Subt) or else Is_Composite_Type (Ret_Typ)
or else No (Exp) or else No (Exp)
then then
if No (HSS) then if No (HSS) then
...@@ -4279,9 +4281,8 @@ package body Exp_Ch6 is ...@@ -4279,9 +4281,8 @@ package body Exp_Ch6 is
-- result to be built in place, though that's necessarily true for -- result to be built in place, though that's necessarily true for
-- the case of result types with task parts. -- the case of result types with task parts.
if Is_Build_In_Place if Is_BIP_Func and then Has_Task (Ret_Typ) then
and then Has_Task (Result_Subt)
then
-- The return expression is an aggregate for a complex type which -- The return expression is an aggregate for a complex type which
-- contains tasks. This particular case is left unexpanded since -- contains tasks. This particular case is left unexpanded since
-- the regular expansion would insert all temporaries and -- the regular expansion would insert all temporaries and
...@@ -4295,16 +4296,14 @@ package body Exp_Ch6 is ...@@ -4295,16 +4296,14 @@ package body Exp_Ch6 is
-- contain tasks. -- contain tasks.
if Has_Task (Etype (Ret_Obj_Id)) then 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;
end if; end if;
-- Update the state of the function right before the object is -- Update the state of the function right before the object is
-- returned. -- returned.
if Is_Build_In_Place if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then
and then Needs_Finalization (Etype (Ret_Obj_Id))
then
declare declare
Flag_Id : constant Entity_Id := Flag_Id : constant Entity_Id :=
Status_Flag_Or_Transient_Decl (Ret_Obj_Id); Status_Flag_Or_Transient_Decl (Ret_Obj_Id);
...@@ -4354,7 +4353,7 @@ package body Exp_Ch6 is ...@@ -4354,7 +4353,7 @@ package body Exp_Ch6 is
-- build-in-place function, and that function is responsible for -- build-in-place function, and that function is responsible for
-- the allocation of the return object. -- 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 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
then then
pragma Assert pragma Assert
...@@ -4366,7 +4365,7 @@ package body Exp_Ch6 is ...@@ -4366,7 +4365,7 @@ package body Exp_Ch6 is
Set_By_Ref (Return_Stmt); Set_By_Ref (Return_Stmt);
elsif Is_Build_In_Place then elsif Is_BIP_Func then
-- Locate the implicit access parameter associated with the -- Locate the implicit access parameter associated with the
-- caller-supplied return object and convert the return -- caller-supplied return object and convert the return
...@@ -4390,17 +4389,13 @@ package body Exp_Ch6 is ...@@ -4390,17 +4389,13 @@ package body Exp_Ch6 is
-- ... -- ...
declare declare
Return_Obj_Id : constant Entity_Id := Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
Defining_Identifier (Ret_Obj_Decl); Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
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;
Init_Assignment : Node_Id := Empty; Init_Assignment : Node_Id := Empty;
Obj_Acc_Formal : Entity_Id;
Obj_Acc_Deref : Node_Id;
Obj_Alloc_Formal : Entity_Id;
begin begin
-- Build-in-place results must be returned by reference -- Build-in-place results must be returned by reference
...@@ -4409,8 +4404,8 @@ package body Exp_Ch6 is ...@@ -4409,8 +4404,8 @@ package body Exp_Ch6 is
-- Retrieve the implicit access parameter passed by the caller -- Retrieve the implicit access parameter passed by the caller
Object_Access := Obj_Acc_Formal :=
Build_In_Place_Formal (Par_Func, BIP_Object_Access); Build_In_Place_Formal (Func_Id, BIP_Object_Access);
-- If the return object's declaration includes an expression -- If the return object's declaration includes an expression
-- and the declaration isn't marked as No_Initialization, then -- and the declaration isn't marked as No_Initialization, then
...@@ -4428,16 +4423,16 @@ package body Exp_Ch6 is ...@@ -4428,16 +4423,16 @@ package body Exp_Ch6 is
-- is a nonlimited descendant of a limited interface (the -- is a nonlimited descendant of a limited interface (the
-- interface has no assignment operation). -- 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 No_Initialization (Ret_Obj_Decl)
and then not Is_Interface (Return_Obj_Typ) and then not Is_Interface (Ret_Obj_Typ)
then then
Init_Assignment := Init_Assignment :=
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Return_Obj_Id, Loc), Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
Expression => Relocate_Node (Return_Obj_Expr)); 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_Assignment_OK (Name (Init_Assignment));
Set_No_Ctrl_Actions (Init_Assignment); Set_No_Ctrl_Actions (Init_Assignment);
...@@ -4446,14 +4441,14 @@ package body Exp_Ch6 is ...@@ -4446,14 +4441,14 @@ package body Exp_Ch6 is
Set_Expression (Ret_Obj_Decl, Empty); 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 and then not Is_Class_Wide_Type
(Etype (Expression (Init_Assignment))) (Etype (Expression (Init_Assignment)))
then then
Rewrite (Expression (Init_Assignment), Rewrite (Expression (Init_Assignment),
Make_Type_Conversion (Loc, Make_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Etype (Return_Obj_Id), Loc), New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
Expression => Expression =>
Relocate_Node (Expression (Init_Assignment)))); Relocate_Node (Expression (Init_Assignment))));
end if; end if;
...@@ -4464,8 +4459,8 @@ package body Exp_Ch6 is ...@@ -4464,8 +4459,8 @@ package body Exp_Ch6 is
-- the different forms of allocation (this is true for -- the different forms of allocation (this is true for
-- unconstrained and tagged result subtypes). -- unconstrained and tagged result subtypes).
if Constr_Result if Is_Constrained (Ret_Typ)
and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) and then not Is_Tagged_Type (Underlying_Type (Ret_Typ))
then then
Insert_After (Ret_Obj_Decl, Init_Assignment); Insert_After (Ret_Obj_Decl, Init_Assignment);
end if; end if;
...@@ -4490,11 +4485,11 @@ package body Exp_Ch6 is ...@@ -4490,11 +4485,11 @@ package body Exp_Ch6 is
-- called in dispatching contexts and must be handled similarly -- called in dispatching contexts and must be handled similarly
-- to functions with a class-wide result. -- to functions with a class-wide result.
if not Constr_Result if not Is_Constrained (Ret_Typ)
or else Is_Tagged_Type (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
then then
Obj_Alloc_Formal := Obj_Alloc_Formal :=
Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
declare declare
Pool_Id : constant Entity_Id := Pool_Id : constant Entity_Id :=
...@@ -4529,7 +4524,7 @@ package body Exp_Ch6 is ...@@ -4529,7 +4524,7 @@ package body Exp_Ch6 is
Make_Access_To_Object_Definition (Loc, Make_Access_To_Object_Definition (Loc,
All_Present => True, All_Present => True,
Subtype_Indication => Subtype_Indication =>
New_Occurrence_Of (Return_Obj_Typ, Loc))); New_Occurrence_Of (Ret_Obj_Typ, Loc)));
Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
...@@ -4553,7 +4548,7 @@ package body Exp_Ch6 is ...@@ -4553,7 +4548,7 @@ package body Exp_Ch6 is
-- global heap. If there's an initialization expression, -- global heap. If there's an initialization expression,
-- then create these as initialized allocators. -- then create these as initialized allocators.
if Present (Return_Obj_Expr) if Present (Ret_Obj_Expr)
and then not No_Initialization (Ret_Obj_Decl) and then not No_Initialization (Ret_Obj_Decl)
then then
-- Always use the type of the expression for the -- Always use the type of the expression for the
...@@ -4570,9 +4565,8 @@ package body Exp_Ch6 is ...@@ -4570,9 +4565,8 @@ package body Exp_Ch6 is
Make_Qualified_Expression (Loc, Make_Qualified_Expression (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of New_Occurrence_Of
(Etype (Return_Obj_Expr), Loc), (Etype (Ret_Obj_Expr), Loc),
Expression => Expression => New_Copy_Tree (Ret_Obj_Expr)));
New_Copy_Tree (Return_Obj_Expr)));
else else
-- If the function returns a class-wide type we cannot -- If the function returns a class-wide type we cannot
...@@ -4580,17 +4574,17 @@ package body Exp_Ch6 is ...@@ -4580,17 +4574,17 @@ package body Exp_Ch6 is
-- use the type of the expression, which must be an -- use the type of the expression, which must be an
-- aggregate of a definite type. -- 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 := Heap_Allocator :=
Make_Allocator (Loc, Make_Allocator (Loc,
Expression => Expression =>
New_Occurrence_Of New_Occurrence_Of
(Etype (Return_Obj_Expr), Loc)); (Etype (Ret_Obj_Expr), Loc));
else else
Heap_Allocator := Heap_Allocator :=
Make_Allocator (Loc, Make_Allocator (Loc,
Expression => Expression =>
New_Occurrence_Of (Return_Obj_Typ, Loc)); New_Occurrence_Of (Ret_Obj_Typ, Loc));
end if; end if;
-- If the object requires default initialization then -- If the object requires default initialization then
...@@ -4622,7 +4616,7 @@ package body Exp_Ch6 is ...@@ -4622,7 +4616,7 @@ package body Exp_Ch6 is
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
New_Occurrence_Of New_Occurrence_Of
(Build_In_Place_Formal (Build_In_Place_Formal
(Par_Func, BIP_Storage_Pool), Loc))); (Func_Id, BIP_Storage_Pool), Loc)));
Set_Storage_Pool (Pool_Allocator, Pool_Id); Set_Storage_Pool (Pool_Allocator, Pool_Id);
Set_Procedure_To_Call Set_Procedure_To_Call
(Pool_Allocator, RTE (RE_Allocate_Any)); (Pool_Allocator, RTE (RE_Allocate_Any));
...@@ -4675,10 +4669,10 @@ package body Exp_Ch6 is ...@@ -4675,10 +4669,10 @@ package body Exp_Ch6 is
-- statement, past the point where these flags are -- statement, past the point where these flags are
-- normally set. -- normally set.
Set_Sec_Stack_Needed_For_Return (Par_Func); Set_Sec_Stack_Needed_For_Return (Func_Id);
Set_Sec_Stack_Needed_For_Return Set_Sec_Stack_Needed_For_Return
(Return_Statement_Entity (N)); (Return_Statement_Entity (N));
Set_Uses_Sec_Stack (Par_Func); Set_Uses_Sec_Stack (Func_Id);
Set_Uses_Sec_Stack (Return_Statement_Entity (N)); Set_Uses_Sec_Stack (Return_Statement_Entity (N));
-- Create an if statement to test the BIP_Alloc_Form -- Create an if statement to test the BIP_Alloc_Form
...@@ -4719,7 +4713,7 @@ package body Exp_Ch6 is ...@@ -4719,7 +4713,7 @@ package body Exp_Ch6 is
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Ref_Type, Loc), New_Occurrence_Of (Ref_Type, Loc),
Expression => Expression =>
New_Occurrence_Of (Object_Access, Loc)))), New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
Elsif_Parts => New_List ( Elsif_Parts => New_List (
Make_Elsif_Part (Loc, Make_Elsif_Part (Loc,
...@@ -4752,8 +4746,8 @@ package body Exp_Ch6 is ...@@ -4752,8 +4746,8 @@ package body Exp_Ch6 is
Build_Heap_Allocator Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id, (Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type, Temp_Typ => Ref_Type,
Func_Id => Par_Func, Func_Id => Func_Id,
Ret_Typ => Return_Obj_Typ, Ret_Typ => Ret_Obj_Typ,
Alloc_Expr => Heap_Allocator)))), Alloc_Expr => Heap_Allocator)))),
Else_Statements => New_List ( Else_Statements => New_List (
...@@ -4761,8 +4755,8 @@ package body Exp_Ch6 is ...@@ -4761,8 +4755,8 @@ package body Exp_Ch6 is
Build_Heap_Allocator Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id, (Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type, Temp_Typ => Ref_Type,
Func_Id => Par_Func, Func_Id => Func_Id,
Ret_Typ => Return_Obj_Typ, Ret_Typ => Ret_Obj_Typ,
Alloc_Expr => Pool_Allocator))); Alloc_Expr => Pool_Allocator)));
-- If a separate initialization assignment was created -- If a separate initialization assignment was created
...@@ -4778,8 +4772,7 @@ package body Exp_Ch6 is ...@@ -4778,8 +4772,7 @@ package body Exp_Ch6 is
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
Set_Etype Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
(Name (Init_Assignment), Etype (Return_Obj_Id));
Append_To Append_To
(Then_Statements (Alloc_If_Stmt), Init_Assignment); (Then_Statements (Alloc_If_Stmt), Init_Assignment);
...@@ -4790,7 +4783,7 @@ package body Exp_Ch6 is ...@@ -4790,7 +4783,7 @@ package body Exp_Ch6 is
-- Remember the local access object for use in the -- Remember the local access object for use in the
-- dereference of the renaming created below. -- dereference of the renaming created below.
Object_Access := Alloc_Obj_Id; Obj_Acc_Formal := Alloc_Obj_Id;
end; end;
end if; end if;
...@@ -4800,17 +4793,16 @@ package body Exp_Ch6 is ...@@ -4800,17 +4793,16 @@ package body Exp_Ch6 is
Obj_Acc_Deref := Obj_Acc_Deref :=
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Object_Access, Loc)); Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
Rewrite (Ret_Obj_Decl, Rewrite (Ret_Obj_Decl,
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Return_Obj_Id, Defining_Identifier => Ret_Obj_Id,
Access_Definition => Empty, Access_Definition => Empty,
Subtype_Mark => Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
New_Occurrence_Of (Return_Obj_Typ, Loc),
Name => Obj_Acc_Deref)); Name => Obj_Acc_Deref));
Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
end; end;
end if; end if;
...@@ -8789,14 +8781,14 @@ package body Exp_Ch6 is ...@@ -8789,14 +8781,14 @@ package body Exp_Ch6 is
---------------------------------------------------- ----------------------------------------------------
procedure Make_Build_In_Place_Call_In_Object_Declaration procedure Make_Build_In_Place_Call_In_Object_Declaration
(Object_Decl : Node_Id; (Obj_Decl : Node_Id;
Function_Call : Node_Id) Function_Call : Node_Id)
is is
Loc : Source_Ptr; Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
Obj_Def_Id : constant Entity_Id := Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id);
Defining_Identifier (Object_Decl); Loc : constant Source_Ptr := Sloc (Function_Call);
Enclosing_Func : constant Entity_Id := Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl);
Enclosing_Subprogram (Obj_Def_Id);
Call_Deref : Node_Id; Call_Deref : Node_Id;
Caller_Object : Node_Id; Caller_Object : Node_Id;
Def_Id : Entity_Id; Def_Id : Entity_Id;
...@@ -8835,8 +8827,6 @@ package body Exp_Ch6 is ...@@ -8835,8 +8827,6 @@ package body Exp_Ch6 is
Set_Is_Expanded_Build_In_Place_Call (Func_Call); Set_Is_Expanded_Build_In_Place_Call (Func_Call);
Loc := Sloc (Function_Call);
if Is_Entity_Name (Name (Func_Call)) then if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call)); Function_Id := Entity (Name (Func_Call));
...@@ -8878,11 +8868,11 @@ package body Exp_Ch6 is ...@@ -8878,11 +8868,11 @@ package body Exp_Ch6 is
-- cause freezing. -- cause freezing.
if Definite if Definite
and then not Is_Return_Object (Defining_Identifier (Object_Decl)) and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
then then
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl);
else else
Insert_Action (Object_Decl, Ptr_Typ_Decl); Insert_Action (Obj_Decl, Ptr_Typ_Decl);
end if; end if;
-- Force immediate freezing of Ptr_Typ because Res_Decl will be -- Force immediate freezing of Ptr_Typ because Res_Decl will be
...@@ -8907,18 +8897,18 @@ package body Exp_Ch6 is ...@@ -8907,18 +8897,18 @@ package body Exp_Ch6 is
-- aggregate return object, when the call result should really be -- aggregate return object, when the call result should really be
-- directly built in place in the aggregate and not in a temporary. ???) -- 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; Pass_Caller_Acc := True;
-- When the enclosing function has a BIP_Alloc_Form formal then we -- When the enclosing function has a BIP_Alloc_Form formal then we
-- pass it along to the callee (such as when the enclosing function -- pass it along to the callee (such as when the enclosing function
-- has an unconstrained or tagged result type). -- 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 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
Pool_Actual := Pool_Actual :=
New_Occurrence_Of (Build_In_Place_Formal New_Occurrence_Of
(Enclosing_Func, BIP_Storage_Pool), Loc); (Build_In_Place_Formal (Encl_Func, BIP_Storage_Pool), Loc);
-- The build-in-place pool formal is not built on e.g. ZFP -- The build-in-place pool formal is not built on e.g. ZFP
...@@ -8931,8 +8921,7 @@ package body Exp_Ch6 is ...@@ -8931,8 +8921,7 @@ package body Exp_Ch6 is
Function_Id => Function_Id, Function_Id => Function_Id,
Alloc_Form_Exp => Alloc_Form_Exp =>
New_Occurrence_Of New_Occurrence_Of
(Build_In_Place_Formal (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc),
(Enclosing_Func, BIP_Alloc_Form), Loc),
Pool_Actual => Pool_Actual); Pool_Actual => Pool_Actual);
-- Otherwise, if enclosing function has a definite result subtype, -- Otherwise, if enclosing function has a definite result subtype,
...@@ -8943,27 +8932,27 @@ package body Exp_Ch6 is ...@@ -8943,27 +8932,27 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation); (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if; end if;
if Needs_BIP_Finalization_Master (Enclosing_Func) then if Needs_BIP_Finalization_Master (Encl_Func) then
Fmaster_Actual := Fmaster_Actual :=
New_Occurrence_Of New_Occurrence_Of
(Build_In_Place_Formal (Build_In_Place_Formal
(Enclosing_Func, BIP_Finalization_Master), Loc); (Encl_Func, BIP_Finalization_Master), Loc);
end if; end if;
-- Retrieve the BIPacc formal from the enclosing function and convert -- Retrieve the BIPacc formal from the enclosing function and convert
-- it to the access type of the callee's BIP_Object_Access formal. -- it to the access type of the callee's BIP_Object_Access formal.
Caller_Object := Caller_Object :=
Make_Unchecked_Type_Conversion (Loc, Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of New_Occurrence_Of
(Etype (Etype
(Build_In_Place_Formal (Function_Id, BIP_Object_Access)), (Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
Loc), Loc),
Expression => Expression =>
New_Occurrence_Of New_Occurrence_Of
(Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
Loc)); Loc));
-- In the definite case, add an implicit actual to the function call -- In the definite case, add an implicit actual to the function call
-- that provides access to the declared object. An unchecked conversion -- that provides access to the declared object. An unchecked conversion
...@@ -8990,7 +8979,7 @@ package body Exp_Ch6 is ...@@ -8990,7 +8979,7 @@ package body Exp_Ch6 is
-- the secondary stack is destroyed after each library unload. This is -- the secondary stack is destroyed after each library unload. This is
-- a hybrid mechanism where a stack-allocated object lives on the heap. -- 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) and then not Restriction_Active (No_Implicit_Heap_Allocations)
then then
Add_Unconstrained_Actuals_To_Build_In_Place_Call Add_Unconstrained_Actuals_To_Build_In_Place_Call
...@@ -9024,7 +9013,7 @@ package body Exp_Ch6 is ...@@ -9024,7 +9013,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack); (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Caller_Object := Empty; Caller_Object := Empty;
Establish_Transient_Scope (Object_Decl, Sec_Stack => True); Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
end if; end if;
-- Pass along any finalization master actual, which is needed in the -- Pass along any finalization master actual, which is needed in the
...@@ -9036,7 +9025,7 @@ package body Exp_Ch6 is ...@@ -9036,7 +9025,7 @@ package body Exp_Ch6 is
Func_Id => Function_Id, Func_Id => Function_Id,
Master_Exp => Fmaster_Actual); 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) and then Has_Task (Result_Subt)
then then
-- Here we're passing along the master that was passed in to this -- Here we're passing along the master that was passed in to this
...@@ -9045,8 +9034,8 @@ package body Exp_Ch6 is ...@@ -9045,8 +9034,8 @@ package body Exp_Ch6 is
Add_Task_Actuals_To_Build_In_Place_Call Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, (Func_Call, Function_Id,
Master_Actual => Master_Actual =>
New_Occurrence_Of (Build_In_Place_Formal New_Occurrence_Of
(Enclosing_Func, BIP_Task_Master), Loc)); (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc));
else else
Add_Task_Actuals_To_Build_In_Place_Call Add_Task_Actuals_To_Build_In_Place_Call
...@@ -9079,7 +9068,7 @@ package body Exp_Ch6 is ...@@ -9079,7 +9068,7 @@ package body Exp_Ch6 is
-- the object as having no initialization. -- the object as having no initialization.
if Definite if Definite
and then not Is_Return_Object (Defining_Identifier (Object_Decl)) and then not Is_Return_Object (Defining_Identifier (Obj_Decl))
then then
-- The related object declaration is encased in a transient block -- The related object declaration is encased in a transient block
-- because the build-in-place function call contains at least one -- because the build-in-place function call contains at least one
...@@ -9093,14 +9082,12 @@ package body Exp_Ch6 is ...@@ -9093,14 +9082,12 @@ package body Exp_Ch6 is
-- which prompted the generation of the transient block. To resolve -- which prompted the generation of the transient block. To resolve
-- this scenario, store the build-in-place call. -- this scenario, store the build-in-place call.
if Scope_Is_Transient if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then
and then Node_To_Be_Wrapped = Object_Decl
then
Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl);
end if; end if;
Set_Expression (Object_Decl, Empty); Set_Expression (Obj_Decl, Empty);
Set_No_Initialization (Object_Decl); Set_No_Initialization (Obj_Decl);
-- In case of an indefinite result subtype, or if the call is the -- In case of an indefinite result subtype, or if the call is the
-- return expression of an enclosing BIP function, rewrite the object -- return expression of an enclosing BIP function, rewrite the object
...@@ -9111,20 +9098,28 @@ package body Exp_Ch6 is ...@@ -9111,20 +9098,28 @@ package body Exp_Ch6 is
else else
Call_Deref := Call_Deref :=
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Obj_Loc,
Prefix => New_Occurrence_Of (Def_Id, Loc)); Prefix => New_Occurrence_Of (Def_Id, Obj_Loc));
Loc := Sloc (Object_Decl); Rewrite (Obj_Decl,
Rewrite (Object_Decl, Make_Object_Renaming_Declaration (Obj_Loc,
Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
Defining_Identifier => Make_Temporary (Loc, 'D'), Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc),
Access_Definition => Empty,
Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
Name => Call_Deref)); 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 -- Replace the internal identifier of the renaming declaration's
-- entity with identifier of the original object entity. We also have -- entity with identifier of the original object entity. We also have
...@@ -9138,31 +9133,27 @@ package body Exp_Ch6 is ...@@ -9138,31 +9133,27 @@ package body Exp_Ch6 is
-- corrupted. Finally, the homonym chain must be preserved as well. -- corrupted. Finally, the homonym chain must be preserved as well.
declare declare
Renaming_Def_Id : constant Entity_Id := Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
Defining_Identifier (Object_Decl); Next_Id : constant Entity_Id := Next_Entity (Ren_Id);
Next_Entity_Temp : constant Entity_Id :=
Next_Entity (Renaming_Def_Id);
begin 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 -- Swap next entity links in preparation for exchanging entities
Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));
Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); Set_Next_Entity (Obj_Def_Id, Next_Id);
Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_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 -- Preserve source indication of original declaration, so that
-- xref information is properly generated for the right entity. -- xref information is properly generated for the right entity.
Preserve_Comes_From_Source Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));
(Object_Decl, Original_Node (Object_Decl)); Preserve_Comes_From_Source (Obj_Def_Id, Original_Node (Obj_Decl));
Preserve_Comes_From_Source
(Obj_Def_Id, Original_Node (Object_Decl));
Set_Comes_From_Source (Renaming_Def_Id, False); Set_Comes_From_Source (Ren_Id, False);
end; end;
end if; end if;
...@@ -9174,8 +9165,8 @@ package body Exp_Ch6 is ...@@ -9174,8 +9165,8 @@ package body Exp_Ch6 is
-- improve this treatment when build-in-place functions with class-wide -- improve this treatment when build-in-place functions with class-wide
-- results are implemented. ??? -- results are implemented. ???
if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then
Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt);
end if; end if;
end Make_Build_In_Place_Call_In_Object_Declaration; end Make_Build_In_Place_Call_In_Object_Declaration;
......
gcc/ada/exp_ch6.ads
...@@ -178,7 +178,7 @@ package Exp_Ch6 is ...@@ -178,7 +178,7 @@ package Exp_Ch6 is
-- call. -- call.
procedure Make_Build_In_Place_Call_In_Object_Declaration procedure Make_Build_In_Place_Call_In_Object_Declaration
(Object_Decl : Node_Id; (Obj_Decl : Node_Id;
Function_Call : Node_Id); Function_Call : Node_Id);
-- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
-- occurs as the expression initializing an object declaration by -- occurs as the expression initializing an object declaration by
......
gcc/ada/sem_prag.adb
...@@ -25211,6 +25211,7 @@ package body Sem_Prag is ...@@ -25211,6 +25211,7 @@ package body Sem_Prag is
Root_Typ := Etype (F); Root_Typ := Etype (F);
if Is_Access_Type (Etype (F)) then if Is_Access_Type (Etype (F)) then
Root_Typ := Designated_Type (Root_Typ);
New_Typ := New_Typ :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => Chars =>
......
gcc/ada/sem_util.adb
...@@ -16961,6 +16961,106 @@ package body Sem_Util is ...@@ -16961,6 +16961,106 @@ package body Sem_Util is
end if; end if;
end Remove_Homonym; 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 -- -- Rep_To_Pos_Flag --
--------------------- ---------------------
......
gcc/ada/sem_util.ads
...@@ -1781,12 +1781,6 @@ package Sem_Util is ...@@ -1781,12 +1781,6 @@ package Sem_Util is
-- convenience, qualified expressions applied to object names are also -- convenience, qualified expressions applied to object names are also
-- allowed as actuals for this function. -- 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; function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id;
-- Retrieve the name of aspect or pragma N taking into account a possible -- 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 -- rewrite and whether the pragma is generated from an aspect as the names
...@@ -1799,6 +1793,12 @@ package Sem_Util is ...@@ -1799,6 +1793,12 @@ package Sem_Util is
-- Type_Invariant -> Name_uType_Invariant -- Type_Invariant -> Name_uType_Invariant
-- Type_Invariant'Class -> 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; function Policy_In_Effect (Policy : Name_Id) return Name_Id;
-- Given a policy, return the policy identifier associated with it. If no -- Given a policy, return the policy identifier associated with it. If no
-- such policy is in effect, the value returned is No_Name. -- such policy is in effect, the value returned is No_Name.
...@@ -1845,6 +1845,12 @@ package Sem_Util is ...@@ -1845,6 +1845,12 @@ package Sem_Util is
procedure Remove_Homonym (E : Entity_Id); procedure Remove_Homonym (E : Entity_Id);
-- Removes E from the homonym chain -- 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; 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 -- 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 -- which is Standard_True if range checks are enabled (E is an entity to
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment