diff options
| -rw-r--r-- | gcc/ada/contracts.adb | 164 |
1 files changed, 58 insertions, 106 deletions
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 98f469b..1902fbb 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; ---------------------- |