[Ada] Crash in class-wide pre/postconditions

gcc/ada/

	* atree.ads (Traverse_Func_With_Parent): New generic subprogram.
	(Traverse_Proc_With_Parent): Likewise.
	* atree.adb (Parents_Stack): New table used to traverse trees
	passing the parent field of each node.
	(Internal_Traverse_With_Parent): New generic subprogram.
	(Traverse_Func_With_Parent): Likewise.
	(Traverse_Proc_With_Parent): Likewise.
	* contracts.adb (Fix_Parents): New subprogram.
	(Restore_Original_Selected_Component): Enhanced to fix the
	parent field of restored nodes.
	(Inherit_Condition): Adding assertions to check the parent field
	of inherited conditions and to ensure that the built inherited
	condition has no reference to the formals of the parent
	subprogram.
	* sem_util.ads, sem_util.adb (Check_Parents): New subprogram.

1 files changed, 142 insertions, 12 deletions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 1902fbb..24bd568 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -4323,9 +4323,55 @@ package body Contracts is
          -----------------------------------------
 
          procedure Restore_Original_Selected_Component is
+            Restored_Nodes_List : Elist_Id := No_Elist;
+
+            procedure Fix_Parents (N : Node_Id);
+            --  Traverse the subtree of N fixing the Parent field of all the
+            --  nodes.
 
             function Restore_Node (N : Node_Id) return Traverse_Result;
-            --  Process a single node
+            --  Process dispatching calls to functions whose original node was
+            --  a selected component, and replace them with their original
+            --  node. Restored nodes are stored in the Restored_Nodes_List
+            --  to fix the parent fields of their subtrees in a separate
+            --  tree traversal.
+
+            -----------------
+            -- Fix_Parents --
+            -----------------
+
+            procedure Fix_Parents (N : Node_Id) is
+
+               function Fix_Parent
+                 (Parent_Node : Node_Id;
+                  Node        : Node_Id) return Traverse_Result;
+               --  Process a single node
+
+               ----------------
+               -- Fix_Parent --
+               ----------------
+
+               function Fix_Parent
+                 (Parent_Node : Node_Id;
+                  Node        : Node_Id) return Traverse_Result
+               is
+                  Par : constant Node_Id := Parent (Node);
+
+               begin
+                  if Par /= Parent_Node then
+                     pragma Assert (not Is_List_Member (Node));
+                     Set_Parent (Node, Parent_Node);
+                  end if;
+
+                  return OK;
+               end Fix_Parent;
+
+               procedure Fix_Parents is
+                  new Traverse_Proc_With_Parent (Fix_Parent);
+
+            begin
+               Fix_Parents (N);
+            end Fix_Parents;
 
             ------------------
             -- Restore_Node --
@@ -4340,13 +4386,11 @@ package body Contracts is
                   Rewrite (N, Original_Node (N));
                   Set_Original_Node (N, N);
 
-                  --  Restore decoration of its child nodes; required to ensure
-                  --  proper copies of this subtree (if required) by subsequent
-                  --  calls to New_Copy_Tree (since otherwise these child nodes
-                  --  are not duplicated).
+                  --  Save the restored node in the Restored_Nodes_List to fix
+                  --  the parent fields of their subtrees in a separate tree
+                  --  traversal.
 
-                  Set_Parent (Prefix (N), N);
-                  Set_Parent (Selector_Name (N), N);
+                  Append_New_Elmt (N, Restored_Nodes_List);
                end if;
 
                return OK;
@@ -4354,8 +4398,29 @@ package body Contracts is
 
             procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
 
+         --  Start of processing for Restore_Original_Selected_Component
+
          begin
             Restore_Nodes (Expr);
+
+            --  After restoring the original node we must fix the decoration
+            --  of the Parent attribute to ensure tree consistency; required
+            --  because when the class-wide condition is inherited, calls to
+            --  New_Copy_Tree will perform copies of this subtree, and formal
+            --  occurrences with wrong Parent field cannot be mapped to the
+            --  new formals.
+
+            if Present (Restored_Nodes_List) then
+               declare
+                  Elmt : Elmt_Id := First_Elmt (Restored_Nodes_List);
+
+               begin
+                  while Present (Elmt) loop
+                     Fix_Parents (Node (Elmt));
+                     Next_Elmt (Elmt);
+                  end loop;
+               end;
+            end if;
          end Restore_Original_Selected_Component;
 
       --  Start of processing for Preanalyze_Condition
@@ -4428,11 +4493,60 @@ package body Contracts is
            (Par_Subp : Entity_Id;
             Subp     : Entity_Id) return Node_Id
          is
+            function Check_Condition (Expr : Node_Id) return Boolean;
+            --  Used in assertion to check that Expr has no reference to the
+            --  formals of Par_Subp.
+
+            ---------------------
+            -- Check_Condition --
+            ---------------------
+
+            function Check_Condition (Expr : Node_Id) return Boolean is
+               Par_Formal_Id : Entity_Id;
+
+               function Check_Entity (N : Node_Id) return Traverse_Result;
+               --  Check occurrence of Par_Formal_Id
+
+               ------------------
+               -- Check_Entity --
+               ------------------
+
+               function Check_Entity (N : Node_Id) return Traverse_Result is
+               begin
+                  if Nkind (N) = N_Identifier
+                    and then Present (Entity (N))
+                    and then Entity (N) = Par_Formal_Id
+                  then
+                     return Abandon;
+                  end if;
+
+                  return OK;
+               end Check_Entity;
+
+               function Check_Expression is new Traverse_Func (Check_Entity);
+
+            --  Start of processing for Check_Condition
+
+            begin
+               Par_Formal_Id := First_Formal (Par_Subp);
+
+               while Present (Par_Formal_Id) loop
+                  if Check_Expression (Expr) = Abandon then
+                     return False;
+                  end if;
+
+                  Next_Formal (Par_Formal_Id);
+               end loop;
+
+               return True;
+            end Check_Condition;
+
+            --  Local variables
+
             Assoc_List     : constant Elist_Id := New_Elmt_List;
             Par_Formal_Id  : Entity_Id := First_Formal (Par_Subp);
             Subp_Formal_Id : Entity_Id := First_Formal (Subp);
-
-         --  Start of processing for Inherit_Condition
+            New_Condition  : Node_Id;
 
          begin
             while Present (Par_Formal_Id) loop
@@ -4443,9 +4557,25 @@ package body Contracts is
                Next_Formal (Subp_Formal_Id);
             end loop;
 
-            return New_Copy_Tree
-                     (Source => Class_Condition (Kind, Par_Subp),
-                      Map    => Assoc_List);
+            --  Check that Parent field of all the nodes have their correct
+            --  decoration; required because otherwise mapped nodes with
+            --  wrong Parent field are left unmodified in the copied tree
+            --  and cause reporting wrong errors at later stages.
+
+            pragma Assert
+              (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List));
+
+            New_Condition :=
+              New_Copy_Tree
+                (Source => Class_Condition (Kind, Par_Subp),
+                 Map    => Assoc_List);
+
+            --  Ensure that the inherited condition has no reference to the
+            --  formals of the parent subprogram.
+
+            pragma Assert (Check_Condition (New_Condition));
+
+            return New_Condition;
          end Inherit_Condition;
 
          ----------------------