diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 21f438f90f37..218fd66852fd 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 --
----------------------------------------
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index bde32ffc5b44..ae6355ef410b 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -276,6 +276,10 @@ package Contracts is
-- which are invoked from the caller side; they are also used to build
-- the dispatch-table wrapper (DTW), if required.
+ procedure Preanalyze_Class_Conditions (Spec_Id : Entity_Id);
+ -- Preanalyze class-wide pre-/postconditions of the given subprogram
+ -- specification.
+
procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id);
-- Merge, preanalyze, and check class-wide pre/postconditions of Typ
-- primitives.
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2a3aca85a796..615c6d2110c6 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -26201,6 +26201,20 @@ package body Sem_Prag is
Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
Set_Is_Analyzed_Pragma (N);
+ -- If the subprogram is frozen then its class-wide pre- and post-
+ -- conditions have been preanalyzed (see Merge_Class_Conditions);
+ -- otherwise they must be preanalyzed now to ensure the correct
+ -- visibility of their referenced entities. This scenario occurs
+ -- when the subprogram is defined in a nested package (since the
+ -- end of the package does not cause freezing).
+
+ if Class_Present (N)
+ and then Is_Dispatching_Operation (Spec_Id)
+ and then not Is_Frozen (Spec_Id)
+ then
+ Preanalyze_Class_Conditions (Spec_Id);
+ end if;
+
Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Pre_Post_Condition_In_Decl_Part;