+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
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.
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;
(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 =
-- 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
Set_Comes_From_Extended_Return_Statement (Return_Stmt);
Rewrite (N, Result);
- Analyze (N);
+ Analyze (N, Suppress => All_Checks);
end Expand_N_Extended_Return_Statement;
----------------------------
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 :=
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.
(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
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:
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 --
-- 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
+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,
--- /dev/null
+-- { 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
+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
+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;
projects / gcc.git / commitdiff