This patch modifies the expansion of a build-in-place function call that
initializes a class-wide limited object to generate the necessary debug
information for the object.
------------
-- Source --
------------
-- types.ads
package Types is
type Root_Type is tagged limited record
I : Integer;
end record;
type Root_Access is access all Root_Type'Class;
function Get return Root_Type'Class;
procedure Ignore (O_Acc : Root_Access);
end Types;
-- types.adb
package body Types is
function Get return Root_Type'Class is
begin
return Root_Type'(I => 0);
end Get;
procedure Ignore (O_Acc : Root_Access) is
begin
null;
end Ignore;
end Types;
-- cw_debug_info.adb
with Types; use Types;
procedure CW_Debug_Info is
Obj : aliased Root_Type'Class := Get;
Obj_Ptr : constant Root_Access := Obj'Unchecked_Access;
begin
Ignore (Obj_Ptr);
end CW_Debug_Info;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q -g cw_debug_info.adb
$ gdb ./cw_debug_info
$ b cw_debug_info.adb:5
$ r
$ print (obj)
$1 = (i => 0)
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-10-20 Hristian Kirtchev <kirtc...@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.
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 229060)
+++ sem_util.adb (working copy)
@@ -16961,6 +16961,106 @@
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 --
---------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 229058)
+++ sem_util.ads (working copy)
@@ -1781,12 +1781,6 @@
-- 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 @@
-- 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 @@
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
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 229056)
+++ exp_ch6.adb (working copy)
@@ -3942,22 +3942,6 @@
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 @@
-- 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 @@
-- 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 @@
-- 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 @@
-- 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 @@
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 @@
-- 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 @@
-- 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 @@
-- 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 @@
-- 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 @@
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 @@
-- ...
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 @@
-- 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 @@
-- 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 @@
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 @@
-- 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 @@
-- 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 @@
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 @@
-- 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 @@
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 @@
-- 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 @@
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 @@
-- 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 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
----------------------------------------------------
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 @@
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 @@
-- 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 @@
-- 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 @@
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 @@
(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 @@
-- 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 @@
(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 @@
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 @@
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 @@
-- 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 @@
-- 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,21 +9098,29 @@
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
-- to exchange the entities containing their defining identifiers to
@@ -9138,31 +9133,27 @@
-- 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_Decl, Original_Node (Obj_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 if;
@@ -9174,8 +9165,8 @@
-- 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;
Index: exp_ch6.ads
===================================================================
--- exp_ch6.ads (revision 229049)
+++ exp_ch6.ads (working copy)
@@ -178,7 +178,7 @@
-- 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
