From 321c24f75dde674402481f1df0025c8169aa9cdd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:00:46 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Ed Schonberg * sem_ch3.adb (Add_Internal_Interface_Entities): Move Has_Non_Trivial_Precondition to sem_util. for use elsewhere. Improve error message on operations that inherit non-conforming classwide preconditions from ancestor and progenitor. * sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition): moved here from sem_ch3. * sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality check given in RM 6.1.1 (17) concerning renamings of overriding operations that inherits class-wide preconditions from ancestor or progenitor. 2017-04-25 Hristian Kirtchev * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup. (Build_Adjust_Statements): Code cleanup. (Build_Finalizer): Update the initialization of Exceptions_OK. (Build_Finalize_Statements): Code cleanup. (Build_Initialize_Statements): Code cleanup. (Make_Deep_Array_Body): Update the initialization of Exceptions_OK. (Make_Deep_Record_Body): Update the initialization of Exceptions_OK. (Process_Object_Declaration): Generate a null exception handler only when exceptions are allowed. (Process_Transients_In_Scope): Update the initialization of Exceptions_OK. * exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New routine. * sem_ch11.adb (Analyze_Exception_Handlers): Do not check any restrictions when the handler is internally generated and the mode is warnings. 2017-04-25 Ed Schonberg * sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to enforce legality rule on classwide preconditions inherited from both an ancestor and a progenitor (RM 6.1.1 (10-13). * sem_disp.adb (Check_Dispatching_Context): A call to an abstract subprogram need not be dispatching if it appears in a precondition for an abstract or null subprogram. 2017-04-25 Gary Dismukes * sem_ch10.adb: Minor typo fix. From-SVN: r247192 --- gcc/ada/ChangeLog | 47 ++++++++++++++++++ gcc/ada/exp_ch7.adb | 110 +++++++++++++++++++++---------------------- gcc/ada/exp_util.adb | 12 +++++ gcc/ada/exp_util.ads | 4 ++ gcc/ada/sem_ch10.adb | 2 +- gcc/ada/sem_ch11.adb | 20 +++++++- gcc/ada/sem_ch3.adb | 37 +++++++++++++++ gcc/ada/sem_ch8.adb | 13 +++++ gcc/ada/sem_disp.adb | 4 +- gcc/ada/sem_util.adb | 12 +++++ gcc/ada/sem_util.ads | 4 ++ 11 files changed, 203 insertions(+), 62 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 24f3fa2c728..842af1f9939 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2017-04-25 Ed Schonberg + + * sem_ch3.adb (Add_Internal_Interface_Entities): Move + Has_Non_Trivial_Precondition to sem_util. for use elsewhere. + Improve error message on operations that inherit non-conforming + classwide preconditions from ancestor and progenitor. + * sem_util.ads, sem_util.adb (Has_Non_Trivial_Precondition): + moved here from sem_ch3. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality + check given in RM 6.1.1 (17) concerning renamings of overriding + operations that inherits class-wide preconditions from ancestor + or progenitor. + +2017-04-25 Hristian Kirtchev + + * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup. + (Build_Adjust_Statements): Code cleanup. + (Build_Finalizer): Update the initialization of + Exceptions_OK. + (Build_Finalize_Statements): Code cleanup. + (Build_Initialize_Statements): Code cleanup. + (Make_Deep_Array_Body): Update the initialization of + Exceptions_OK. + (Make_Deep_Record_Body): Update the initialization of Exceptions_OK. + (Process_Object_Declaration): Generate a null exception handler only + when exceptions are allowed. + (Process_Transients_In_Scope): Update the initialization of + Exceptions_OK. + * exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New + routine. + * sem_ch11.adb (Analyze_Exception_Handlers): Do not check any + restrictions when the handler is internally generated and the + mode is warnings. + +2017-04-25 Ed Schonberg + + * sem_ch3.adb (Has_Non_Trivial_Precondition): New predicate to + enforce legality rule on classwide preconditions inherited from + both an ancestor and a progenitor (RM 6.1.1 (10-13). + * sem_disp.adb (Check_Dispatching_Context): A call to an abstract + subprogram need not be dispatching if it appears in a precondition + for an abstract or null subprogram. + +2017-04-25 Gary Dismukes + + * sem_ch10.adb: Minor typo fix. + 2017-04-25 Arnaud Charlet * gcc-interface/Makefile.in: Cleanup VxWorks targets. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 56414e00a62..d20b5389a45 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1327,8 +1327,7 @@ package body Exp_Ch7 is or else (Present (Clean_Stmts) and then Is_Non_Empty_List (Clean_Stmts)); - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); + Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; For_Package : constant Boolean := @@ -2844,7 +2843,7 @@ package body Exp_Ch7 is Body_Ins : Node_Id; Count_Ins : Node_Id; Fin_Call : Node_Id; - Fin_Stmts : List_Id; + Fin_Stmts : List_Id := No_List; Inc_Decl : Node_Id; Label : Node_Id; Label_Id : Entity_Id; @@ -3004,8 +3003,6 @@ package body Exp_Ch7 is -- manual finalization of their lock managers. if Is_Protected then - Fin_Stmts := No_List; - if Is_Simple_Protected_Type (Obj_Typ) then Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref); @@ -3031,8 +3028,8 @@ package body Exp_Ch7 is -- null; -- end; - if Present (Fin_Stmts) then - Append_To (Finalizer_Stmts, + if Present (Fin_Stmts) and then Exceptions_OK then + Fin_Stmts := New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -4866,8 +4863,7 @@ package body Exp_Ch7 is Last_Object : Node_Id; Related_Node : Node_Id) is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); + Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; Must_Hook : Boolean := False; -- Flag denoting whether the context requires transient object @@ -5529,6 +5525,8 @@ package body Exp_Ch7 is (Prim : Final_Primitives; Typ : Entity_Id) return List_Id is + Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; + function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id; -- Create the statements necessary to adjust or finalize an array of @@ -5645,12 +5643,10 @@ package body Exp_Ch7 is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); procedure Build_Indexes; -- Generate the indexes used in the dimension loops @@ -5822,13 +5818,11 @@ package body Exp_Ch7 is --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); function Build_Assignment (Counter_Id : Entity_Id) return Node_Id; -- Generate the following assignment: @@ -6349,6 +6343,8 @@ package body Exp_Ch7 is Typ : Entity_Id; Is_Local : Boolean := False) return List_Id is + Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; + function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; -- Build the statements necessary to adjust a record type. The type may -- have discriminants and contain variant parts. Generate: @@ -6498,17 +6494,10 @@ package body Exp_Ch7 is ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := - Type_Definition (Parent (Typ)); + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Bod_Stmts : List_Id; - Finalizer_Data : Finalization_Exception_Data; - Finalizer_Decls : List_Id := No_List; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Finalizer_Data : Finalization_Exception_Data; function Process_Component_List_For_Adjust (Comps : Node_Id) return List_Id; @@ -6581,6 +6570,7 @@ package body Exp_Ch7 is Decl_Typ : Entity_Id; Has_POC : Boolean; Num_Comps : Nat; + Var_Case : Node_Id; -- Start of processing for Process_Component_List_For_Adjust @@ -6710,6 +6700,12 @@ package body Exp_Ch7 is return Stmts; end Process_Component_List_For_Adjust; + -- Local variables + + Bod_Stmts : List_Id; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + -- Start of processing for Build_Adjust_Statements begin @@ -6914,18 +6910,12 @@ package body Exp_Ch7 is ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := - Type_Definition (Parent (Typ)); + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Bod_Stmts : List_Id; - Counter : Int := 0; - Finalizer_Data : Finalization_Exception_Data; - Finalizer_Decls : List_Id := No_List; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Counter : Int := 0; + Finalizer_Data : Finalization_Exception_Data; + Num_Comps : Nat := 0; function Process_Component_List_For_Finalize (Comps : Node_Id) return List_Id; @@ -6940,19 +6930,6 @@ package body Exp_Ch7 is function Process_Component_List_For_Finalize (Comps : Node_Id) return List_Id is - Alts : List_Id; - Counter_Id : Entity_Id; - Decl : Node_Id; - Decl_Id : Entity_Id; - Decl_Typ : Entity_Id; - Decls : List_Id; - Has_POC : Boolean; - Jump_Block : Node_Id; - Label : Node_Id; - Label_Id : Entity_Id; - Num_Comps : Nat; - Stmts : List_Id; - procedure Process_Component_For_Finalize (Decl : Node_Id; Alts : List_Id; @@ -7066,6 +7043,21 @@ package body Exp_Ch7 is end if; end Process_Component_For_Finalize; + -- Local variables + + Alts : List_Id; + Counter_Id : Entity_Id; + Decl : Node_Id; + Decl_Id : Entity_Id; + Decl_Typ : Entity_Id; + Decls : List_Id; + Has_POC : Boolean; + Jump_Block : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + Stmts : List_Id; + Var_Case : Node_Id; + -- Start of processing for Process_Component_List_For_Finalize begin @@ -7286,6 +7278,12 @@ package body Exp_Ch7 is end if; end Process_Component_List_For_Finalize; + -- Local variables + + Bod_Stmts : List_Id; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + -- Start of processing for Build_Finalize_Statements begin diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bced508c7b2..db6a8582adb 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4784,6 +4784,18 @@ package body Exp_Util is end if; end Evolve_Or_Else; + ----------------------------------- + -- Exceptions_In_Finalization_OK -- + ----------------------------------- + + function Exceptions_In_Finalization_OK return Boolean is + begin + return + not (Restriction_Active (No_Exception_Handlers) or else + Restriction_Active (No_Exception_Propagation) or else + Restriction_Active (No_Exceptions)); + end Exceptions_In_Finalization_OK; + ----------------------------------------- -- Expand_Static_Predicates_In_Choices -- ----------------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 0a409f3d22c..ee12a240d41 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -535,6 +535,10 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. + function Exceptions_In_Finalization_OK return Boolean; + -- Determine whether the finalization machinery can safely add exception + -- handlers and recovery circuitry. + procedure Expand_Static_Predicates_In_Choices (N : Node_Id); -- N is either a case alternative or a variant. The Discrete_Choices field -- of N points to a list of choices. If any of these choices is the name diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 31bf27f4a32..3559e8e7f09 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1134,7 +1134,7 @@ package body Sem_Ch10 is Style_Check := Save_Style_Check; end; - -- In GNATprove mode, force the loading of a Interrupt_Priority when + -- In GNATprove mode, force the loading of an Interrupt_Priority when -- processing compilation units with potentially "main" subprograms. -- This is required for the ceiling priority protocol checks, which -- are triggered by these subprograms. diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 3e71b543c97..13ba280a1c5 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -165,8 +165,24 @@ package body Sem_Ch11 is begin Handler := First (L); - Check_Restriction (No_Exceptions, Handler); - Check_Restriction (No_Exception_Handlers, Handler); + + -- Pragma Restriction_Warnings has more related semantics than pragma + -- Restrictions in that it flags exception handlers as violators. Note + -- that the compiler must still generate handlers for certain critical + -- scenarios such as finalization. As a result, these handlers should + -- not be subjected to the restriction check when in warnings mode. + + if not Comes_From_Source (Handler) + and then (Restriction_Warnings (No_Exception_Handlers) + or else Restriction_Warnings (No_Exception_Propagation) + or else Restriction_Warnings (No_Exceptions)) + then + null; + + else + Check_Restriction (No_Exceptions, Handler); + Check_Restriction (No_Exception_Handlers, Handler); + end if; -- Kill current remembered values, since we don't know where we were -- when the exception was raised. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a40f64ec0f3..7a0feef8c25 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1717,6 +1717,43 @@ package body Sem_Ch3 is Derived_Type => Tagged_Type, Parent_Type => Iface); + declare + Anc : Entity_Id; + begin + if Is_Inherited_Operation (Prim) + and then Present (Alias (Prim)) + then + Anc := Alias (Prim); + else + Anc := Overridden_Operation (Prim); + end if; + + -- Apply legality checks in RM 6.1.1 (10-13) concerning + -- non-conforming preconditions in both an ancestor and + -- a progenitor operation. + + if Present (Anc) + and then Has_Non_Trivial_Precondition (Anc) + and then Has_Non_Trivial_Precondition (Iface_Prim) + then + if Is_Abstract_Subprogram (Prim) + or else (Ekind (Prim) = E_Procedure + and then + Nkind (Parent (Prim)) = N_Procedure_Specification + and then Null_Present (Parent (Prim))) + then + null; + + -- The inherited operation must be overridden + + elsif not Comes_From_Source (Prim) then + Error_Msg_NE ("&inherits non-conforming preconditions " + & "and must be overridden (RM 6.1.1 (10-16)", + Parent (Tagged_Type), Prim); + end if; + end if; + end; + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp -- associated with interface types. These entities are -- only registered in the list of primitives of its diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 2b9a681cd5c..4c7de392d93 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3191,6 +3191,19 @@ package body Sem_Ch8 is ("renamed entity cannot be subprogram that requires overriding " & "(RM 8.5.4 (5.1))", N); end if; + + declare + Prev : constant Entity_Id := Overridden_Operation (New_S); + begin + if Present (Prev) + and then + (Has_Non_Trivial_Precondition (Prev) + or else Has_Non_Trivial_Precondition (Old_S)) + then + Error_Msg_NE ("conflicting inherited classwide preconditions " + & "in renaming of& (RM 6.1.1 (17)", N, Old_S); + end if; + end; end if; if Old_S /= Any_Id then diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 8dd6de88aa2..e322894fd6b 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -574,9 +574,7 @@ package body Sem_Disp is -- a primitive of an abstract type. The call is non-dispatching -- but will be legal in overridings of the operation. - elsif In_Spec_Expression - and then - (Is_Subprogram (Scop) + elsif (Is_Subprogram (Scop) or else Chars (Scop) = Name_Postcondition) and then (Is_Abstract_Subprogram (Scop) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1cadd47af93..34ef713319a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9820,6 +9820,18 @@ package body Sem_Util is and then Nkind (Node (First_Elmt (Constits))) /= N_Null; end Has_Non_Null_Refinement; + ---------------------------------- + -- Has_Non_Trivial_Precondition -- + ---------------------------------- + + function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is + Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre); + begin + return Present (Cont) + and then Class_Present (Cont) + and then not Is_Entity_Name (Expression (Cont)); + end Has_Non_Trivial_Precondition; + ------------------- -- Has_Null_Body -- ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e3afc1bec0a..0d5de62d5fc 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1169,6 +1169,10 @@ package Sem_Util is -- null statement, possibly followed by an optional return. Used to -- optimize useless calls to assertion checks. + function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean; + -- True if subprogram has a class-wide precondition that is not + -- statically True. + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion -- 2.30.2