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 262 additions and 147 deletions
gcc/ada/ChangeLog
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
Aspect_Disable_Controlled): If expander is not active, pre-analyze
expression anyway for ASIS and other tools use.
......
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,11 +8932,11 @@ 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
......@@ -8962,7 +8951,7 @@ package body Exp_Ch6 is
Loc),
Expression =>
New_Occurrence_Of
(Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
(Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
Loc));
-- In the definite case, add an implicit actual to the function call
......@@ -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));
Make_Explicit_Dereference (Obj_Loc,
Prefix => New_Occurrence_Of (Def_Id, Obj_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),
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);
Analyze (Object_Decl);
-- 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 (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;
......
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
......
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 =>
......
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 --
---------------------
......
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
......
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