+2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb (Is_Elaboration_Checks_OK_Id): Use predicate
+ Is_Elaboration_Target.
+ (Is_Elaboration_Target): New routine.
+ (Is_Elaboration_Warnings_OK_Id): Use predicate Is_Elaboration_Target.
+ (Set_Is_Elaboration_Checks_OK_Id): Use predicate Is_Elaboration_Target.
+ (Set_Is_Elaboration_Warnings_OK_Id): Use predicate
+ Is_Elaboration_Target.
+ * einfo.ads: Add new synthesized attribute Is_Elaboration_Target along
+ with occurrences in nodes.
+ (Is_Elaboration_Target): New routine.
+ * sem_prag.adb (Analyze_Pragma): Suppress elaboration warnings when an
+ elaboration target is subject to pragma Warnings (Off, ...).
+
2018-05-23 Eric Botcazou <ebotcazou@adacore.com>
* repinfo.adb (List_Type_Info): Remove obsolete stuff.
function Is_Elaboration_Checks_OK_Id (Id : E) return B 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));
+ pragma Assert (Is_Elaboration_Target (Id));
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));
+ pragma Assert (Is_Elaboration_Target (Id) or else Ekind (Id) = E_Void);
return Flag304 (Id);
end Is_Elaboration_Warnings_OK_Id;
procedure Set_Is_Elaboration_Checks_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));
+ pragma Assert (Is_Elaboration_Target (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));
+ pragma Assert (Is_Elaboration_Target (Id));
Set_Flag304 (Id, V);
end Set_Is_Elaboration_Warnings_OK_Id;
and then Is_Entity_Attribute_Name (Attribute_Name (N)));
end Is_Entity_Name;
+ ---------------------------
+ -- Is_Elaboration_Target --
+ ---------------------------
+
+ function Is_Elaboration_Target (Id : Entity_Id) return Boolean is
+ begin
+ return
+ 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);
+ end Is_Elaboration_Target;
+
-----------------------
-- Is_External_State --
-----------------------
-- checks. Such targets are allowed to generate run-time conditional ABE
-- checks or guaranteed ABE failures.
+-- Is_Elaboration_Target (synthesized)
+-- Applies to all entities, True only for elaboration targets (see the
+-- terminology in Sem_Elab).
+
-- 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.
+-- Applies to all entities, True for all elementary types and subtypes.
-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
-- of any type.
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
+ -- Is_Elaboration_Target (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
-- Entry_Index_Type (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
-- Is_Primitive (Flag218)
-- Is_Pure (Flag44)
-- SPARK_Pragma_Inherited (Flag265)
+ -- Is_Elaboration_Target (synth)
-- Aren't there more flags and fields? seems like this list should be
-- more similar to the E_Function list, which is much longer ???
-- Static_Elaboration_Desired (Flag77) (non-generic case only)
-- Has_Non_Null_Abstract_State (synth)
-- Has_Null_Abstract_State (synth)
+ -- Is_Elaboration_Target (synth)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Scope_Depth (synth)
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
-- Is_Finalizer (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- Has_Entries (synth)
+ -- Is_Elaboration_Target (synth)
-- Number_Entries (synth)
-- Scope_Depth (synth)
-- (plus type attributes)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
+ -- Is_Elaboration_Target (synth)
-- Size_Clause (synth)
-- E_Void
function Is_Controlled (Id : E) return B;
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
+ function Is_Elaboration_Target (Id : E) return B;
function Is_External_State (Id : E) return B;
function Is_Finalizer (Id : E) return B;
function Is_Null_State (Id : E) return B;
(E, (Chars (Get_Pragma_Arg (Arg1)) =
Name_Off));
+ -- Suppress elaboration warnings if the entity
+ -- denotes an elaboration target.
+
+ if Is_Elaboration_Target (E) then
+ Set_Is_Elaboration_Warnings_OK_Id (E, False);
+ end if;
+
-- For OFF case, make entry in warnings off
-- pragma table for later processing. But we do
-- not do that within an instance, since these
+2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/elab5.adb, gnat.dg/elab5_pkg.adb, gnat.dg/elab5_pkg.ads: New
+ testcase.
+
2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/elab4.adb, gnat.dg/elab4_pkg.adb, gnat.dg/elab4_pkg.ads: New
--- /dev/null
+-- { dg-do link }
+
+with Elab5_Pkg;
+
+procedure Elab5 is begin null; end Elab5;
--- /dev/null
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Elab5_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;
+
+ procedure Suppressed_Call_3 is
+ package Inst is new ABE_Gen;
+ T : ABE_Task;
+ begin
+ ABE_Call;
+ end Suppressed_Call_3;
+
+ function Elaborator_3 return Boolean is
+ begin
+ Suppressed_Call_3;
+ return True;
+ end Elaborator_3;
+
+ Elab_3 : constant Boolean := Elaborator_3;
+
+ -----------------------------------------------------------
+ -- 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_4 return Boolean is
+ pragma Warnings ("L");
+ package Inst is new Suppressed_Generic;
+ pragma Warnings ("l");
+ begin
+ return True;
+ end Elaborator_4;
+
+ Elab_4 : constant Boolean := Elaborator_4;
+
+ -------------------------------------------------------------
+ -- 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_5 return Boolean is
+ pragma Warnings ("L");
+ T : Suppressed_Task;
+ pragma Warnings ("l");
+ begin
+ return True;
+ end Elaborator_5;
+
+ Elab_5 : constant Boolean := Elaborator_5;
+
+ function Elaborator_6 return Boolean is
+ T : Suppressed_Task;
+ pragma Warnings (Off, T);
+ begin
+ return True;
+ end Elaborator_6;
+
+ Elab_6 : constant Boolean := Elaborator_6;
+
+ 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 Elab5_Pkg;
--- /dev/null
+package Elab5_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;
+ function Elaborator_3 return Boolean;
+
+ procedure Suppressed_Call_1;
+
+ pragma Warnings ("L");
+ procedure Suppressed_Call_2;
+ pragma Warnings ("l");
+
+ procedure Suppressed_Call_3;
+ pragma Warnings (Off, Suppressed_Call_3);
+
+ -----------------------------------------------------------
+ -- Instantiation to call, instantiation, task activation --
+ -----------------------------------------------------------
+
+ function Elaborator_4 return Boolean;
+
+ generic
+ package Suppressed_Generic is
+ procedure Force_Body;
+ end Suppressed_Generic;
+
+ -------------------------------------------------------------
+ -- Task activation to call, instantiation, task activation --
+ -------------------------------------------------------------
+
+ function Elaborator_5 return Boolean;
+ function Elaborator_6 return Boolean;
+
+ task type Suppressed_Task;
+end Elab5_Pkg;
projects / gcc.git / commitdiff