[Ada] Crash on dispatching conditional entry call

2020-06-11  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch9.adb (Expand_N_Conditional_Entry_Call): Replace call to
	New_Copy_List by calls to the new routine
	New_Copy_Separate_List.
	* sem_util.ads (New_Copy_Separate_List, New_Copy_Separate_Tree):
	New routines.

	* sem_util.adb (New_Copy_Separate_List, New_Copy_Separate_Tree):
	New routines.
	(New_Copy_Tree): Extend the machinery that detects syntactic
	nodes to handle lists of indentifiers with field More_Ids;
	otherwise such nodes are erroneously handled as semantic nodes.
	Copy aspect specifications attached to nodes.
	* sem_ch12.adb (Copy_Generic_Node): Protect reading attribute
	Etype.

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 4c2af03efe2a30827ac20d88116ce7f7f0d957bb..49d3c1f324b4985413d2c4abe5c970d1385e492e 100644 (file)
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -8124,7 +8124,7 @@ package body Exp_Ch9 is
          --       <else-statements>
          --    end if;
 
-         N_Stats := New_Copy_List_Tree (Statements (Alt));
+         N_Stats := New_Copy_Separate_List (Statements (Alt));
 
          Prepend_To (N_Stats,
            Make_Implicit_If_Statement (N,
@@ -8168,7 +8168,7 @@ package body Exp_Ch9 is
          --    <dispatching-call>;
          --    <triggering-statements>
 
-         Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
+         Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt));
          Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
 
          --  Generate:

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 80a8246b3a6a7bdd8f511c789af9387a96a82319..93a3ca59d5cdf64280443c9bfa985838d2a05507 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -8098,6 +8098,7 @@ package body Sem_Ch12 is
                      elsif Nkind (Assoc) = N_Identifier
                        and then Nkind (Parent (Assoc)) = N_Type_Conversion
                        and then Subtype_Mark (Parent (Assoc)) = Assoc
+                       and then Present (Etype (Assoc))
                        and then Is_Access_Type (Etype (Assoc))
                        and then Present (Etype (Expression (Parent (Assoc))))
                        and then

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 92dd39452d1312699a588e5a84aa509a79a2e8ba..cce55a6c58ae1d73ffec86e9b795ee1a7f0f81c5 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -20323,6 +20323,118 @@ package body Sem_Util is
       end if;
    end New_Copy_List_Tree;
 
+   ----------------------------
+   -- New_Copy_Separate_List --
+   ----------------------------
+
+   function New_Copy_Separate_List (List : List_Id) return List_Id is
+   begin
+      if List = No_List then
+         return No_List;
+
+      else
+         declare
+            List_Copy : constant List_Id := New_List;
+            N         : Node_Id := First (List);
+
+         begin
+            while Present (N) loop
+               Append (New_Copy_Separate_Tree (N), List_Copy);
+               Next (N);
+            end loop;
+
+            return List_Copy;
+         end;
+      end if;
+   end New_Copy_Separate_List;
+
+   ----------------------------
+   -- New_Copy_Separate_Tree --
+   ----------------------------
+
+   function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is
+      function Search_Decl (N : Node_Id) return Traverse_Result;
+      --  Subtree visitor which collects declarations
+
+      procedure Search_Declarations is new Traverse_Proc (Search_Decl);
+      --  Subtree visitor instantiation
+
+      -----------------
+      -- Search_Decl --
+      -----------------
+
+      Decls : Elist_Id;
+
+      function Search_Decl (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) in N_Declaration then
+            if No (Decls) then
+               Decls := New_Elmt_List;
+            end if;
+
+            Append_Elmt (N, Decls);
+         end if;
+
+         return OK;
+      end Search_Decl;
+
+      --  Local variables
+
+      Source_Copy : constant Node_Id := New_Copy_Tree (Source);
+
+   --  Start of processing for New_Copy_Separate_Tree
+
+   begin
+      Decls := No_Elist;
+      Search_Declarations (Source_Copy);
+
+      --  Associate a new Entity with all the subtree declarations (keeping
+      --  their original name).
+
+      if Present (Decls) then
+         declare
+            Elmt  : Elmt_Id;
+            Decl  : Node_Id;
+            New_E : Entity_Id;
+
+         begin
+            Elmt := First_Elmt (Decls);
+            while Present (Elmt) loop
+               Decl  := Node (Elmt);
+               New_E := Make_Defining_Identifier (Sloc (Decl),
+                          New_Internal_Name ('P'));
+
+               if Nkind (Decl) = N_Expression_Function then
+                  Decl := Specification (Decl);
+               end if;
+
+               if Nkind_In (Decl, N_Function_Instantiation,
+                                  N_Function_Specification,
+                                  N_Generic_Function_Renaming_Declaration,
+                                  N_Generic_Package_Renaming_Declaration,
+                                  N_Generic_Procedure_Renaming_Declaration,
+                                  N_Package_Body,
+                                  N_Package_Instantiation,
+                                  N_Package_Renaming_Declaration,
+                                  N_Package_Specification,
+                                  N_Procedure_Instantiation,
+                                  N_Procedure_Specification)
+               then
+                  Set_Chars (New_E, Chars (Defining_Unit_Name (Decl)));
+                  Set_Defining_Unit_Name (Decl, New_E);
+               else
+                  Set_Chars (New_E, Chars (Defining_Identifier (Decl)));
+                  Set_Defining_Identifier (Decl, New_E);
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+         end;
+      end if;
+
+      return Source_Copy;
+   end New_Copy_Separate_Tree;
+
    -------------------
    -- New_Copy_Tree --
    -------------------
@@ -20751,6 +20863,65 @@ package body Sem_Util is
          New_Par  : Node_Id := Empty;
          Semantic : Boolean := False) return Union_Id
       is
+         function Has_More_Ids (N : Node_Id) return Boolean;
+         --  Return True when N has attribute More_Ids set to True
+
+         function Is_Syntactic_Node return Boolean;
+         --  Return True when Field is a syntactic node
+
+         ------------------
+         -- Has_More_Ids --
+         ------------------
+
+         function Has_More_Ids (N : Node_Id) return Boolean is
+         begin
+            if Nkind_In (N, N_Component_Declaration,
+                            N_Discriminant_Specification,
+                            N_Exception_Declaration,
+                            N_Formal_Object_Declaration,
+                            N_Number_Declaration,
+                            N_Object_Declaration,
+                            N_Parameter_Specification,
+                            N_Use_Package_Clause,
+                            N_Use_Type_Clause)
+            then
+               return More_Ids (N);
+            else
+               return False;
+            end if;
+         end Has_More_Ids;
+
+         -----------------------
+         -- Is_Syntactic_Node --
+         -----------------------
+
+         function Is_Syntactic_Node return Boolean is
+            Old_N : constant Node_Id := Node_Id (Field);
+
+         begin
+            if Parent (Old_N) = Old_Par then
+               return True;
+
+            elsif not Has_More_Ids (Old_Par) then
+               return False;
+
+            --  Perform the check using the last last id in the syntactic chain
+
+            else
+               declare
+                  N : Node_Id := Old_Par;
+
+               begin
+                  while Present (N) and then More_Ids (N) loop
+                     Next (N);
+                  end loop;
+
+                  pragma Assert (Prev_Ids (N));
+                  return Parent (Old_N) = N;
+               end;
+            end if;
+         end Is_Syntactic_Node;
+
       begin
          --  The field is empty
 
@@ -20762,7 +20933,7 @@ package body Sem_Util is
          elsif Field in Node_Range then
             declare
                Old_N     : constant Node_Id := Node_Id (Field);
-               Syntactic : constant Boolean := Parent (Old_N) = Old_Par;
+               Syntactic : constant Boolean := Is_Syntactic_Node;
 
                New_N : Node_Id;
 
@@ -20990,6 +21161,11 @@ package body Sem_Util is
                   Set_Chars (Result, Chars (Entity (Result)));
                end if;
             end if;
+
+            if Has_Aspects (N) then
+               Set_Aspect_Specifications (Result,
+                 Copy_List_With_Replacement (Aspect_Specifications (N)));
+            end if;
          end if;
 
          return Result;

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e477c3849bb64a87ebd4aac8f7e2417aebc9a58e..b794e8098224710efee6c1a1a85fa3569e518c8a 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2291,6 +2291,16 @@ package Sem_Util is
    --  below. As for New_Copy_Tree, it is illegal to attempt to copy extended
    --  nodes (entities) either directly or indirectly using this function.
 
+   function New_Copy_Separate_List (List : List_Id) return List_Id;
+   --  Copy recursively a list of nodes using New_Copy_Separate_Tree
+
+   function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id;
+   --  Perform a deep copy of the subtree rooted at Source using New_Copy_Tree
+   --  replacing entities of local declarations by new entities. This behavior
+   --  is required by the backend to ensure entities uniqueness when a copy of
+   --  a subtree is attached to the tree. The new entities keep their original
+   --  names to facilitate debugging the tree copy.
+
    function New_Copy_Tree
      (Source           : Node_Id;
       Map              : Elist_Id   := No_Elist;