[Ada] Limited function violates No_Exception_Propagation

This patch suppresses the generation of raise statements in the context
of build-in-place and elaboration checks for primitives of tagged types
when exceptions cannot be used.

2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* checks.adb (Install_Primitive_Elaboration_Check): Do not
	create the check when exceptions cannot be used.
	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not raise
	Program_Errror when exceptions cannot be used. Analyze the
	generated code with all checks suppressed.
	* exp_ch7.adb (Build_Finalizer): Remove the declaration of
	Exceptions_OK.
	(Make_Deep_Array_Body): Remove the declaration of Exceptions_OK.
	(Make_Deep_Record_Body): Remove the declaration of
	Exceptions_OK.
	(Process_Transients_In_Scope): Remove the declaration of
	Exceptions_OK.
	* exp_util.adb (Exceptions_In_Finalization_OK): Renamed to
	Exceptions_OK.
	* exp_util.ads (Exceptions_In_Finalization_OK): Renamed to
	Exceptions_OK.

gcc/testsuite/

	* gnat.dg/bip_exception.adb, gnat.dg/bip_exception.ads,
	gnat.dg/bip_exception_pkg.ads: New testcase.

From-SVN: r266115

gcc/ada/ChangeLog

 2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* checks.adb (Install_Primitive_Elaboration_Check): Do not
+	create the check when exceptions cannot be used.
+	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not raise
+	Program_Errror when exceptions cannot be used. Analyze the
+	generated code with all checks suppressed.
+	* exp_ch7.adb (Build_Finalizer): Remove the declaration of
+	Exceptions_OK.
+	(Make_Deep_Array_Body): Remove the declaration of Exceptions_OK.
+	(Make_Deep_Record_Body): Remove the declaration of
+	Exceptions_OK.
+	(Process_Transients_In_Scope): Remove the declaration of
+	Exceptions_OK.
+	* exp_util.adb (Exceptions_In_Finalization_OK): Renamed to
+	Exceptions_OK.
+	* exp_util.ads (Exceptions_In_Finalization_OK): Renamed to
+	Exceptions_OK.
+
+2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use
 	routine Find_Equality instead.
 	(Find_Equality): New routine.

gcc/ada/checks.adb

@@ -7960,6 +7960,12 @@ package body Checks is
       elsif Restriction_Active (No_Elaboration_Code) then
          return;
 
+      --  Do not generate an elaboration check if exceptions cannot be used,
+      --  caught, or propagated.
+
+      elsif not Exceptions_OK then
+         return;
+
       --  Do not consider subprograms which act as compilation units, because
       --  they cannot be the target of a dispatching call.
 

gcc/ada/exp_ch6.adb

@@ -5099,6 +5099,7 @@ package body Exp_Ch6 is
                      Alloc_Obj_Id   : Entity_Id;
                      Alloc_Obj_Decl : Node_Id;
                      Alloc_If_Stmt  : Node_Id;
+                     Guard_Except   : Node_Id;
                      Heap_Allocator : Node_Id;
                      Pool_Decl      : Node_Id;
                      Pool_Allocator : Node_Id;
@@ -5298,6 +5299,18 @@ package body Exp_Ch6 is
                        (Return_Statement_Entity (N));
                      Set_Enclosing_Sec_Stack_Return (N);
 
+                     --  Guard against poor expansion on the caller side by
+                     --  using a raise statement to catch out-of-range values
+                     --  of formal parameter BIP_Alloc_Form.
+
+                     if Exceptions_OK then
+                        Guard_Except :=
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Build_In_Place_Mismatch);
+                     else
+                        Guard_Except := Make_Null_Statement (Loc);
+                     end if;
+
                      --  Create an if statement to test the BIP_Alloc_Form
                      --  formal and initialize the access object to either the
                      --  BIP_Object_Access formal (BIP_Alloc_Form =
@@ -5400,9 +5413,7 @@ package body Exp_Ch6 is
                          --  Raise Program_Error if it's none of the above;
                          --  this is a compiler bug.
 
-                         Else_Statements => New_List (
-                           Make_Raise_Program_Error (Loc,
-                             Reason => PE_Build_In_Place_Mismatch)));
+                         Else_Statements => New_List (Guard_Except));
 
                      --  If a separate initialization assignment was created
                      --  earlier, append that following the assignment of the
@@ -5477,7 +5488,7 @@ package body Exp_Ch6 is
       Set_Comes_From_Extended_Return_Statement (Return_Stmt);
 
       Rewrite (N, Result);
-      Analyze (N);
+      Analyze (N, Suppress => All_Checks);
    end Expand_N_Extended_Return_Statement;
 
    ----------------------------

gcc/ada/exp_ch7.adb

@@ -1337,7 +1337,7 @@ package body Exp_Ch7 is
                              or else
                                (Present (Clean_Stmts)
                                  and then Is_Non_Empty_List (Clean_Stmts));
-      Exceptions_OK    : constant Boolean := Exceptions_In_Finalization_OK;
+
       For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
       For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
       For_Package      : constant Boolean :=
@@ -5328,8 +5328,6 @@ package body Exp_Ch7 is
          Last_Object  : Node_Id;
          Related_Node : Node_Id)
       is
-         Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
-
          Must_Hook : Boolean := False;
          --  Flag denoting whether the context requires transient object
          --  export to the outer finalizer.
@@ -5997,8 +5995,6 @@ package body Exp_Ch7 is
      (Prim : Final_Primitives;
       Typ  : Entity_Id) return List_Id
    is
-      Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
-
       function Build_Adjust_Or_Finalize_Statements
         (Typ : Entity_Id) return List_Id;
       --  Create the statements necessary to adjust or finalize an array of
@@ -6829,8 +6825,6 @@ package body Exp_Ch7 is
       Typ      : Entity_Id;
       Is_Local : Boolean := False) return List_Id
    is
-      Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
-
       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
       --  Build the statements necessary to adjust a record type. The type may
       --  have discriminants and contain variant parts. Generate:

gcc/ada/exp_util.adb

@@ -4940,17 +4940,17 @@ package body Exp_Util is
       end if;
    end Evolve_Or_Else;
 
-   -----------------------------------
-   -- Exceptions_In_Finalization_OK --
-   -----------------------------------
+   -------------------
+   -- Exceptions_OK --
+   -------------------
 
-   function Exceptions_In_Finalization_OK return Boolean is
+   function Exceptions_OK return Boolean is
    begin
       return
         not (Restriction_Active (No_Exception_Handlers)    or else
              Restriction_Active (No_Exception_Propagation) or else
              Restriction_Active (No_Exceptions));
-   end Exceptions_In_Finalization_OK;
+   end Exceptions_OK;
 
    -----------------------------------------
    -- Expand_Static_Predicates_In_Choices --

gcc/ada/exp_util.ads

@@ -544,9 +544,9 @@ package Exp_Util is
    --  indicating that no checks were required). The Sloc field of the
    --  constructed N_Or_Else node is copied from Cond1.
 
-   function Exceptions_In_Finalization_OK return Boolean;
-   --  Determine whether the finalization machinery can safely add exception
-   --  handlers and recovery circuitry.
+   function Exceptions_OK return Boolean;
+   --  Determine whether exceptions are allowed to be caught, propagated, or
+   --  raised.
 
    procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
    --  N is either a case alternative or a variant. The Discrete_Choices field

gcc/testsuite/ChangeLog

 2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* gnat.dg/bip_exception.adb, gnat.dg/bip_exception.ads,
+	gnat.dg/bip_exception_pkg.ads: New testcase.
+
+2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* gnat.dg/equal4.adb, gnat.dg/equal4.ads,
 	gnat.dg/equal4_controlled_filter.ads,
 	gnat.dg/equal4_full_selector_filter.ads,

gcc/testsuite/gnat.dg/bip_exception.adb

+--  { dg-do compile }
+--  { dg-options "-gnatwa" }
+
+package body BIP_Exception is
+   package body Constructors is
+      function Initialize return T_C4_Scheduler is
+      begin
+         return T_C4_Scheduler'(T_Super with null record);
+      end Initialize;
+   end Constructors;
+
+   overriding procedure V_Run (This : in T_C4_Scheduler) is
+      pragma Unreferenced (This);
+   begin
+      null;
+   end V_Run;
+end BIP_Exception;

gcc/testsuite/gnat.dg/bip_exception.ads

+pragma Restrictions (No_Exception_Propagation);
+with BIP_Exception_Pkg;
+
+package BIP_Exception is
+   type T_C4_Scheduler is new BIP_Exception_Pkg.T_Process with private;
+   type T_C4_Scheduler_Class_Access is access all T_C4_Scheduler'Class;
+
+   package Constructors is
+      function Initialize return T_C4_Scheduler;
+   end Constructors;
+
+   overriding procedure V_Run (This : in T_C4_Scheduler);
+   pragma Suppress (Elaboration_Check, V_Run);
+
+private
+   package Super renames BIP_Exception_Pkg;
+   subtype T_Super is Super.T_Process;
+
+   type T_C4_Scheduler is new T_Super with null record;
+end BIP_Exception;

gcc/testsuite/gnat.dg/bip_exception_pkg.ads

+pragma Restrictions (No_Exception_Propagation);
+
+package BIP_Exception_Pkg is
+   type T_Process is abstract tagged limited private;
+   type T_Process_Class_Access is access all T_Process'Class;
+
+   procedure V_Run (This : in T_Process) is abstract;
+
+private
+   type T_Process is abstract tagged limited null record;
+end BIP_Exception_Pkg;