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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-11-14 Hristian Kirtchev <kirtc...@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.--- gcc/ada/checks.adb
+++ 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
+++ 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
+++ 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
+++ 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
+++ 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
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bip_exception.adb
@@ -0,0 +1,17 @@
+-- { 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;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bip_exception.ads
@@ -0,0 +1,20 @@
+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;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bip_exception_pkg.ads
@@ -0,0 +1,11 @@
+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;
