From 788e5f06d4e804dcc9e255fa448ba0c3db1586c4 Mon Sep 17 00:00:00 2001 From: Ronan Desplanques Date: Mon, 17 Oct 2022 12:00:09 +0200 Subject: ada: Preanalyze classwide contracts as spec expressions Classwide contracts are "spec expressions" as defined in the documentation in sem.ads. Before this patch, the instances of classwide contracts that are destined to class conditions merging were not preanalyzed as spec expressions. That caused preanalysis to emit spurious errors in some cases. gcc/ada/ * contracts.adb (Preanalyze_Condition): Use Preanalyze_Spec_Expression. --- gcc/ada/contracts.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada/contracts.adb') diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index a300d739eff..21f438f90f3 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -42,13 +42,13 @@ with Nmake; use Nmake; with Opt; use Opt; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -4755,7 +4755,7 @@ package body Contracts is Install_Formals (Subp); Inside_Class_Condition_Preanalysis := True; - Preanalyze_And_Resolve (Expr, Standard_Boolean); + Preanalyze_Spec_Expression (Expr, Standard_Boolean); Inside_Class_Condition_Preanalysis := False; Remove_Formals (Subp); -- cgit v1.2.1 From 45656a992eb18bfefe2e6e20d3b425afe945af28 Mon Sep 17 00:00:00 2001 From: Ronan Desplanques Date: Mon, 24 Oct 2022 11:50:06 +0200 Subject: 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. --- gcc/ada/contracts.adb | 481 ++++++++++++++++++++++++++------------------------ 1 file changed, 249 insertions(+), 232 deletions(-) (limited to 'gcc/ada/contracts.adb') 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 -- ---------------------------------------- -- cgit v1.2.1