This patch modifies the analysis of exception handlers to bypass restriction
checks when the handler is internally generated and the verification mode is
warnings.
------------
-- Source --
------------
-- gen.ads
generic
type Ptr is private;
package Gen is
end Gen;
-- types.ads
with Gen;
package Types is
type T is private;
type Ptr is access all T;
package Inst is new Gen (Ptr);
private
type T is record
Comp : Integer;
end record;
end Types;
-- gnat.adc
pragma Restriction_Warnings (No_Exception_Handlers);
-----------------
-- Compilation --
-----------------
$ gcc -c types.ads
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-04-25 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Code cleanup.
(Build_Adjust_Statements): Code cleanup.
(Build_Finalizer): Update the initialization of
Exceptions_OK.
(Build_Finalize_Statements): Code cleanup.
(Build_Initialize_Statements): Code cleanup.
(Make_Deep_Array_Body): Update the initialization of
Exceptions_OK.
(Make_Deep_Record_Body): Update the initialization of Exceptions_OK.
(Process_Object_Declaration): Generate a null exception handler only
when exceptions are allowed.
(Process_Transients_In_Scope): Update the initialization of
Exceptions_OK.
* exp_util.ads, exp_util.adb (Exceptions_In_Finalization_OK): New
routine.
* sem_ch11.adb (Analyze_Exception_Handlers): Do not check any
restrictions when the handler is internally generated and the
mode is warnings.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 247177)
+++ exp_ch7.adb (working copy)
@@ -1327,8 +1327,7 @@
or else
(Present (Clean_Stmts)
and then Is_Non_Empty_List (Clean_Stmts));
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
+ 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 :=
@@ -2844,7 +2843,7 @@
Body_Ins : Node_Id;
Count_Ins : Node_Id;
Fin_Call : Node_Id;
- Fin_Stmts : List_Id;
+ Fin_Stmts : List_Id := No_List;
Inc_Decl : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
@@ -3004,8 +3003,6 @@
-- manual finalization of their lock managers.
if Is_Protected then
- Fin_Stmts := No_List;
-
if Is_Simple_Protected_Type (Obj_Typ) then
Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
@@ -3031,8 +3028,8 @@
-- null;
-- end;
- if Present (Fin_Stmts) then
- Append_To (Finalizer_Stmts,
+ if Present (Fin_Stmts) and then Exceptions_OK then
+ Fin_Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
@@ -4866,8 +4863,7 @@
Last_Object : Node_Id;
Related_Node : Node_Id)
is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
+ Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
Must_Hook : Boolean := False;
-- Flag denoting whether the context requires transient object
@@ -5529,6 +5525,8 @@
(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
@@ -5645,12 +5643,10 @@
function Build_Adjust_Or_Finalize_Statements
(Typ : Entity_Id) return List_Id
is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
@@ -5822,13 +5818,11 @@
---------------------------------
function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Final_List : constant List_Id := New_List;
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Final_List : constant List_Id := New_List;
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
-- Generate the following assignment:
@@ -6349,6 +6343,8 @@
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:
@@ -6498,17 +6494,10 @@
-----------------------------
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id :=
- Type_Definition (Parent (Typ));
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
- Bod_Stmts : List_Id;
- Finalizer_Data : Finalization_Exception_Data;
- Finalizer_Decls : List_Id := No_List;
- Rec_Def : Node_Id;
- Var_Case : Node_Id;
+ Finalizer_Data : Finalization_Exception_Data;
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id;
@@ -6581,6 +6570,7 @@
Decl_Typ : Entity_Id;
Has_POC : Boolean;
Num_Comps : Nat;
+ Var_Case : Node_Id;
-- Start of processing for Process_Component_List_For_Adjust
@@ -6710,6 +6700,12 @@
return Stmts;
end Process_Component_List_For_Adjust;
+ -- Local variables
+
+ Bod_Stmts : List_Id;
+ Finalizer_Decls : List_Id := No_List;
+ Rec_Def : Node_Id;
+
-- Start of processing for Build_Adjust_Statements
begin
@@ -6914,18 +6910,12 @@
-------------------------------
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id :=
- Type_Definition (Parent (Typ));
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
- Bod_Stmts : List_Id;
- Counter : Int := 0;
- Finalizer_Data : Finalization_Exception_Data;
- Finalizer_Decls : List_Id := No_List;
- Rec_Def : Node_Id;
- Var_Case : Node_Id;
+ Counter : Int := 0;
+ Finalizer_Data : Finalization_Exception_Data;
+ Num_Comps : Nat := 0;
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id;
@@ -6940,19 +6930,6 @@
function Process_Component_List_For_Finalize
(Comps : Node_Id) return List_Id
is
- Alts : List_Id;
- Counter_Id : Entity_Id;
- Decl : Node_Id;
- Decl_Id : Entity_Id;
- Decl_Typ : Entity_Id;
- Decls : List_Id;
- Has_POC : Boolean;
- Jump_Block : Node_Id;
- Label : Node_Id;
- Label_Id : Entity_Id;
- Num_Comps : Nat;
- Stmts : List_Id;
-
procedure Process_Component_For_Finalize
(Decl : Node_Id;
Alts : List_Id;
@@ -7066,6 +7043,21 @@
end if;
end Process_Component_For_Finalize;
+ -- Local variables
+
+ Alts : List_Id;
+ Counter_Id : Entity_Id;
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+ Decl_Typ : Entity_Id;
+ Decls : List_Id;
+ Has_POC : Boolean;
+ Jump_Block : Node_Id;
+ Label : Node_Id;
+ Label_Id : Entity_Id;
+ Stmts : List_Id;
+ Var_Case : Node_Id;
+
-- Start of processing for Process_Component_List_For_Finalize
begin
@@ -7286,6 +7278,12 @@
end if;
end Process_Component_List_For_Finalize;
+ -- Local variables
+
+ Bod_Stmts : List_Id;
+ Finalizer_Decls : List_Id := No_List;
+ Rec_Def : Node_Id;
+
-- Start of processing for Build_Finalize_Statements
begin
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 247177)
+++ exp_util.adb (working copy)
@@ -4784,6 +4784,18 @@
end if;
end Evolve_Or_Else;
+ -----------------------------------
+ -- Exceptions_In_Finalization_OK --
+ -----------------------------------
+
+ function Exceptions_In_Finalization_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;
+
-----------------------------------------
-- Expand_Static_Predicates_In_Choices --
-----------------------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 247177)
+++ exp_util.ads (working copy)
@@ -535,6 +535,10 @@
-- 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.
+
procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
-- N is either a case alternative or a variant. The Discrete_Choices field
-- of N points to a list of choices. If any of these choices is the name
Index: sem_ch11.adb
===================================================================
--- sem_ch11.adb (revision 247177)
+++ sem_ch11.adb (working copy)
@@ -165,9 +165,25 @@
begin
Handler := First (L);
- Check_Restriction (No_Exceptions, Handler);
- Check_Restriction (No_Exception_Handlers, Handler);
+ -- Pragma Restriction_Warnings has more related semantics than pragma
+ -- Restrictions in that it flags exception handlers as violators. Note
+ -- that the compiler must still generate handlers for certain critical
+ -- scenarios such as finalization. As a result, these handlers should
+ -- not be subjected to the restriction check when in warnings mode.
+
+ if not Comes_From_Source (Handler)
+ and then (Restriction_Warnings (No_Exception_Handlers)
+ or else Restriction_Warnings (No_Exception_Propagation)
+ or else Restriction_Warnings (No_Exceptions))
+ then
+ null;
+
+ else
+ Check_Restriction (No_Exceptions, Handler);
+ Check_Restriction (No_Exception_Handlers, Handler);
+ end if;
+
-- Kill current remembered values, since we don't know where we were
-- when the exception was raised.
