+2018-07-17 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping
+ constructs and entities within receive new entities when replicating a
+ tree.
+ (Expand_N_Extended_Return_Statement): Ensure that scoping constructs
+ and entities within receive new entities when replicating a tree.
+ * sem_util.adb (New_Copy_Tree): Add new formal Scopes_In_EWA_OK.
+ (Visit_Entity): Visit entities within scoping constructs inside
+ expression with actions nodes when requested by the caller. Add blocks,
+ labels, and procedures to the list of entities which need replication.
+ * sem_util.ads (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. Update
+ the comment on usage.
+
2018-07-17 Arnaud Charlet <charlet@adacore.com>
* doc/gnat_ugn/about_this_guide.rst,
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
- Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
+ Orig_Expr : constant Node_Id :=
+ New_Copy_Tree
+ (Source => Alloc_Expr,
+ Scopes_In_EWA_OK => True);
Stmts : constant List_Id := New_List;
Desig_Typ : Entity_Id;
Local_Id : Entity_Id;
Init_Assignment :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
- Expression => New_Copy_Tree (Ret_Obj_Expr));
+ Expression =>
+ New_Copy_Tree
+ (Source => Ret_Obj_Expr,
+ Scopes_In_EWA_OK => True));
Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
Set_Assignment_OK (Name (Init_Assignment));
Subtype_Mark =>
New_Occurrence_Of
(Etype (Ret_Obj_Expr), Loc),
- Expression => New_Copy_Tree (Ret_Obj_Expr)));
+ Expression =>
+ New_Copy_Tree
+ (Source => Ret_Obj_Expr,
+ Scopes_In_EWA_OK => True)));
else
-- If the function returns a class-wide type we cannot
-- except we set Storage_Pool and Procedure_To_Call so
-- it will use the user-defined storage pool.
- Pool_Allocator := New_Copy_Tree (Heap_Allocator);
+ Pool_Allocator :=
+ New_Copy_Tree
+ (Source => Heap_Allocator,
+ Scopes_In_EWA_OK => True);
+
pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
-- Do not generate the renaming of the build-in-place
-- allocation.
else
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
+ SS_Allocator :=
+ New_Copy_Tree
+ (Source => Heap_Allocator,
+ Scopes_In_EWA_OK => True);
+
pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
-- The heap and pool allocators are marked as
-------------------
function New_Copy_Tree
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty;
+ Scopes_In_EWA_OK : Boolean := False) return Node_Id
is
-- This routine performs low-level tree manipulations and needs access
-- to the internals of the tree.
pragma Assert (Nkind (Id) in N_Entity);
pragma Assert (not Is_Itype (Id));
- -- Nothing to do if the entity is not defined in the Actions list of
- -- an N_Expression_With_Actions node.
+ -- Nothing to do when the entity is not defined in the Actions list
+ -- of an N_Expression_With_Actions node.
if EWA_Level = 0 then
return;
- -- Nothing to do if the entity is defined within a scoping construct
- -- of an N_Expression_With_Actions node.
+ -- Nothing to do when the entity is defined in a scoping construct
+ -- within an N_Expression_With_Actions node, unless the caller has
+ -- requested their replication.
- elsif EWA_Inner_Scope_Level > 0 then
+ -- ??? should this restriction be eliminated?
+
+ elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then
return;
- -- Nothing to do if the entity is not an object or a type. Relaxing
+ -- Nothing to do when the entity does not denote a construct that
+ -- may appear within an N_Expression_With_Actions node. Relaxing
-- this restriction leads to a performance penalty.
- elsif not Ekind_In (Id, E_Constant, E_Variable)
+ -- ??? this list is flaky, and may hide dormant bugs
+
+ elsif not Ekind_In (Id, E_Block,
+ E_Constant,
+ E_Label,
+ E_Procedure,
+ E_Variable)
and then not Is_Type (Id)
then
return;
- -- Nothing to do if the entity was already visited
+ -- Nothing to do when the entity was already visited
elsif NCT_Tables_In_Use
and then Present (NCT_New_Entities.Get (Id))
then
return;
- -- Nothing to do if the declaration node of the entity is not within
+ -- Nothing to do when the declaration node of the entity is not in
-- the subtree being replicated.
elsif not In_Subtree
Placement : out State_Space_Kind;
Pack_Id : out Entity_Id);
-- Determine the state space placement of an item. Item_Id denotes the
- -- entity of an abstract state, object or package instantiation. Placement
+ -- entity of an abstract state, object, or package instantiation. Placement
-- captures the precise placement of the item in the enclosing state space.
-- If the state space is that of a package, Pack_Id denotes its entity,
-- otherwise Pack_Id is Empty.
-- nodes (entities) either directly or indirectly using this function.
function New_Copy_Tree
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id;
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty;
+ Scopes_In_EWA_OK : Boolean := False) return Node_Id;
-- Perform a deep copy of the subtree rooted at Source. Entities, itypes,
-- and nodes are handled separately as follows:
--
--
-- Parameter New_Scope may be used to specify a new scope for all copied
-- entities and itypes.
+ --
+ -- Parameter Scopes_In_EWA_OK may be used to force the replication of both
+ -- scoping entities and non-scoping entities found within expression with
+ -- actions nodes.
function New_External_Entity
(Kind : Entity_Kind;
+2018-07-17 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.
+
2018-07-16 Carl Love <cel@us.ibm.com>
PR target/86414
--- /dev/null
+-- { dg-do compile }
+
+with BIP_Case_Expr_Pkg; use BIP_Case_Expr_Pkg;
+
+procedure BIP_Case_Expr is
+ function Make_Any_Lim_Ctrl (Flag : Boolean) return Lim_Ctrl is
+ begin
+ return (case Flag is
+ when True => Make_Lim_Ctrl,
+ when False => Make_Lim_Ctrl);
+ end;
+
+ Res : Lim_Ctrl := Make_Any_Lim_Ctrl (True);
+
+begin null; end BIP_Case_Expr;
--- /dev/null
+with Ada.Finalization; use Ada.Finalization;
+
+package BIP_Case_Expr_Pkg is
+ type Lim_Ctrl is new Limited_Controlled with null record;
+
+ function Make_Lim_Ctrl return Lim_Ctrl;
+end BIP_Case_Expr_Pkg;
projects / gcc.git / commitdiff