From: Hristian Kirtchev Date: Wed, 23 May 2018 10:22:15 +0000 (+0000) Subject: [Ada] Suppression of elaboration-related warnings X-Git-Tag: upstream/12.2.0~31636 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=162ed06fb32b64802db9909e27c447527dd759ee;p=platform%2Fupstream%2Fgcc.git [Ada] Suppression of elaboration-related warnings This patch changes the behavior of elaboration-related warnings as follows: * If a scenario or a target has [elaboration] warnings suppressed, then any further elaboration-related warnings along the paths rooted at the scenario are also suppressed. * Elaboration-related warnings related to task activation can now be suppressed when either the task object, task type, or the activation call have [elaboration] warnings suppressed. * Elaboration-related warnings related to calls can now be suppressed when either the target or the call have [elaboration] warnings suppressed. * Elaboration-related warnings related to instantiations can now be suppressed when the instantiation has [elaboration] warnings suppressed. The patch also cleans up the way the state of the Processing phase is updated with each new node along a path. It is now preferable to update the state in routines Process_Conditional_ABE_Activation_Impl Process_Conditional_ABE_Call Process_Conditional_ABE_Instantiation rather than within their language-specific versions. 2018-05-23 Hristian Kirtchev gcc/ada/ * einfo.adb: Flag304 is now Is_Elaboration_Warnings_OK_Id. (Is_Elaboration_Warnings_OK_Id): New routine. (Set_Is_Elaboration_Warnings_OK_Id): New routine. (Write_Entity_Flags): Output Flag304. * einfo.ads: Add new attribute Is_Elaboration_Warnings_OK_Id along with occurrences in entities. (Is_Elaboration_Warnings_OK_Id): New routine along with pragma Inline. (Set_Is_Elaboration_Warnings_OK_Id): New routine along with pragma Inline. * sem_attr.adb (Analyze_Access_Attribute): Capture the state of elaboration warnings. * sem_ch3.adb (Analyze_Object_Declaration): Capture the state of elaboration warnings. * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Capture the state of elaboration warnings. (Analyze_Subprogram_Body_Helper): Capture the state of elaboration warnings. (Analyze_Subprogram_Declaration): Capture the state of elaboration warnings. * sem_ch9.adb (Analyze_Entry_Declaration): Capture the state of elaboration warnings. (Analyze_Single_Task_Declaration): Capture the state of elaboration warnings. (Analyze_Task_Type_Declaration): Capture the state of elaboration warnings. * sem_ch12.adb (Analyze_Generic_Package_Declaration): Capture the state of elaboration warnings. (Analyze_Generic_Subprogram_Declaration): Capture the state of elaboration warnings. * sem_elab.adb: Add a section on suppressing elaboration warnings. Type Processing_Attributes includes component Suppress_Warnings intended to suppress any elaboration warnings along a path in the graph. Update Initial_State to include a value for this component. Types Target_Attributes and Task_Attriutes include component Elab_Warnings_OK to indicate whether the target or task has elaboration warnings enabled. component Elab_Warnings_OK. (Build_Access_Marker): Propagate attribute Is_Elaboration_Warnings_OK_Node from the attribute to the generated call marker. (Extract_Instantiation_Attributes): Set the value for Elab_Warnings_OK. (Extract_Target_Attributes): Set the value for Elab_Warnings_OK. (Extract_Task_Attributes): Set the value for Elab_Warnings_OK. (Process_Conditional_ABE_Access): Suppress futher elaboration warnings when already in this mode or when the attribute or target have warnings suppressed. (Process_Conditional_ABE_Activation_Impl): Do not emit any diagnostics if warnings are suppressed. (Process_Conditional_ABE_Call): Suppress further elaboration warnings when already in this mode, or the target or call have warnings suppressed. (Process_Conditional_ABE_Call_Ada): Do not emit any diagnostics if warnings are suppressed. (Process_Conditional_ABE_Call_SPARK): Do not emit any diagnostics if warnings are suppressed. (Process_Conditional_ABE_Instantiation): Suppress further elaboration warnings when already in this mode or when the instantiation has warnings suppressed. (Process_Conditional_ABE_Instantiation_Ada): Do not emit any diagnostics if warnings are suppressed. (Process_Conditional_ABE_Variable_Assignment_Ada): Use the more specific Is_Elaboration_Warnings_OK_Id rather than Warnings_Off. (Process_Conditional_ABE_Variable_Assignment_SPARK): Use the more specific Is_Elaboration_Warnings_OK_Id rather than Warnings_Off. (Process_Task_Object): Suppress further elaboration warnings when already in this mode, or when the object, activation call, or task type have warnings suppressed. Update the processing state to indicate that the path goes through a task body. * sinfo.adb (Is_Elaboration_Warnings_OK_Node): Accept attribute references. (Set_Is_Elaboration_Warnings_OK_Node): Accept attribute references. * sinfo.ads: Attribute Is_Elaboration_Warnings_OK_Node now applies to attribute references. gcc/testsuite/ * gnat.dg/elab4.adb, gnat.dg/elab4_pkg.adb, gnat.dg/elab4_pkg.ads: New testcase. From-SVN: r260578 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 616697b..6f495c1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,78 @@ +2018-05-23 Hristian Kirtchev + + * einfo.adb: Flag304 is now Is_Elaboration_Warnings_OK_Id. + (Is_Elaboration_Warnings_OK_Id): New routine. + (Set_Is_Elaboration_Warnings_OK_Id): New routine. + (Write_Entity_Flags): Output Flag304. + * einfo.ads: Add new attribute Is_Elaboration_Warnings_OK_Id along with + occurrences in entities. + (Is_Elaboration_Warnings_OK_Id): New routine along with pragma Inline. + (Set_Is_Elaboration_Warnings_OK_Id): New routine along with pragma + Inline. + * sem_attr.adb (Analyze_Access_Attribute): Capture the state of + elaboration warnings. + * sem_ch3.adb (Analyze_Object_Declaration): Capture the state of + elaboration warnings. + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Capture the + state of elaboration warnings. + (Analyze_Subprogram_Body_Helper): Capture the state of elaboration + warnings. + (Analyze_Subprogram_Declaration): Capture the state of elaboration + warnings. + * sem_ch9.adb (Analyze_Entry_Declaration): Capture the state of + elaboration warnings. + (Analyze_Single_Task_Declaration): Capture the state of elaboration + warnings. + (Analyze_Task_Type_Declaration): Capture the state of elaboration + warnings. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): Capture the state + of elaboration warnings. + (Analyze_Generic_Subprogram_Declaration): Capture the state of + elaboration warnings. + * sem_elab.adb: Add a section on suppressing elaboration warnings. + Type Processing_Attributes includes component Suppress_Warnings + intended to suppress any elaboration warnings along a path in the + graph. Update Initial_State to include a value for this component. + Types Target_Attributes and Task_Attriutes include component + Elab_Warnings_OK to indicate whether the target or task has elaboration + warnings enabled. component Elab_Warnings_OK. + (Build_Access_Marker): Propagate attribute + Is_Elaboration_Warnings_OK_Node from the attribute to the generated + call marker. + (Extract_Instantiation_Attributes): Set the value for Elab_Warnings_OK. + (Extract_Target_Attributes): Set the value for Elab_Warnings_OK. + (Extract_Task_Attributes): Set the value for Elab_Warnings_OK. + (Process_Conditional_ABE_Access): Suppress futher elaboration warnings + when already in this mode or when the attribute or target have warnings + suppressed. + (Process_Conditional_ABE_Activation_Impl): Do not emit any diagnostics + if warnings are suppressed. + (Process_Conditional_ABE_Call): Suppress further elaboration warnings + when already in this mode, or the target or call have warnings + suppressed. + (Process_Conditional_ABE_Call_Ada): Do not emit any diagnostics if + warnings are suppressed. + (Process_Conditional_ABE_Call_SPARK): Do not emit any diagnostics if + warnings are suppressed. + (Process_Conditional_ABE_Instantiation): Suppress further elaboration + warnings when already in this mode or when the instantiation has + warnings suppressed. + (Process_Conditional_ABE_Instantiation_Ada): Do not emit any + diagnostics if warnings are suppressed. + (Process_Conditional_ABE_Variable_Assignment_Ada): Use the more + specific Is_Elaboration_Warnings_OK_Id rather than Warnings_Off. + (Process_Conditional_ABE_Variable_Assignment_SPARK): Use the more + specific Is_Elaboration_Warnings_OK_Id rather than Warnings_Off. + (Process_Task_Object): Suppress further elaboration warnings when + already in this mode, or when the object, activation call, or task type + have warnings suppressed. Update the processing state to indicate that + the path goes through a task body. + * sinfo.adb (Is_Elaboration_Warnings_OK_Node): Accept attribute + references. + (Set_Is_Elaboration_Warnings_OK_Node): Accept attribute references. + * sinfo.ads: Attribute Is_Elaboration_Warnings_OK_Node now applies to + attribute references. + 2018-05-23 Piotr Trojanek * einfo.ads: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 339faa6..47d4f25 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -627,8 +627,8 @@ package body Einfo is -- Ignore_SPARK_Mode_Pragmas Flag301 -- Is_Initial_Condition_Procedure Flag302 -- Suppress_Elaboration_Warnings Flag303 + -- Is_Elaboration_Warnings_OK_Id Flag304 - -- (unused) Flag304 -- (unused) Flag305 -- (unused) Flag306 -- (unused) Flag307 @@ -2262,6 +2262,17 @@ package body Einfo is return Flag148 (Id); end Is_Elaboration_Checks_OK_Id; + function Is_Elaboration_Warnings_OK_Id (Id : E) return B is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable, E_Void) + or else Is_Entry (Id) + or else Is_Generic_Unit (Id) + or else Is_Subprogram (Id) + or else Is_Task_Type (Id)); + return Flag304 (Id); + end Is_Elaboration_Warnings_OK_Id; + function Is_Eliminated (Id : E) return B is begin return Flag124 (Id); @@ -5476,6 +5487,17 @@ package body Einfo is Set_Flag148 (Id, V); end Set_Is_Elaboration_Checks_OK_Id; + procedure Set_Is_Elaboration_Warnings_OK_Id (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable) + or else Is_Entry (Id) + or else Is_Generic_Unit (Id) + or else Is_Subprogram (Id) + or else Is_Task_Type (Id)); + Set_Flag304 (Id, V); + end Set_Is_Elaboration_Warnings_OK_Id; + procedure Set_Is_Eliminated (Id : E; V : B := True) is begin Set_Flag124 (Id, V); @@ -9685,6 +9707,7 @@ package body Einfo is W ("Is_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Dispatching_Operation", Flag6 (Id)); W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id)); + W ("Is_Elaboration_Warnings_OK_Id", Flag304 (Id)); W ("Is_Eliminated", Flag124 (Id)); W ("Is_Entry_Formal", Flag52 (Id)); W ("Is_Exception_Handler", Flag286 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d6522d1..5fc3071 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2522,6 +2522,10 @@ package Einfo is -- checks. Such targets are allowed to generate run-time conditional ABE -- checks or guaranteed ABE failures. +-- Is_Elaboration_Warnings_OK_Id (Flag304) +-- Defined in elaboration targets (see terminology in Sem_Elab). Set when +-- the target appears in a region with elaboration warnings enabled. + -- Is_Elementary_Type (synthesized) -- Applies to all entities, true for all elementary types and subtypes. -- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true @@ -5949,6 +5953,7 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Elaboration_Checks_OK_Id (Flag148) (constants only) + -- Is_Elaboration_Warnings_OK_Id (Flag304) (constants only) -- Is_Eliminated (Flag124) -- Is_Finalized_Transient (Flag252) -- Is_Ignored_Transient (Flag295) @@ -6026,6 +6031,7 @@ package Einfo is -- Has_Expanded_Contract (Flag240) -- Ignore_SPARK_Mode_Pragmas (Flag301) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Entry_Wrapper (Flag297) -- Needs_No_Actuals (Flag22) -- Sec_Stack_Needed_For_Return (Flag167) @@ -6166,6 +6172,7 @@ package Einfo is -- Is_Discrim_SO_Function (Flag176) -- Is_Discriminant_Check_Function (Flag264) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) @@ -6316,6 +6323,7 @@ package Einfo is -- Has_Nested_Subprogram (Flag282) -- Ignore_SPARK_Mode_Pragmas (Flag301) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Intrinsic_Subprogram (Flag64) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Primitive (Flag218) @@ -6383,6 +6391,7 @@ package Einfo is -- In_Package_Body (Flag48) -- In_Use (Flag8) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Instantiated (Flag126) -- Is_Private_Descendant (Flag53) -- Is_Visible_Lib_Unit (Flag116) @@ -6486,6 +6495,7 @@ package Einfo is -- Is_Constructor (Flag76) -- Is_DIC_Procedure (Flag132) (non-generic case only) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) @@ -6697,6 +6707,7 @@ package Einfo is -- Has_Storage_Size_Clause (Flag23) (base type only) -- Ignore_SPARK_Mode_Pragmas (Flag301) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- SPARK_Aux_Pragma_Inherited (Flag266) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) @@ -6745,6 +6756,7 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Elaboration_Checks_OK_Id (Flag148) + -- Is_Elaboration_Warnings_OK_Id (Flag304) -- Is_Eliminated (Flag124) -- Is_Finalized_Transient (Flag252) -- Is_Ignored_Transient (Flag295) @@ -7264,6 +7276,7 @@ package Einfo is function Is_Dispatch_Table_Entity (Id : E) return B; function Is_Dispatching_Operation (Id : E) return B; function Is_Elaboration_Checks_OK_Id (Id : E) return B; + function Is_Elaboration_Warnings_OK_Id (Id : E) return B; function Is_Eliminated (Id : E) return B; function Is_Entry_Formal (Id : E) return B; function Is_Entry_Wrapper (Id : E) return B; @@ -7959,6 +7972,7 @@ package Einfo is procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True); procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True); + procedure Set_Is_Elaboration_Warnings_OK_Id (Id : E; V : B := True); procedure Set_Is_Eliminated (Id : E; V : B := True); procedure Set_Is_Entry_Formal (Id : E; V : B := True); procedure Set_Is_Entry_Wrapper (Id : E; V : B := True); @@ -8787,6 +8801,7 @@ package Einfo is pragma Inline (Is_Dispatch_Table_Entity); pragma Inline (Is_Dispatching_Operation); pragma Inline (Is_Elaboration_Checks_OK_Id); + pragma Inline (Is_Elaboration_Warnings_OK_Id); pragma Inline (Is_Elementary_Type); pragma Inline (Is_Eliminated); pragma Inline (Is_Entry); @@ -9303,6 +9318,7 @@ package Einfo is pragma Inline (Set_Is_Dispatch_Table_Entity); pragma Inline (Set_Is_Dispatching_Operation); pragma Inline (Set_Is_Elaboration_Checks_OK_Id); + pragma Inline (Set_Is_Elaboration_Warnings_OK_Id); pragma Inline (Set_Is_Eliminated); pragma Inline (Set_Is_Entry_Formal); pragma Inline (Set_Is_Entry_Wrapper); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 6e87453..a7063d0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -813,9 +813,10 @@ package body Sem_Attr is -- analysis, resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => N, - Checks => True, - Modes => True); + (N_Id => N, + Checks => True, + Modes => True, + Warnings => True); -- Save the scenario for later examination by the ABE Processing -- phase. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index d8721a5..6bfe989 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3564,8 +3564,9 @@ package body Sem_Ch12 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Id, - Checks => True); + (N_Id => Id, + Checks => True, + Warnings => True); -- Analyze aspects now, so that generated pragmas appear in the -- declarations before building and analyzing the generic copy. @@ -3738,8 +3739,9 @@ package body Sem_Ch12 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Id, - Checks => True); + (N_Id => Id, + Checks => True, + Warnings => True); Formals := Parameter_Specifications (Spec); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 965596a..3316ff7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4758,8 +4758,9 @@ package body Sem_Ch3 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Id, - Checks => True); + (N_Id => Id, + Checks => True, + Warnings => True); -- Initialize alignment and size and capture alignment setting diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ccd9bd5..997f4ed 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -236,8 +236,9 @@ package body Sem_Ch6 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Subp_Id, - Checks => True); + (N_Id => Subp_Id, + Checks => True, + Warnings => True); Set_Is_Abstract_Subprogram (Subp_Id); New_Overloaded_Entity (Subp_Id); @@ -4148,6 +4149,17 @@ package body Sem_Ch6 is end if; end if; + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + if No (Spec_Id) then + Mark_Elaboration_Attributes + (N_Id => Body_Id, + Checks => True, + Warnings => True); + end if; + -- If this is the proper body of a stub, we must verify that the stub -- conforms to the body, and to the previous spec if one was present. -- We know already that the body conforms to that spec. This test is @@ -4785,8 +4797,9 @@ package body Sem_Ch6 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Designator, - Checks => True); + (N_Id => Designator, + Checks => True, + Warnings => True); if Debug_Flag_C then Write_Str ("==> subprogram spec "); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e487391..b049930 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1662,8 +1662,9 @@ package body Sem_Ch9 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Def_Id, - Checks => True); + (N_Id => Def_Id, + Checks => True, + Warnings => True); -- Process formals @@ -2866,8 +2867,9 @@ package body Sem_Ch9 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => Obj_Id, - Checks => True); + (N_Id => Obj_Id, + Checks => True, + Warnings => True); -- Instead of calling Analyze on the new node, call the proper analysis -- procedure directly. Otherwise the node would be expanded twice, with @@ -3137,8 +3139,9 @@ package body Sem_Ch9 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => T, - Checks => True); + (N_Id => T, + Checks => True, + Warnings => True); Push_Scope (T); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 4987f93..0ec49c1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -372,6 +372,56 @@ package body Sem_Elab is -- The diagnostics of the ABE mechanism depend on accurate source locations -- to determine the spacial relation of nodes. + ----------------------------------------- + -- Suppression of elaboration warnings -- + ----------------------------------------- + + -- Elaboration warnings along multiple traversal paths rooted at a scenario + -- are suppressed when the scenario has elaboration warnings suppressed. + -- + -- Root scenario + -- | + -- +-- Child scenario 1 + -- | | + -- | +-- Grandchild scenario 1 + -- | | + -- | +-- Grandchild scenario N + -- | + -- +-- Child scenario N + -- + -- If the root scenario has elaboration warnings suppressed, then all its + -- child, grandchild, etc. scenarios will have their elaboration warnings + -- suppressed. + -- + -- In addition to switch -gnatwL, pragma Warnings may be used to suppress + -- elaboration-related warnings by wrapping a construct in the following + -- manner: + -- + -- pragma Warnings ("L"); + -- + -- pragma Warnings ("l"); + -- + -- * To suppress elaboration warnings for '[Unrestricted_]Access of + -- entries, operators, and subprograms, either: + -- + -- - Wrap the entry, operator, or subprogram, or + -- - Wrap the attribute, or + -- - Use switch -gnatw.f + -- + -- * To suppress elaboration warnings for calls to entries, operators, + -- and subprograms, either: + -- + -- - Wrap the entry, operator, or subprogram, or + -- - Wrap the call + -- + -- * To suppress elaboration warnings for instantiations, wrap the + -- instantiation. + -- + -- * To suppress elaboration warnings for task activations, either: + -- + -- - Wrap the task object, or + -- - Wrap the task type + -------------- -- Switches -- -------------- @@ -718,6 +768,10 @@ package body Sem_Elab is -- This flag is set when the Processing phase must not generate any -- implicit Elaborate[_All] pragmas. + Suppress_Warnings : Boolean; + -- This flag is set when the Processing phase must not emit any warnings + -- on elaboration problems. + Within_Initial_Condition : Boolean; -- This flag is set when the Processing phase is currently examining a -- scenario which was reached from an initial condition procedure. @@ -737,6 +791,7 @@ package body Sem_Elab is Initial_State : constant Processing_Attributes := (Suppress_Implicit_Pragmas => False, + Suppress_Warnings => False, Within_Initial_Condition => False, Within_Instance => False, Within_Partial_Finalization => False, @@ -749,6 +804,9 @@ package body Sem_Elab is Elab_Checks_OK : Boolean; -- This flag is set when the target has elaboration checks enabled + Elab_Warnings_OK : Boolean; + -- This flag is set when the target has elaboration warnings enabled + From_Source : Boolean; -- This flag is set when the target comes from source @@ -831,6 +889,9 @@ package body Sem_Elab is Elab_Checks_OK : Boolean; -- This flag is set when the task type has elaboration checks enabled + Elab_Warnings_OK : Boolean; + -- This flag is set when the task type has elaboration warnings enabled + Ghost_Mode_Ignore : Boolean; -- This flag is set when the task type appears in a region subject to -- pragma Ghost with policy ignore, or starts one such region. @@ -4090,6 +4151,7 @@ package body Sem_Elab is Attrs.Body_Barf := Body_Barf; Attrs.Body_Decl := Body_Decl; Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id); Attrs.From_Source := Comes_From_Source (Target_Id); Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); Attrs.SPARK_Mode_On := @@ -4140,6 +4202,7 @@ package body Sem_Elab is Attrs.Body_Decl := Body_Decl; Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ); Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); Attrs.SPARK_Mode_On := Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; @@ -8392,8 +8455,8 @@ package body Sem_Elab is -- component. procedure Process_Task_Objects (List : List_Id); - -- Perform ABE checks and diagnostics for all task objects found in - -- the list List. + -- Perform ABE checks and diagnostics for all task objects found in the + -- list List. ------------------------- -- Process_Task_Object -- @@ -8405,30 +8468,54 @@ package body Sem_Elab is Comp_Id : Entity_Id; Task_Attrs : Task_Attributes; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin if Is_Task_Type (Typ) then Extract_Task_Attributes (Typ => Base_Typ, Attrs => Task_Attrs); + -- Warnings are suppressed when a prior scenario is already in + -- that mode, or when the object, activation call, or task type + -- have warnings suppressed. Update the state of the Processing + -- phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) + or else not Call_Attrs.Elab_Warnings_OK + or else not Task_Attrs.Elab_Warnings_OK; + + -- Update the state of the Processing phase to indicate that any + -- further traversal is now within a task body. + + New_State.Within_Task_Body := True; + Process_Single_Activation (Call => Call, Call_Attrs => Call_Attrs, Obj_Id => Obj_Id, Task_Attrs => Task_Attrs, - State => State); + State => New_State); -- Examine the component type when the object is an array elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then - Process_Task_Object (Obj_Id, Component_Type (Typ)); + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Component_Type (Typ)); -- Examine individual component types when the object is a record elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then Comp_Id := First_Component (Typ); while Present (Comp_Id) loop - Process_Task_Object (Obj_Id, Etype (Comp_Id)); + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Comp_Id)); + Next_Component (Comp_Id); end loop; end if; @@ -8454,7 +8541,9 @@ package body Sem_Elab is Item_Typ := Etype (Item_Id); if Has_Task (Item_Typ) then - Process_Task_Object (Item_Id, Item_Typ); + Process_Task_Object + (Obj_Id => Item_Id, + Typ => Item_Typ); end if; end if; @@ -8558,6 +8647,8 @@ package body Sem_Elab is (Marker, False); Set_Is_Elaboration_Checks_OK_Node (Marker, Is_Elaboration_Checks_OK_Node (Attr)); + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Is_Elaboration_Warnings_OK_Node (Attr)); Set_Is_Source_Call (Marker, Comes_From_Source (Attr)); Set_Is_SPARK_Mode_On_Node @@ -8578,6 +8669,9 @@ package body Sem_Elab is Target_Attrs : Target_Attributes; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + -- Start of processing for Process_Conditional_ABE_Access begin @@ -8593,6 +8687,21 @@ package body Sem_Elab is (Target_Id => Target_Id, Attrs => Target_Attrs); + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the attribute or the target have warnings suppressed. + -- Update the state of the Processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Is_Elaboration_Warnings_OK_Node (Attr) + or else not Target_Attrs.Elab_Warnings_OK; + + -- Do not emit any ABE diagnostics when the current or previous scenario + -- in this traversal has suppressed elaboration warnings. + + if New_State.Suppress_Warnings then + null; + -- Both the attribute and the corresponding body are in the same unit. -- The corresponding body must appear prior to the root scenario which -- started the recursive search. If this is not the case, then there is @@ -8600,7 +8709,7 @@ package body Sem_Elab is -- Emit a warning only when switch -gnatw.f (warnings on suspucious -- 'Access) is in effect. - if Warn_On_Elab_Access + elsif Warn_On_Elab_Access and then Present (Target_Attrs.Body_Decl) and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) @@ -8620,7 +8729,7 @@ package body Sem_Elab is if Debug_Flag_Dot_O then Process_Conditional_ABE (N => Build_Access_Marker (Target_Id), - State => State); + State => New_State); -- Otherwise ensure that the unit with the corresponding body is -- elaborated prior to the main unit. @@ -8630,7 +8739,7 @@ package body Sem_Elab is (N => Attr, Unit_Id => Target_Attrs.Unit_Id, Prag_Nam => Name_Elaborate_All, - State => State); + State => New_State); end if; end Process_Conditional_ABE_Access; @@ -8785,11 +8894,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + -- Do not emit any ABE diagnostics when the activation occurs in -- a partial finalization context because this leads to confusing -- noise. - if State.Within_Partial_Finalization then + elsif State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -8797,9 +8912,7 @@ package body Sem_Elab is -- this order diagnostics appear jumbled and result in unwanted -- noise. - elsif Static_Elaboration_Checks - and then Call_Attrs.Elab_Warnings_OK - then + elsif Static_Elaboration_Checks then Error_Msg_Sloc := Sloc (Call); Error_Msg_N ("??task & will be activated # before elaboration of its " @@ -8869,11 +8982,6 @@ package body Sem_Elab is Id => Task_Attrs.Unit_Id); end if; - -- Update the state of the Processing phase to indicate that any further - -- traversal is now within a task body. - - New_State.Within_Task_Body := True; - -- Both the activation call and task type are subject to SPARK_Mode -- On, this triggers the SPARK rules for task activation. Compared to -- calls and instantiations, task activation in SPARK does not require @@ -9085,6 +9193,15 @@ package body Sem_Elab is return; end if; + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or the call or target have warnings suppressed. Update the + -- state of the Processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Call_Attrs.Elab_Warnings_OK + or else not Target_Attrs.Elab_Warnings_OK; + -- The call occurs in an initial condition context when a prior scenario -- is already in that mode, or when the target is an Initial_Condition -- procedure. Update the state of the Processing phase to reflect this. @@ -9221,11 +9338,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + -- Do not emit any ABE diagnostics when the call occurs in a -- partial finalization context because this leads to confusing -- noise. - if State.Within_Partial_Finalization then + elsif State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -9233,9 +9356,7 @@ package body Sem_Elab is -- this order diagnostics appear jumbled and result in unwanted -- noise. - elsif Static_Elaboration_Checks - and then Call_Attrs.Elab_Warnings_OK - then + elsif Static_Elaboration_Checks then Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); Error_Msg_N ("\Program_Error may be raised at run time", Call); @@ -9408,11 +9529,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + -- Do not emit any ABE diagnostics when the call occurs in an -- initial condition context because this leads to incorrect -- diagnostics. - if State.Within_Initial_Condition then + elsif State.Within_Initial_Condition then null; -- Do not emit any ABE diagnostics when the call occurs in a @@ -9515,6 +9642,9 @@ package body Sem_Elab is SPARK_Rules_On : Boolean; -- This flag is set when the SPARK rules are in effect + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin Extract_Instantiation_Attributes (Exp_Inst => Exp_Inst, @@ -9579,15 +9709,23 @@ package body Sem_Elab is elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then return; + end if; + + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the instantiation has warnings suppressed. Update + -- the state of the processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; -- The SPARK rules are in effect - elsif SPARK_Rules_On then + if SPARK_Rules_On then Process_Conditional_ABE_Instantiation_SPARK (Inst => Inst, Gen_Id => Gen_Id, Gen_Attrs => Gen_Attrs, - State => State); + State => New_State); -- Otherwise the Ada rules are in effect, or SPARK code is allowed to -- violate the SPARK rules. @@ -9599,7 +9737,7 @@ package body Sem_Elab is Inst_Attrs => Inst_Attrs, Gen_Id => Gen_Id, Gen_Attrs => Gen_Attrs, - State => State); + State => New_State); end if; end Process_Conditional_ABE_Instantiation; @@ -9624,11 +9762,11 @@ package body Sem_Elab is -- the generic have active elaboration checks and both are not ignored -- Ghost constructs. + Root : constant Node_Id := Root_Scenario; + New_State : Processing_Attributes := State; -- Each step of the Processing phase constitutes a new state - Root : constant Node_Id := Root_Scenario; - begin -- Nothing to do when the instantiation is ABE-safe -- @@ -9685,11 +9823,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + -- Do not emit any ABE diagnostics when the instantiation occurs -- in partial finalization context because this leads to unwanted -- noise. - if State.Within_Partial_Finalization then + elsif State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -9697,9 +9841,7 @@ package body Sem_Elab is -- this order diagnostics appear jumbled and result in unwanted -- noise. - elsif Static_Elaboration_Checks - and then Inst_Attrs.Elab_Warnings_OK - then + elsif Static_Elaboration_Checks then Error_Msg_NE ("??cannot instantiate & before body seen", Inst, Gen_Id); Error_Msg_N ("\Program_Error may be raised at run time", Inst); @@ -9899,7 +10041,7 @@ package body Sem_Elab is -- spec without a pragma Elaborate_Body is initialized by elaboration -- code within the corresponding body. - if not Warnings_Off (Var_Id) + if Is_Elaboration_Warnings_OK_Id (Var_Id) and then not Is_Initialized (Var_Decl) and then not Has_Pragma_Elaborate_Body (Spec_Id) then @@ -9940,7 +10082,8 @@ package body Sem_Elab is -- without pragma Elaborate_Body is further modified by elaboration code -- within the corresponding body. - if Is_Initialized (Var_Decl) + if Is_Elaboration_Warnings_OK_Id (Var_Id) + and then Is_Initialized (Var_Decl) and then not Has_Pragma_Elaborate_Body (Spec_Id) then Error_Msg_NE diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 93ffae3..875b9eb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18399,12 +18399,13 @@ package body Sem_Util is Elaboration_Checks_OK (Target_Id => Id, Context_Id => Scope (Id))); + end if; - -- Entities do not need to capture their enclosing level. The Ghost - -- and SPARK modes in effect are already marked during analysis. + -- Mark the status of elaboration warnings in effect. Do not reset + -- the status in case the entity is reanalyzed with warnings off. - else - null; + if Warnings and then not Is_Elaboration_Warnings_OK_Id (Id) then + Set_Is_Elaboration_Warnings_OK_Id (Id, Elab_Warnings); end if; end Mark_Elaboration_Attributes_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 4ab5614..acb3215 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1929,6 +1929,7 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call @@ -5392,6 +5393,7 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0e53aa9..f1a532d 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1758,6 +1758,7 @@ package Sinfo is -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) -- Present in the following nodes: -- + -- attribute reference -- call marker -- entry call statement -- function call @@ -4064,6 +4065,7 @@ package Sinfo is -- Associated_Node (Node4-Sem) -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) -- Header_Size_Added (Flag11-Sem) -- Redundant_Use (Flag13-Sem) -- Must_Be_Byte_Aligned (Flag14-Sem) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b12fb9e..fc786e3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-05-23 Hristian Kirtchev + + * gnat.dg/elab4.adb, gnat.dg/elab4_pkg.adb, gnat.dg/elab4_pkg.ads: New + testcase. + 2018-05-23 Bob Duff * gnat.dg/addr10.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/elab4.adb b/gcc/testsuite/gnat.dg/elab4.adb new file mode 100644 index 0000000..dd841c1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elab4.adb @@ -0,0 +1,5 @@ +-- { dg-do link } + +with Elab4_Pkg; + +procedure Elab4 is begin null; end Elab4; diff --git a/gcc/testsuite/gnat.dg/elab4_pkg.adb b/gcc/testsuite/gnat.dg/elab4_pkg.adb new file mode 100644 index 0000000..db91dc7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elab4_pkg.adb @@ -0,0 +1,99 @@ +with Ada.Text_IO; use Ada.Text_IO; + +package body Elab4_Pkg is + + -------------------------------------------------- + -- Call to call, instantiation, task activation -- + -------------------------------------------------- + + procedure Suppressed_Call_1 is + package Inst is new ABE_Gen; + T : ABE_Task; + begin + ABE_Call; + end Suppressed_Call_1; + + function Elaborator_1 return Boolean is + begin + pragma Warnings ("L"); + Suppressed_Call_1; + pragma Warnings ("l"); + return True; + end Elaborator_1; + + Elab_1 : constant Boolean := Elaborator_1; + + procedure Suppressed_Call_2 is + package Inst is new ABE_Gen; + T : ABE_Task; + begin + ABE_Call; + end Suppressed_Call_2; + + function Elaborator_2 return Boolean is + begin + Suppressed_Call_2; + return True; + end Elaborator_2; + + Elab_2 : constant Boolean := Elaborator_2; + + ----------------------------------------------------------- + -- Instantiation to call, instantiation, task activation -- + ----------------------------------------------------------- + + package body Suppressed_Generic is + procedure Force_Body is begin null; end Force_Body; + package Inst is new ABE_Gen; + T : ABE_Task; + begin + ABE_Call; + end Suppressed_Generic; + + function Elaborator_3 return Boolean is + pragma Warnings ("L"); + package Inst is new Suppressed_Generic; + pragma Warnings ("l"); + begin + return True; + end Elaborator_3; + + Elab_3 : constant Boolean := Elaborator_3; + + ------------------------------------------------------------- + -- Task activation to call, instantiation, task activation -- + ------------------------------------------------------------- + + task body Suppressed_Task is + package Inst is new ABE_Gen; + T : ABE_Task; + begin + ABE_Call; + end Suppressed_Task; + + function Elaborator_4 return Boolean is + pragma Warnings ("L"); + T : Suppressed_Task; + pragma Warnings ("l"); + begin + return True; + end Elaborator_4; + + Elab_4 : constant Boolean := Elaborator_4; + + procedure ABE_Call is + begin + Put_Line ("ABE_Call"); + end ABE_Call; + + package body ABE_Gen is + procedure Force_Body is begin null; end Force_Body; + begin + Put_Line ("ABE_Gen"); + end ABE_Gen; + + task body ABE_Task is + begin + Put_Line ("ABE_Task"); + end ABE_Task; +end Elab4_Pkg; diff --git a/gcc/testsuite/gnat.dg/elab4_pkg.ads b/gcc/testsuite/gnat.dg/elab4_pkg.ads new file mode 100644 index 0000000..e8e5bab --- /dev/null +++ b/gcc/testsuite/gnat.dg/elab4_pkg.ads @@ -0,0 +1,41 @@ +package Elab4_Pkg is + procedure ABE_Call; + + generic + package ABE_Gen is + procedure Force_Body; + end ABE_Gen; + + task type ABE_Task; + + -------------------------------------------------- + -- Call to call, instantiation, task activation -- + -------------------------------------------------- + + function Elaborator_1 return Boolean; + function Elaborator_2 return Boolean; + + procedure Suppressed_Call_1; + + pragma Warnings ("L"); + procedure Suppressed_Call_2; + pragma Warnings ("l"); + + ----------------------------------------------------------- + -- Instantiation to call, instantiation, task activation -- + ----------------------------------------------------------- + + function Elaborator_3 return Boolean; + + generic + package Suppressed_Generic is + procedure Force_Body; + end Suppressed_Generic; + + ------------------------------------------------------------- + -- Task activation to call, instantiation, task activation -- + ------------------------------------------------------------- + + function Elaborator_4 return Boolean; + task type Suppressed_Task; +end Elab4_Pkg;