The new implementation of Access-Before-Elaboration detection can create new
raise Program_Error statements at the very end of the front-end processing,
which is too late in order for the first-line mechanism implementing the
No_Exception_Propagation restriction present in the front-end to catch them.
There is a second-line mechanism present in gigi that can catch them, but the
expanded tree must nevertheless be prepared beforehand for their possible
creation; this is achieved by calling Possible_Local_Raise in the few cases
where an ABE scenario could give rise to raising Program_Error.
Since this is a very conservative processing, additional adjustements are made
in order for the warnings tied to the No_Exception_Propagation restriction to
still be issued in an useful way.
ACATS c39006b must now pass again in ZFP mode.
2017-10-20 Eric Botcazou <ebotca...@adacore.com>
* exp_ch11.ads (Warn_If_No_Local_Raise): Declare.
* exp_ch11.adb (Expand_Exception_Handlers): Use Warn_If_No_Local_Raise
to issue the warning on the absence of local raise.
(Possible_Local_Raise): Do not issue the warning for Call_Markers.
(Warn_If_No_Local_Raise): New procedure to issue the warning on the
absence of local raise.
* sem_elab.adb: Add with and use clauses for Exp_Ch11.
(Record_Elaboration_Scenario): Call Possible_Local_Raise in the cases
where a scenario could give rise to raising Program_Error.
* sem_elab.adb: Typo fixes.
* fe.h (Warn_If_No_Local_Raise): Declare.
* gcc-interface/gigi.h (get_exception_label): Change return type.
* gcc-interface/trans.c (gnu_constraint_error_label_stack): Change to
simple vector of Entity_Id.
(gnu_storage_error_label_stack): Likewise.
(gnu_program_error_label_stack): Likewise.
(gigi): Adjust to above changes.
(Raise_Error_to_gnu): Likewise.
(gnat_to_gnu) <N_Goto_Statement>: Set TREE_USED on the label.
(N_Push_Constraint_Error_Label): Push the label onto the stack.
(N_Push_Storage_Error_Label): Likewise.
(N_Push_Program_Error_Label): Likewise.
(N_Pop_Constraint_Error_Label): Pop the label from the stack and issue
a warning on the absence of local raise.
(N_Pop_Storage_Error_Label): Likewise.
(N_Pop_Program_Error_Label): Likewise.
(push_exception_label_stack): Delete.
(get_exception_label): Change return type to Entity_Id and adjust.
* gcc-interface/utils2.c (build_goto_raise): Change type of first
parameter to Entity_Id and adjust. Set TREE_USED on the label.
(build_call_raise): Adjust calls to get_exception_label and also
build_goto_raise.
(build_call_raise_column): Likewise.
(build_call_raise_range): Likewise.
* doc/gnat_ugn/building_executable_programs_with_gnat.rst (-gnatw.x):
Document actual default behavior.
Index: doc/gnat_ugn/building_executable_programs_with_gnat.rst
===================================================================
--- doc/gnat_ugn/building_executable_programs_with_gnat.rst (revision
253938)
+++ doc/gnat_ugn/building_executable_programs_with_gnat.rst (working copy)
@@ -3898,8 +3898,8 @@
This switch activates warnings for exception usage when pragma Restrictions
(No_Exception_Propagation) is in effect. Warnings are given for implicit or
explicit exception raises which are not covered by a local handler, and for
- exception handlers which do not cover a local raise. The default is that
these
- warnings are not given.
+ exception handlers which do not cover a local raise. The default is that
+ these warnings are given for units that contain exception handlers.
:switch:`-gnatw.X`
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 253938)
+++ exp_ch11.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -64,7 +64,7 @@
procedure Warn_If_No_Propagation (N : Node_Id);
-- Called for an exception raise that is not a local raise (and thus can
- -- not be optimized to a goto. Issues warning if No_Exception_Propagation
+ -- not be optimized to a goto). Issues warning if No_Exception_Propagation
-- restriction is set. N is the node for the raise or equivalent call.
---------------------------
@@ -998,15 +998,10 @@
-- if a source generated handler was not the target of a local raise.
else
- if Restriction_Active (No_Exception_Propagation)
- and then not Has_Local_Raise (Handler)
+ if not Has_Local_Raise (Handler)
and then Comes_From_Source (Handler)
- and then Warn_On_Non_Local_Exception
then
- Warn_No_Exception_Propagation_Active (Handler);
- Error_Msg_N
- ("\?X?this handler can never be entered, "
- & "and has been removed", Handler);
+ Warn_If_No_Local_Raise (Handler);
end if;
if No_Exception_Propagation_Active then
@@ -1859,8 +1854,12 @@
-- Otherwise, if the No_Exception_Propagation restriction is active
-- and the warning is enabled, generate the appropriate warnings.
+ -- ??? Do not do it for the Call_Marker nodes inserted by the ABE
+ -- mechanism because this generates too many false positives.
+
elsif Warn_On_Non_Local_Exception
and then Restriction_Active (No_Exception_Propagation)
+ and then Nkind (N) /= N_Call_Marker
then
Warn_No_Exception_Propagation_Active (N);
@@ -2155,6 +2154,22 @@
end Get_RT_Exception_Name;
----------------------------
+ -- Warn_If_No_Local_Raise --
+ ----------------------------
+
+ procedure Warn_If_No_Local_Raise (N : Node_Id) is
+ begin
+ if Restriction_Active (No_Exception_Propagation)
+ and then Warn_On_Non_Local_Exception
+ then
+ Warn_No_Exception_Propagation_Active (N);
+
+ Error_Msg_N
+ ("\?X?this handler can never be entered, and has been removed", N);
+ end if;
+ end Warn_If_No_Local_Raise;
+
+ ----------------------------
-- Warn_If_No_Propagation --
----------------------------
Index: exp_ch11.ads
===================================================================
--- exp_ch11.ads (revision 253938)
+++ exp_ch11.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -90,4 +90,9 @@
-- is a local handler marking that it has a local raise. E is the entity
-- of the corresponding exception.
+ procedure Warn_If_No_Local_Raise (N : Node_Id);
+ -- Called for an exception handler that is not the target of a local raise.
+ -- Issues warning if No_Exception_Propagation restriction is set. N is the
+ -- node for the handler.
+
end Exp_Ch11;
Index: fe.h
===================================================================
--- fe.h (revision 253938)
+++ fe.h (working copy)
@@ -109,10 +109,12 @@
#define Get_Local_Raise_Call_Entity exp_ch11__get_local_raise_call_entity
#define Get_RT_Exception_Entity exp_ch11__get_rt_exception_entity
#define Get_RT_Exception_Name exp_ch11__get_rt_exception_name
+#define Warn_If_No_Local_Raise exp_ch11__warn_if_no_local_raise
extern Entity_Id Get_Local_Raise_Call_Entity (void);
extern Entity_Id Get_RT_Exception_Entity (int);
extern void Get_RT_Exception_Name (int);
+extern void Warn_If_No_Local_Raise (int);
/* exp_code: */
Index: sem_elab.adb
===================================================================
--- sem_elab.adb (revision 253938)
+++ sem_elab.adb (working copy)
@@ -27,6 +27,7 @@
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
@@ -348,7 +349,7 @@
-- ABE mechanism effectively ignores all calls which cause the
-- elaboration flow to "leave" the instance.
--
- -- -gnatd.o conservarive elaboration order for indirect calls
+ -- -gnatd.o conservative elaboration order for indirect calls
--
-- The ABE mechanism treats '[Unrestricted_]Access of an entry,
-- operator, or subprogram as an immediate invocation of the
@@ -6333,7 +6334,7 @@
end if;
-- Treat the attribute as an immediate invocation of the target when
- -- switch -gnatd.o (conservarive elaboration order for indirect calls)
+ -- switch -gnatd.o (conservative elaboration order for indirect calls)
-- is in effect. Note that the prior elaboration of the unit containing
-- the target is ensured processing the corresponding call marker.
@@ -8210,15 +8211,34 @@
-- Instantiations
-- Reads of variables
- elsif Is_Suitable_Access (N)
- or else Is_Suitable_Variable_Assignment (N)
+ elsif Is_Suitable_Access (N) then
+ -- Signal any enclosing local exception handlers that the 'Access may
+ -- raise Program_Error due to a failed ABE check when switch -gnatd.o
+ -- (conservative elaboration order for indirect calls) is in effect.
+ -- Marking the exception handlers ensures proper expansion by both
+ -- the front and back end restriction when No_Exception_Propagation
+ -- is in effect.
+
+ if Debug_Flag_Dot_O then
+ Possible_Local_Raise (N, Standard_Program_Error);
+ end if;
+
+ elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then
+ Declaration_Level_OK := True;
+
+ -- Signal any enclosing local exception handlers that the call or
+ -- instantiation may raise Program_Error due to a failed ABE check.
+ -- Marking the exception handlers ensures proper expansion by both
+ -- the front and back end restriction when No_Exception_Propagation
+ -- is in effect.
+
+ Possible_Local_Raise (N, Standard_Program_Error);
+
+ elsif Is_Suitable_Variable_Assignment (N)
or else Is_Suitable_Variable_Read (N)
then
null;
- elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then
- Declaration_Level_OK := True;
-
-- Otherwise the input does not denote a suitable scenario
else
@@ -8271,7 +8291,7 @@
-- Mark a scenario which may produce run-time conditional ABE checks or
-- guaranteed ABE failures as recorded. The flag ensures that scenario
- -- rewritting performed by Atree.Rewrite will be properly reflected in
+ -- rewriting performed by Atree.Rewrite will be properly reflected in
-- all relevant internal data structures.
if Is_Check_Emitting_Scenario (N) then
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 253938)
+++ gcc-interface/gigi.h (working copy)
@@ -312,9 +312,9 @@
extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent,
tree t, int num);
-/* Return a label to branch to for the exception type in KIND or NULL_TREE
+/* Return a label to branch to for the exception type in KIND or Empty
if none. */
-extern tree get_exception_label (char kind);
+extern Entity_Id get_exception_label (char kind);
/* If nonzero, pretend we are allocating at global level. */
extern int force_global;
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 253938)
+++ gcc-interface/trans.c (working copy)
@@ -211,9 +211,9 @@
static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
/* The stacks for N_{Push,Pop}_*_Label. */
-static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
-static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
-static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
+static vec<Entity_Id> gnu_constraint_error_label_stack;
+static vec<Entity_Id> gnu_storage_error_label_stack;
+static vec<Entity_Id> gnu_program_error_label_stack;
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
@@ -226,7 +226,6 @@
static void insert_code_for (Node_Id);
static void add_cleanup (tree, Node_Id);
static void add_stmt_list (List_Id);
-static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
static tree build_stmt_group (List_Id, bool);
static inline bool stmt_group_may_fallthru (void);
static enum gimplify_status gnat_gimplify_stmt (tree *);
@@ -647,10 +646,11 @@
gnat_install_builtins ();
vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
- vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
- vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
- vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
+ gnu_constraint_error_label_stack.safe_push (Empty);
+ gnu_storage_error_label_stack.safe_push (Empty);
+ gnu_program_error_label_stack.safe_push (Empty);
+
/* Process any Pragma Ident for the main unit. */
if (Present (Ident_String (Main_Unit)))
targetm.asm_out.output_ident
@@ -5614,7 +5614,7 @@
const bool with_extra_info
= Exception_Extra_Info
&& !No_Exception_Handlers_Set ()
- && !get_exception_label (kind);
+ && No (get_exception_label (kind));
tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
/* The following processing is not required for correctness. Its purpose is
@@ -7271,8 +7271,9 @@
break;
case N_Goto_Statement:
- gnu_result
- = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
+ gnu_expr = gnat_to_gnu (Name (gnat_node));
+ gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_expr);
+ TREE_USED (gnu_expr) = 1;
break;
/***************************/
@@ -7492,30 +7493,36 @@
break;
case N_Push_Constraint_Error_Label:
- push_exception_label_stack (&gnu_constraint_error_label_stack,
- Exception_Label (gnat_node));
+ gnu_constraint_error_label_stack.safe_push (Exception_Label (gnat_node));
break;
case N_Push_Storage_Error_Label:
- push_exception_label_stack (&gnu_storage_error_label_stack,
- Exception_Label (gnat_node));
+ gnu_storage_error_label_stack.safe_push (Exception_Label (gnat_node));
break;
case N_Push_Program_Error_Label:
- push_exception_label_stack (&gnu_program_error_label_stack,
- Exception_Label (gnat_node));
+ gnu_program_error_label_stack.safe_push (Exception_Label (gnat_node));
break;
case N_Pop_Constraint_Error_Label:
- gnu_constraint_error_label_stack->pop ();
+ gnat_temp = gnu_constraint_error_label_stack.pop ();
+ if (Present (gnat_temp)
+ && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
+ Warn_If_No_Local_Raise (gnat_temp);
break;
case N_Pop_Storage_Error_Label:
- gnu_storage_error_label_stack->pop ();
+ gnat_temp = gnu_storage_error_label_stack.pop ();
+ if (Present (gnat_temp)
+ && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
+ Warn_If_No_Local_Raise (gnat_temp);
break;
case N_Pop_Program_Error_Label:
- gnu_program_error_label_stack->pop ();
+ gnat_temp = gnu_program_error_label_stack.pop ();
+ if (Present (gnat_temp)
+ && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false)))
+ Warn_If_No_Local_Raise (gnat_temp);
break;
/******************************/
@@ -8029,20 +8036,6 @@
return gnu_result;
}
-/* Subroutine of above to push the exception label stack. GNU_STACK is
- a pointer to the stack to update and GNAT_LABEL, if present, is the
- label to push onto the stack. */
-
-static void
-push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
-{
- tree gnu_label = (Present (gnat_label)
- ? gnat_to_gnu_entity (gnat_label, NULL_TREE, false)
- : NULL_TREE);
-
- vec_safe_push (*gnu_stack, gnu_label);
-}
-
/* Return true if the statement list STMT_LIST is empty. */
static bool
@@ -10226,28 +10219,28 @@
post_error_ne_tree (msg, node, ent, t);
}
-/* Return a label to branch to for the exception type in KIND or NULL_TREE
+/* Return a label to branch to for the exception type in KIND or Empty
if none. */
-tree
+Entity_Id
get_exception_label (char kind)
{
switch (kind)
{
case N_Raise_Constraint_Error:
- return gnu_constraint_error_label_stack->last ();
+ return gnu_constraint_error_label_stack.last ();
case N_Raise_Storage_Error:
- return gnu_storage_error_label_stack->last ();
+ return gnu_storage_error_label_stack.last ();
case N_Raise_Program_Error:
- return gnu_program_error_label_stack->last ();
+ return gnu_program_error_label_stack.last ();
default:
- break;
+ return Empty;
}
- return NULL_TREE;
+ gcc_unreachable ();
}
/* Return the decl for the current elaboration procedure. */
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 253938)
+++ gcc-interface/utils2.c (working copy)
@@ -1787,9 +1787,10 @@
MSG gives the exception's identity for the call to Local_Raise, if any. */
static tree
-build_goto_raise (tree label, int msg)
+build_goto_raise (Entity_Id gnat_label, int msg)
{
- tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
+ tree gnu_label = gnat_to_gnu_entity (gnat_label, NULL_TREE, false);
+ tree gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_label);
Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
/* If Local_Raise is present, build Local_Raise (Exception'Identity). */
@@ -1807,6 +1808,7 @@
= build2 (COMPOUND_EXPR, void_type_node, gnu_call, gnu_result);
}
+ TREE_USED (gnu_label) = 1;
return gnu_result;
}
@@ -1859,13 +1861,13 @@
tree
build_call_raise (int msg, Node_Id gnat_node, char kind)
{
+ Entity_Id gnat_label = get_exception_label (kind);
tree fndecl = gnat_raise_decls[msg];
- tree label = get_exception_label (kind);
tree filename, line;
/* If this is to be done as a goto, handle that case. */
- if (label)
- return build_goto_raise (label, msg);
+ if (Present (gnat_label))
+ return build_goto_raise (gnat_label, msg);
expand_sloc (gnat_node, &filename, &line, NULL);
@@ -1883,13 +1885,13 @@
tree
build_call_raise_column (int msg, Node_Id gnat_node, char kind)
{
+ Entity_Id gnat_label = get_exception_label (kind);
tree fndecl = gnat_raise_decls_ext[msg];
- tree label = get_exception_label (kind);
tree filename, line, col;
/* If this is to be done as a goto, handle that case. */
- if (label)
- return build_goto_raise (label, msg);
+ if (Present (gnat_label))
+ return build_goto_raise (gnat_label, msg);
expand_sloc (gnat_node, &filename, &line, &col);
@@ -1908,13 +1910,13 @@
build_call_raise_range (int msg, Node_Id gnat_node, char kind,
tree index, tree first, tree last)
{
+ Entity_Id gnat_label = get_exception_label (kind);
tree fndecl = gnat_raise_decls_ext[msg];
- tree label = get_exception_label (kind);
tree filename, line, col;
/* If this is to be done as a goto, handle that case. */
- if (label)
- return build_goto_raise (label, msg);
+ if (Present (gnat_label))
+ return build_goto_raise (gnat_label, msg);
expand_sloc (gnat_node, &filename, &line, &col);
