+2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * 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 <trojanek@adacore.com>
* einfo.ads: Minor reformatting.
-- 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
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);
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);
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));
-- 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
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
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;
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);
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);
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);
-- 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.
-- 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.
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
- (N_Id => Id,
- Checks => True);
+ (N_Id => Id,
+ Checks => True,
+ Warnings => True);
Formals := Parameter_Specifications (Spec);
-- 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
-- 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);
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
-- 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 ");
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
- (N_Id => Def_Id,
- Checks => True);
+ (N_Id => Def_Id,
+ Checks => True,
+ Warnings => True);
-- Process formals
-- 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
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
- (N_Id => T,
- Checks => True);
+ (N_Id => T,
+ Checks => True,
+ Warnings => True);
Push_Scope (T);
-- 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");
+ -- <construct>
+ -- 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 --
--------------
-- 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.
Initial_State : constant Processing_Attributes :=
(Suppress_Implicit_Pragmas => False,
+ Suppress_Warnings => False,
Within_Initial_Condition => False,
Within_Instance => False,
Within_Partial_Finalization => False,
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
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.
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 :=
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;
-- 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 --
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;
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;
(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
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
(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
-- 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)
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.
(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;
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
-- 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 "
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
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.
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
-- 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);
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
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,
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.
Inst_Attrs => Inst_Attrs,
Gen_Id => Gen_Id,
Gen_Attrs => Gen_Attrs,
- State => State);
+ State => New_State);
end if;
end Process_Conditional_ABE_Instantiation;
-- 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
--
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
-- 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);
-- 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
-- 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
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;
(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
(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
-- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
-- Present in the following nodes:
--
+ -- attribute reference
-- call marker
-- entry call statement
-- function call
-- 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)
+2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/elab4.adb, gnat.dg/elab4_pkg.adb, gnat.dg/elab4_pkg.ads: New
+ testcase.
+
2018-05-23 Bob Duff <duff@adacore.com>
* gnat.dg/addr10.adb: New testcase.
--- /dev/null
+-- { dg-do link }
+
+with Elab4_Pkg;
+
+procedure Elab4 is begin null; end Elab4;
--- /dev/null
+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;
--- /dev/null
+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;
projects / gcc.git / commitdiff