[Ada] Suppression of elaboration-related warnings

This patch modifies the effects of pragma Warnings (Off, ...) to suppress
elaboration warnings related to an entity.

2018-05-23  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* 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, ...).

gcc/testsuite/

	* gnat.dg/elab5.adb, gnat.dg/elab5_pkg.adb, gnat.dg/elab5_pkg.ads: New
	testcase.

From-SVN: r260580

gcc/ada/ChangeLog

+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.

gcc/ada/einfo.adb

@@ -2253,23 +2253,13 @@ package body Einfo is
 
    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;
 
@@ -5478,23 +5468,13 @@ package body Einfo is
 
    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;
 
@@ -8112,6 +8092,20 @@ package body Einfo is
                   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 --
    -----------------------

gcc/ada/einfo.ads

@@ -2522,12 +2522,16 @@ package Einfo is
 --       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.
 
@@ -5971,6 +5975,7 @@ package Einfo is
    --    Address_Clause                      (synth)
    --    Alignment_Clause                    (synth)
    --    Is_Atomic_Or_VFA                    (synth)
+   --    Is_Elaboration_Target               (synth)
    --    Size_Clause                         (synth)
 
    --  E_Decimal_Fixed_Point_Type
@@ -6041,6 +6046,7 @@ package Einfo is
    --    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)
@@ -6202,6 +6208,7 @@ package Einfo is
    --    Address_Clause                      (synth)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
+   --    Is_Elaboration_Target               (synth)
    --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
    --    Scope_Depth                         (synth)
@@ -6329,6 +6336,7 @@ package Einfo is
    --    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 ???
 
@@ -6401,6 +6409,7 @@ package Einfo is
    --    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)
 
@@ -6525,6 +6534,7 @@ package Einfo is
    --    Address_Clause                      (synth)
    --    First_Formal                        (synth)
    --    First_Formal_With_Extras            (synth)
+   --    Is_Elaboration_Target               (synth)
    --    Is_Finalizer                        (synth)
    --    Last_Formal                         (synth)
    --    Number_Formals                      (synth)
@@ -6712,6 +6722,7 @@ package Einfo is
    --    First_Component                     (synth)
    --    First_Component_Or_Discriminant     (synth)
    --    Has_Entries                         (synth)
+   --    Is_Elaboration_Target               (synth)
    --    Number_Entries                      (synth)
    --    Scope_Depth                         (synth)
    --    (plus type attributes)
@@ -6777,6 +6788,7 @@ package Einfo is
    --    Address_Clause                      (synth)
    --    Alignment_Clause                    (synth)
    --    Is_Atomic_Or_VFA                    (synth)
+   --    Is_Elaboration_Target               (synth)
    --    Size_Clause                         (synth)
 
    --  E_Void
@@ -7595,6 +7607,7 @@ package Einfo is
    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;

gcc/ada/sem_prag.adb

@@ -24696,6 +24696,13 @@ package body Sem_Prag is
                                 (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

gcc/testsuite/ChangeLog

 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
 	testcase.
 

gcc/testsuite/gnat.dg/elab5.adb

+--  { dg-do link }
+
+with Elab5_Pkg;
+
+procedure Elab5 is begin null; end Elab5;

gcc/testsuite/gnat.dg/elab5_pkg.adb

+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;

gcc/testsuite/gnat.dg/elab5_pkg.ads

+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;