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`
``Acceleration``.
The dimensionality checks for relationals use the same rules as
-for "+" and "-"; thus
+for "+" and "-", except when comparing to a literal; thus
.. code-block:: ada
- acc > 10.0
+ acc > len
is equivalent to
.. code-block:: ada
- acc-10.0 > 0.0
+ acc-len > 0.0
+
+and is thus illegal, but
+
+ .. code-block:: ada
+
+ acc > 10.0
-and is thus illegal. Analogously a conditional expression
-requires the same dimension vector for each branch.
+is accepted with a warning. Analogously a conditional expression requires the
+same dimension vector for each branch (with no exception for literals).
The dimension vector of a type conversion :samp:`T({expr})` is defined
as follows, based on the nature of ``T``:
-- 1) Internal entities (such as temporaries generated for the result
-- of an inlined function call or dummy variables generated for the
-- debugger). Set to indicate that they need not be initialized, even
--- when scalars are initialized or normalized;
+-- when scalars are initialized or normalized.
--
-- 2) Predefined primitives of tagged types. Set to mark that they
-- have specific properties: first they are primitives even if they
-- --
-- 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- --
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.
---------------------------
-- 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
-- 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);
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 --
----------------------------
-- --
-- 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- --
-- 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;
Stmt := First (Stmts);
while Present (Stmt) loop
if Nkind (Stmt) = N_Block_Statement then
- Replace_Returns (Param_Id, Statements (Stmt));
+ Replace_Returns (Param_Id,
+ Statements (Handled_Statement_Sequence (Stmt)));
elsif Nkind (Stmt) = N_Case_Statement then
declare
Related_Nod : Node_Id := Empty) return Entity_Id;
-- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
-- is present (xxx is taken from the Chars field of Related_Nod),
- -- otherwise it generates an internal temporary.
+ -- otherwise it generates an internal temporary. The created temporary
+ -- entity is marked as internal.
---------------------
-- Build_Temporary --
Related_Nod : Node_Id := Empty) return Entity_Id
is
Temp_Nam : Name_Id;
+ Temp_Id : Entity_Id;
begin
-- The context requires an external symbol
Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
end if;
- return Make_Defining_Identifier (Loc, Temp_Nam);
+ Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
-- Otherwise generate an internal temporary
else
- return Make_Temporary (Loc, Id, Related_Nod);
+ Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
end if;
+
+ Set_Is_Internal (Temp_Id);
+
+ return Temp_Id;
end Build_Temporary;
-- Local variables
#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: */
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;
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];
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 *);
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)))
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
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;
/***************************/
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;
/******************************/
return gnu_result;
}
\f
-/* 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);
-}
-\f
/* Return true if the statement list STMT_LIST is empty. */
static bool
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. */
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). */
= build2 (COMPOUND_EXPR, void_type_node, gnu_call, gnu_result);
}
+ TREE_USED (gnu_label) = 1;
return gnu_result;
}
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);
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);
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);
@copying
@quotation
-GNAT User's Guide for Native Platforms , Oct 14, 2017
+GNAT User's Guide for Native Platforms , Oct 20, 2017
AdaCore
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.
@item @code{-gnatw.X}
@code{Acceleration}.
The dimensionality checks for relationals use the same rules as
-for "+" and "-"; thus
+for "+" and "-", except when comparing to a literal; thus
@quotation
@example
-acc > 10.0
+acc > len
@end example
@end quotation
@quotation
@example
-acc-10.0 > 0.0
+acc-len > 0.0
+@end example
+@end quotation
+
+and is thus illegal, but
+
+@quotation
+
+@example
+acc > 10.0
@end example
@end quotation
-and is thus illegal. Analogously a conditional expression
-requires the same dimension vector for each branch.
+is accepted with a warning. Analogously a conditional expression requires the
+same dimension vector for each branch (with no exception for literals).
The dimension vector of a type conversion @code{T(@emph{expr})} is defined
as follows, based on the nature of @code{T}:
elsif Ekind (E1) = E_Package then
Check_Mismatch
(Ekind (E1) /= Ekind (E2)
- or else Renamed_Object (E1) /= Renamed_Object (E2));
+ or else (Present (Renamed_Object (E2))
+ and then Renamed_Object (E1) /=
+ Renamed_Object (E2)));
elsif Is_Overloadable (E1) then
-
-- Verify that the actual subprograms match. Note that actuals
-- that are attributes are rewritten as subprograms. If the
-- subprogram in the formal package is defaulted, no check is
begin
-- Preanalyze a duplicate of the expression to have available the
-- minimum decoration needed to locate referenced unfrozen types
- -- without adding any decoration to the function expression. This
- -- preanalysis is performed with errors disabled to avoid reporting
- -- spurious errors on Ghost entities (since the expression is not
- -- fully analyzed).
+ -- without adding any decoration to the function expression.
Push_Scope (Def_Id);
Install_Formals (Def_Id);
- Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
Preanalyze_Spec_Expression (Dup_Expr, Etype (Def_Id));
-
- Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
End_Scope;
-- Restore certain attributes of Def_Id since the preanalysis may
then
Error_Msg_Node_1 := Entity (N);
Error_Msg_NE
- ("use clause for package &? has no effect",
+ ("use clause for package & has no effect?u?",
Curr, Entity (N));
end if;
else
Error_Msg_Node_1 := Etype (N);
Error_Msg_NE
- ("use clause for }? has no effect", Curr, Etype (N));
+ ("use clause for } has no effect?u?", Curr, Etype (N));
end if;
end if;
then
null;
+ -- Numeric literal case. Issue a warning to indicate the
+ -- literal is treated as if its dimension matches the type
+ -- dimension.
+
+ elsif Nkind_In (Original_Node (L), N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (L, Etype (R));
+
+ elsif Nkind_In (Original_Node (R), N_Real_Literal,
+ N_Integer_Literal)
+ then
+ Dim_Warning_For_Numeric_Literal (R, Etype (L));
+
else
Error_Dim_Msg_For_Binary_Op (N, L, R);
end if;
procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is
begin
+ -- Consider the literal zero (integer 0 or real 0.0) to be of any
+ -- dimension.
+
+ case Nkind (Original_Node (N)) is
+ when N_Real_Literal =>
+ if Expr_Value_R (N) = Ureal_0 then
+ return;
+ end if;
+
+ when N_Integer_Literal =>
+ if Expr_Value (N) = Uint_0 then
+ return;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
-- Initialize name buffer
Name_Len := 0;
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;
-- 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
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.
-- Instantiations
-- Reads of variables
- elsif Is_Suitable_Access (N)
- or else Is_Suitable_Variable_Assignment (N)
- or else Is_Suitable_Variable_Read (N)
- then
- null;
+ 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;
+
-- Otherwise the input does not denote a suitable scenario
else
-- 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
return False;
elsif Nkind (Par) in N_Declaration then
- if Nkind (Par) = N_Object_Declaration then
- return Present (Corresponding_Generic_Association (Par));
- else
- return False;
- end if;
+ return Nkind (Par) = N_Object_Declaration
+ and then Present (Corresponding_Generic_Association (Par));
elsif Nkind (Par) = N_Object_Renaming_Declaration then
return Present (Corresponding_Generic_Association (Par));
and then not Comes_From_Source (Par)
then
-- Continue to examine the context if the reference appears in a
- -- subprogram body which was previously an expression function.
+ -- subprogram body which was previously an expression function,
+ -- unless this is during preanalysis (when In_Spec_Expression is
+ -- True), as the body may not yet be inserted in the tree.
if Nkind (Par) = N_Subprogram_Body
and then Was_Expression_Function (Par)
+ and then not In_Spec_Expression
then
null;
or else (Present (Renamed_Object (E))
and then Is_Aliased_View (Renamed_Object (E)))))
- or else ((Is_Formal (E)
- or else Ekind_In (E, E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter))
+ or else ((Is_Formal (E) or else Is_Formal_Object (E))
and then Is_Tagged_Type (Etype (E)))
or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
+2017-10-20 Justin Squirek <squirek@adacore.com>
+
+ * gnat.dg/default_pkg_actual.adb, gnat.dg/default_pkg_actual2.adb: New
+ testcases.
+
2017-10-20 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/dimensions.adb, gnat.dg/dimensions.ads: New testcase.
--- /dev/null
+-- { dg-do compile }
+
+procedure Default_Pkg_Actual is
+
+ generic
+ package As is
+ end As;
+
+ generic
+ type T is private;
+ with package A0 is new As;
+ package Bs is
+ end Bs;
+
+ generic
+ with package Xa is new As;
+ package Xs is
+ package Xb is new Bs(T => Integer, A0 => Xa);
+ end Xs;
+
+ generic
+ with package Yb is new Bs(T => Integer, others => <>);
+ package Ys is
+ end Ys;
+
+ package A is new As;
+ package X is new Xs(Xa => A);
+ package Y is new Ys(Yb => X.Xb);
+
+begin
+ null;
+end;
--- /dev/null
+-- { dg-do compile }
+
+procedure Default_Pkg_Actual2 is
+
+ generic
+ package P1 is
+ end;
+
+ generic
+ with package FP1a is new P1;
+ with package FP1b is new P1;
+ package P2 is
+ end;
+
+ generic
+ with package FP2 is new P2 (FP1a => <>, FP1b => <>);
+ package P3 is
+ end;
+
+ package NP1a is new P1;
+ package NP1b is new P1;
+ package NP2 is new P2 (NP1a, NP1b);
+ package NP4 is new P3 (NP2);
+
+begin
+ null;
+end;
projects / platform / upstream / gcc.git / commitdiff