public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-3797] ada: Adjust classwide contract expression preanalysis
@ 2022-11-08 8:42 Marc Poulhi?s
0 siblings, 0 replies; only message in thread
From: Marc Poulhi?s @ 2022-11-08 8:42 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:45656a992eb18bfefe2e6e20d3b425afe945af28
commit r13-3797-g45656a992eb18bfefe2e6e20d3b425afe945af28
Author: Ronan Desplanques <desplanques@adacore.com>
Date: Mon Oct 24 11:50:06 2022 +0200
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.
Diff:
---
gcc/ada/contracts.adb | 481 ++++++++++++++++++++++++++------------------------
gcc/ada/contracts.ads | 4 +
gcc/ada/sem_prag.adb | 14 ++
3 files changed, 267 insertions(+), 232 deletions(-)
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 21f438f90f3..218fd66852f 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 bde32ffc5b4..ae6355ef410 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 2a3aca85a79..615c6d2110c 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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-11-08 8:42 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-11-08 8:42 [gcc r13-3797] ada: Adjust classwide contract expression preanalysis Marc Poulhi?s
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).