From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id A07713858030; Thu, 6 Jan 2022 17:13:01 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org A07713858030 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-6292] [Ada] Crash in class-wide pre/postconditions X-Act-Checkin: gcc X-Git-Author: Javier Miranda X-Git-Refname: refs/heads/master X-Git-Oldrev: 2a3652640b612c1e7619dfa10c096f3adc750b41 X-Git-Newrev: bfbb8de66079be551f08cdab38cafa766bb29e78 Message-Id: <20220106171301.A07713858030@sourceware.org> Date: Thu, 6 Jan 2022 17:13:01 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Thu, 06 Jan 2022 17:13:01 -0000 https://gcc.gnu.org/g:bfbb8de66079be551f08cdab38cafa766bb29e78 commit r12-6292-gbfbb8de66079be551f08cdab38cafa766bb29e78 Author: Javier Miranda Date: Mon Nov 29 18:12:47 2021 +0000 [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. Diff: --- gcc/ada/contracts.adb | 164 ++++++++++++++++++-------------------------------- 1 file changed, 58 insertions(+), 106 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 98f469bf5b7..1902fbb8863 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; ----------------------