[Ada] Crash on case expression in build-in-place function

This patch modifies the recursive tree replication routine New_Copy_Tree to
create new entities and remap old entities to the new ones for constructs in
N_Expression_With_Actions nodes when requested by a caller. This in turn allows
the build-in-place mechanism to avoid sharing entities between the 4 variants
of returns it generates.

2018-07-17  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* 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.

gcc/testsuite/

	* gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.

From-SVN: r262766

7 files changed, 96 insertions, 23 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4e7eba7..d6cf6e7 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+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,
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 9ddf0fa..ef6406d 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4562,7 +4562,10 @@ package body Exp_Ch6 is
                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;
@@ -5022,7 +5025,10 @@ package body Exp_Ch6 is
                   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));
@@ -5153,7 +5159,10 @@ package body Exp_Ch6 is
                                 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
@@ -5193,7 +5202,11 @@ package body Exp_Ch6 is
                      --  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
@@ -5235,7 +5248,11 @@ package body Exp_Ch6 is
                      --  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
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1c3610c..c8c914a 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -19505,10 +19505,11 @@ package body Sem_Util is
    -------------------
 
    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.
@@ -20430,34 +20431,44 @@ package body Sem_Util is
          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
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 9bff3ba..34d618e 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -872,7 +872,7 @@ package Sem_Util is
       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.
@@ -2240,10 +2240,11 @@ package Sem_Util is
    --  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:
    --
@@ -2313,6 +2314,10 @@ package Sem_Util is
    --
    --  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;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a6cd3c8..c801b10 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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
diff --git a/gcc/testsuite/gnat.dg/bip_case_expr.adb b/gcc/testsuite/gnat.dg/bip_case_expr.adb
new file mode 100644
index 0000000..6e8a687
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/bip_case_expr.adb
@@ -0,0 +1,15 @@
+--  { 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;
diff --git a/gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads b/gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads
new file mode 100644
index 0000000..3fb0009
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads
@@ -0,0 +1,7 @@
+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;