[Ada] Crash in class-wide pre/postconditions

gcc/ada/

	* contracts.adb (Restore_Original_Selected_Component): New
	subprogram that traverses a preanalyzed expression searching for
	dispatching calls to functions whose original node was a
	selected component, and replacing them with their original node.
	This functionality is required because the preanalyis of
	dispatching calls using the Object.Operation notation transforms
	such calls, and we need the original condition to properly
	inherit and extend the condition expression on tagged type
	derivations.  This functionality was previously provided by the
	routine Install_Original_Selected_Component (as part of
	inheriting conditions); now it is performed as part of the
	preanalysis of the condition, thus avoiding repeatedly
	installing and restoring such nodes.
	(Install_Original_Selected_Component): Removed.
	(Restore_Dispatching_Calls): Removed.

1 files changed, 58 insertions, 106 deletions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 98f469b..1902fbb 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -4254,6 +4254,11 @@ package body Contracts is
          procedure Remove_Formals (Id : Entity_Id);
          --  Remove formals from homonym chains and make them not visible
 
+         procedure Restore_Original_Selected_Component;
+         --  Traverse Expr searching for dispatching calls to functions whose
+         --  original node was a selected component, and replace them with
+         --  their original node.
+
          ----------------------------
          -- Clear_Unset_References --
          ----------------------------
@@ -4313,6 +4318,46 @@ package body Contracts is
             end loop;
          end Remove_Formals;
 
+         -----------------------------------------
+         -- Restore_Original_Selected_Component --
+         -----------------------------------------
+
+         procedure Restore_Original_Selected_Component is
+
+            function Restore_Node (N : Node_Id) return Traverse_Result;
+            --  Process a single node
+
+            ------------------
+            -- Restore_Node --
+            ------------------
+
+            function Restore_Node (N : Node_Id) return Traverse_Result is
+            begin
+               if Nkind (N) = N_Function_Call
+                 and then Nkind (Original_Node (N)) = N_Selected_Component
+                 and then Is_Dispatching_Operation (Entity (Name (N)))
+               then
+                  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).
+
+                  Set_Parent (Prefix (N), N);
+                  Set_Parent (Selector_Name (N), N);
+               end if;
+
+               return OK;
+            end Restore_Node;
+
+            procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
+
+         begin
+            Restore_Nodes (Expr);
+         end Restore_Original_Selected_Component;
+
       --  Start of processing for Preanalyze_Condition
 
       begin
@@ -4329,6 +4374,16 @@ package body Contracts is
          Remove_Formals (Subp);
          Pop_Scope;
 
+         --  If this preanalyzed condition has occurrences of dispatching calls
+         --  using the Object.Operation notation, during preanalysis such calls
+         --  are rewritten as dispatching function calls; if at later stages
+         --  this condition is inherited we must have restored the original
+         --  selected-component node to ensure that the preanalysis of the
+         --  inherited condition rewrites these dispatching calls in the
+         --  correct context to avoid reporting spurious errors.
+
+         Restore_Original_Selected_Component;
+
          --  Traverse Expr and clear the Controlling_Argument of calls to
          --  nonabstract functions. Required since the preanalyzed condition
          --  is not yet installed on its definite context and will be cloned
@@ -4373,103 +4428,9 @@ package body Contracts is
            (Par_Subp : Entity_Id;
             Subp     : Entity_Id) return Node_Id
          is
-            Installed_Calls : constant Elist_Id := New_Elmt_List;
-
-            procedure Install_Original_Selected_Component (Expr : Node_Id);
-            --  Traverse the given expression searching for dispatching calls
-            --  to functions whose original nodes was a selected component,
-            --  and replacing them temporarily by a copy of their original
-            --  node. Modified calls are stored in the list Installed_Calls
-            --  (to undo this work later).
-
-            procedure Restore_Dispatching_Calls (Expr : Node_Id);
-            --  Undo the work done by Install_Original_Selected_Component.
-
-            -----------------------------------------
-            -- Install_Original_Selected_Component --
-            -----------------------------------------
-
-            procedure Install_Original_Selected_Component (Expr : Node_Id) is
-               function Install_Node (N : Node_Id) return Traverse_Result;
-               --  Process a single node
-
-               ------------------
-               -- Install_Node --
-               ------------------
-
-               function Install_Node (N : Node_Id) return Traverse_Result is
-                  New_N    : Node_Id;
-                  Orig_Nod : Node_Id;
-
-               begin
-                  if Nkind (N) = N_Function_Call
-                    and then Nkind (Original_Node (N)) = N_Selected_Component
-                    and then Is_Dispatching_Operation (Entity (Name (N)))
-                  then
-                     Orig_Nod := Original_Node (N);
-
-                     --  Temporarily use the original node field to keep the
-                     --  reference to this node (to undo this work later!).
-
-                     New_N := New_Copy (N);
-                     Set_Original_Node (New_N, Orig_Nod);
-                     Append_Elmt (New_N, Installed_Calls);
-
-                     Rewrite (N, Orig_Nod);
-                     Set_Original_Node (N, New_N);
-                  end if;
-
-                  return OK;
-               end Install_Node;
-
-               procedure Install_Nodes is new Traverse_Proc (Install_Node);
-
-            begin
-               Install_Nodes (Expr);
-            end Install_Original_Selected_Component;
-
-            -------------------------------
-            -- Restore_Dispatching_Calls --
-            -------------------------------
-
-            procedure Restore_Dispatching_Calls (Expr : Node_Id) is
-               function Restore_Node (N : Node_Id) return Traverse_Result;
-               --  Process a single node
-
-               ------------------
-               -- Restore_Node --
-               ------------------
-
-               function Restore_Node (N : Node_Id) return Traverse_Result is
-                  Orig_Sel_N : Node_Id;
-
-               begin
-                  if Nkind (N) = N_Selected_Component
-                    and then Nkind (Original_Node (N)) = N_Function_Call
-                    and then Contains (Installed_Calls, Original_Node (N))
-                  then
-                     Orig_Sel_N := Original_Node (Original_Node (N));
-                     pragma Assert (Nkind (Orig_Sel_N) = N_Selected_Component);
-                     Rewrite (N, Original_Node (N));
-                     Set_Original_Node (N, Orig_Sel_N);
-                  end if;
-
-                  return OK;
-               end Restore_Node;
-
-               procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
-
-            begin
-               Restore_Nodes (Expr);
-            end Restore_Dispatching_Calls;
-
-            --  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);
-            New_Expr       : Node_Id;
-            Class_Cond     : Node_Id;
 
          --  Start of processing for Inherit_Condition
 
@@ -4482,18 +4443,9 @@ package body Contracts is
                Next_Formal (Subp_Formal_Id);
             end loop;
 
-            --  In order to properly preanalyze an inherited preanalyzed
-            --  condition that has occurrences of the Object.Operation
-            --  notation we must restore the original node; otherwise we
-            --  would report spurious errors.
-
-            Class_Cond := Class_Condition (Kind, Par_Subp);
-
-            Install_Original_Selected_Component (Class_Cond);
-            New_Expr := New_Copy_Tree (Class_Cond);
-            Restore_Dispatching_Calls (Class_Cond);
-
-            return New_Copy_Tree (New_Expr, Map => Assoc_List);
+            return New_Copy_Tree
+                     (Source => Class_Condition (Kind, Par_Subp),
+                      Map    => Assoc_List);
          end Inherit_Condition;
 
          ----------------------