ada: Adjust classwide contract expression preanalysis

Before this patch, a classwide contract expression was preanalyzed
only when its primitive operation's type was frozen. It caused name
resolution to be off in the cases where the freezing took place
after the end of the declaration list the primitive operation was
declared in.

This patch makes it so that if the compiler gets to the end of
the declaration list before the type is frozen, it preanalyzes the
classwide contract expression, so that the names are resolved in the
right context.

gcc/ada/

	* contracts.adb
	(Preanalyze_Class_Conditions): New procedure.
	(Preanalyze_Condition): Moved out from Merge_Class_Conditions in
	order to be spec-visible.
	* contracts.ads
	(Preanalyze_Class_Conditions): New procedure.
	* sem_prag.adb
	(Analyze_Pre_Post_Condition_In_Decl_Part): Call
	Preanalyze_Class_Conditions when necessary.

1 files changed, 249 insertions, 232 deletions

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 21f438f..218fd66 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -107,6 +107,11 @@ package body Contracts is
    --  well as Contract_Cases, Subprogram_Variant, invariants and predicates.
    --  Body_Id denotes the entity of the subprogram body.
 
+   procedure Preanalyze_Condition
+     (Subp : Entity_Id;
+      Expr : Node_Id);
+   --  Preanalyze the class-wide condition Expr of Subp
+
    procedure Set_Class_Condition
      (Kind : Condition_Kind;
       Subp : Entity_Id;
@@ -4548,242 +4553,10 @@ package body Contracts is
 
    procedure Merge_Class_Conditions (Spec_Id : Entity_Id) is
 
-      procedure Preanalyze_Condition
-        (Subp : Entity_Id;
-         Expr : Node_Id);
-      --  Preanalyze the class-wide condition Expr of Subp
-
       procedure Process_Inherited_Conditions (Kind : Condition_Kind);
       --  Collect all inherited class-wide conditions of Spec_Id and merge
       --  them into one big condition.
 
-      --------------------------
-      -- Preanalyze_Condition --
-      --------------------------
-
-      procedure Preanalyze_Condition
-        (Subp : Entity_Id;
-         Expr : Node_Id)
-      is
-         procedure Clear_Unset_References;
-         --  Clear unset references on formals of Subp since preanalysis
-         --  occurs in a place unrelated to the actual code.
-
-         procedure Remove_Controlling_Arguments;
-         --  Traverse Expr and clear the Controlling_Argument of calls to
-         --  nonabstract functions.
-
-         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 --
-         ----------------------------
-
-         procedure Clear_Unset_References is
-            F : Entity_Id := First_Formal (Subp);
-
-         begin
-            while Present (F) loop
-               Set_Unset_Reference (F, Empty);
-               Next_Formal (F);
-            end loop;
-         end Clear_Unset_References;
-
-         ----------------------------------
-         -- Remove_Controlling_Arguments --
-         ----------------------------------
-
-         procedure Remove_Controlling_Arguments is
-            function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result;
-            --  Reset the Controlling_Argument of calls to nonabstract
-            --  function calls.
-
-            ---------------------
-            -- Remove_Ctrl_Arg --
-            ---------------------
-
-            function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is
-            begin
-               if Nkind (N) = N_Function_Call
-                 and then Present (Controlling_Argument (N))
-                 and then not Is_Abstract_Subprogram (Entity (Name (N)))
-               then
-                  Set_Controlling_Argument (N, Empty);
-               end if;
-
-               return OK;
-            end Remove_Ctrl_Arg;
-
-            procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg);
-         begin
-            Remove_Ctrl_Args (Expr);
-         end Remove_Controlling_Arguments;
-
-         --------------------
-         -- Remove_Formals --
-         --------------------
-
-         procedure Remove_Formals (Id : Entity_Id) is
-            F : Entity_Id := First_Formal (Id);
-
-         begin
-            while Present (F) loop
-               Set_Is_Immediately_Visible (F, False);
-               Remove_Homonym (F);
-               Next_Formal (F);
-            end loop;
-         end Remove_Formals;
-
-         -----------------------------------------
-         -- Restore_Original_Selected_Component --
-         -----------------------------------------
-
-         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 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 --
-            ------------------
-
-            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);
-
-                  --  Save the restored node in the Restored_Nodes_List to fix
-                  --  the parent fields of their subtrees in a separate tree
-                  --  traversal.
-
-                  Append_New_Elmt (N, Restored_Nodes_List);
-               end if;
-
-               return OK;
-            end Restore_Node;
-
-            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
-
-      begin
-         pragma Assert (Present (Expr));
-         pragma Assert (Inside_Class_Condition_Preanalysis = False);
-
-         Push_Scope (Subp);
-         Install_Formals (Subp);
-         Inside_Class_Condition_Preanalysis := True;
-
-         Preanalyze_Spec_Expression (Expr, Standard_Boolean);
-
-         Inside_Class_Condition_Preanalysis := False;
-         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
-         --  and extended in derivations with additional conditions.
-
-         Remove_Controlling_Arguments;
-
-         --  Clear also attribute Unset_Reference; again because preanalysis
-         --  occurs in a place unrelated to the actual code.
-
-         Clear_Unset_References;
-      end Preanalyze_Condition;
-
       ----------------------------------
       -- Process_Inherited_Conditions --
       ----------------------------------
@@ -5116,6 +4889,250 @@ package body Contracts is
       end loop;
    end Merge_Class_Conditions;
 
+   ---------------------------------
+   -- Preanalyze_Class_Conditions --
+   ---------------------------------
+
+   procedure Preanalyze_Class_Conditions (Spec_Id : Entity_Id) is
+      Cond : Node_Id;
+
+   begin
+      for Kind in Condition_Kind loop
+         Cond := Class_Condition (Kind, Spec_Id);
+
+         if Present (Cond) then
+            Preanalyze_Condition (Spec_Id, Cond);
+         end if;
+      end loop;
+   end Preanalyze_Class_Conditions;
+
+   --------------------------
+   -- Preanalyze_Condition --
+   --------------------------
+
+   procedure Preanalyze_Condition
+     (Subp : Entity_Id;
+      Expr : Node_Id)
+   is
+      procedure Clear_Unset_References;
+      --  Clear unset references on formals of Subp since preanalysis
+      --  occurs in a place unrelated to the actual code.
+
+      procedure Remove_Controlling_Arguments;
+      --  Traverse Expr and clear the Controlling_Argument of calls to
+      --  nonabstract functions.
+
+      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 --
+      ----------------------------
+
+      procedure Clear_Unset_References is
+         F : Entity_Id := First_Formal (Subp);
+
+      begin
+         while Present (F) loop
+            Set_Unset_Reference (F, Empty);
+            Next_Formal (F);
+         end loop;
+      end Clear_Unset_References;
+
+      ----------------------------------
+      -- Remove_Controlling_Arguments --
+      ----------------------------------
+
+      procedure Remove_Controlling_Arguments is
+         function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result;
+         --  Reset the Controlling_Argument of calls to nonabstract
+         --  function calls.
+
+         ---------------------
+         -- Remove_Ctrl_Arg --
+         ---------------------
+
+         function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is
+         begin
+            if Nkind (N) = N_Function_Call
+              and then Present (Controlling_Argument (N))
+              and then not Is_Abstract_Subprogram (Entity (Name (N)))
+            then
+               Set_Controlling_Argument (N, Empty);
+            end if;
+
+            return OK;
+         end Remove_Ctrl_Arg;
+
+         procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg);
+      begin
+         Remove_Ctrl_Args (Expr);
+      end Remove_Controlling_Arguments;
+
+      --------------------
+      -- Remove_Formals --
+      --------------------
+
+      procedure Remove_Formals (Id : Entity_Id) is
+         F : Entity_Id := First_Formal (Id);
+
+      begin
+         while Present (F) loop
+            Set_Is_Immediately_Visible (F, False);
+            Remove_Homonym (F);
+            Next_Formal (F);
+         end loop;
+      end Remove_Formals;
+
+      -----------------------------------------
+      -- Restore_Original_Selected_Component --
+      -----------------------------------------
+
+      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 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 --
+         ------------------
+
+         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);
+
+               --  Save the restored node in the Restored_Nodes_List to fix
+               --  the parent fields of their subtrees in a separate tree
+               --  traversal.
+
+               Append_New_Elmt (N, Restored_Nodes_List);
+            end if;
+
+            return OK;
+         end Restore_Node;
+
+         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
+
+   begin
+      pragma Assert (Present (Expr));
+      pragma Assert (Inside_Class_Condition_Preanalysis = False);
+
+      Push_Scope (Subp);
+      Install_Formals (Subp);
+      Inside_Class_Condition_Preanalysis := True;
+
+      Preanalyze_Spec_Expression (Expr, Standard_Boolean);
+
+      Inside_Class_Condition_Preanalysis := False;
+      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
+      --  and extended in derivations with additional conditions.
+
+      Remove_Controlling_Arguments;
+
+      --  Clear also attribute Unset_Reference; again because preanalysis
+      --  occurs in a place unrelated to the actual code.
+
+      Clear_Unset_References;
+   end Preanalyze_Condition;
+
    ----------------------------------------
    -- Save_Global_References_In_Contract --
    ----------------------------------------