diff options
Diffstat (limited to 'gcc/ada/contracts.adb')
| -rw-r--r-- | gcc/ada/contracts.adb | 483 |
1 files changed, 250 insertions, 233 deletions
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index a300d73..218fd66 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; @@ -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_And_Resolve (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 -- ---------------------------------------- |