From 8f8f531f0def95af2eb35265a3e7b6c3aa43ad7c Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Fri, 20 Oct 2017 16:05:28 +0000 Subject: [PATCH] sem_dim.adb (Analyze_Dimension_Binary_Op): Accept with a warning to compare a dimensioned expression with a literal. gcc/ada/ 2017-10-20 Yannick Moy * sem_dim.adb (Analyze_Dimension_Binary_Op): Accept with a warning to compare a dimensioned expression with a literal. (Dim_Warning_For_Numeric_Literal): Do not issue a warning for the special value zero. * doc/gnat_ugn/gnat_and_program_execution.rst: Update description of dimensionality system in GNAT. * gnat_ugn.texi: Regenerate. 2017-10-20 Yannick Moy * sem_ch6.adb (Analyze_Expression_Function.Freeze_Expr_Types): Remove inadequate silencing of errors. * sem_util.adb (Check_Part_Of_Reference): Do not issue an error when checking the subprogram body generated from an expression function, when this is done as part of the preanalysis done on expression functions, as the subprogram body may not yet be attached in the AST. The error if any will be issued later during the analysis of the body. (Is_Aliased_View): Trivial rewrite with Is_Formal_Object. 2017-10-20 Arnaud Charlet * sem_ch8.adb (Update_Chain_In_Scope): Add missing [-gnatwu] marker for warning on ineffective use clause. 2017-10-20 Eric Botcazou * 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) : 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. 2017-10-20 Piotr Trojanek * einfo.ads: Minor consistent punctuation in comment. All numbered items in the comment of Is_Internal are now terminated with a period. 2017-10-20 Piotr Trojanek * exp_util.adb (Build_Temporary): Mark created temporary entity as internal. 2017-10-20 Piotr Trojanek * sem_type.adb (In_Generic_Actual): Simplified. 2017-10-20 Justin Squirek * sem_ch12.adb (Check_Formal_Package_Instance): Add sanity check to verify a renaming exists for a generic formal before comparing it to the actual as defaulted formals will not have a renamed_object. 2017-10-20 Javier Miranda * exp_ch6.adb (Replace_Returns): Fix wrong management of N_Block_Statement nodes. gcc/testsuite/ 2017-10-20 Justin Squirek * gnat.dg/default_pkg_actual.adb, gnat.dg/default_pkg_actual2.adb: New testcases. From-SVN: r253945 --- ...building_executable_programs_with_gnat.rst | 4 +- .../gnat_ugn/gnat_and_program_execution.rst | 16 ++-- gcc/ada/einfo.ads | 2 +- gcc/ada/exp_ch11.adb | 33 ++++++--- gcc/ada/exp_ch11.ads | 7 +- gcc/ada/exp_ch6.adb | 3 +- gcc/ada/exp_util.adb | 12 ++- gcc/ada/fe.h | 2 + gcc/ada/gcc-interface/gigi.h | 4 +- gcc/ada/gcc-interface/trans.c | 73 +++++++++---------- gcc/ada/gcc-interface/utils2.c | 24 +++--- gcc/ada/gnat_ugn.texi | 25 +++++-- gcc/ada/sem_ch12.adb | 5 +- gcc/ada/sem_ch6.adb | 8 +- gcc/ada/sem_ch8.adb | 4 +- gcc/ada/sem_dim.adb | 32 ++++++++ gcc/ada/sem_elab.adb | 36 +++++++-- gcc/ada/sem_type.adb | 7 +- gcc/ada/sem_util.adb | 9 ++- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gnat.dg/default_pkg_actual.adb | 32 ++++++++ gcc/testsuite/gnat.dg/default_pkg_actual2.adb | 27 +++++++ 22 files changed, 259 insertions(+), 111 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/default_pkg_actual.adb create mode 100644 gcc/testsuite/gnat.dg/default_pkg_actual2.adb diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 046fe35a825..90d29e1b98d 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -3898,8 +3898,8 @@ of the pragma in the :title:`GNAT_Reference_manual`). 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` diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index ac45cee3305..8f9f37cc0d8 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3611,20 +3611,26 @@ combine a dimensioned and dimensionless value. Thus an expression such as ``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``: diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2b2a8382e3b..bfe14fcae7c 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2756,7 +2756,7 @@ package Einfo is -- 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 diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 8711c89d0eb..7941cbd2ca6 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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 @@ package body Exp_Ch11 is 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 @@ package body Exp_Ch11 is -- 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 @@ package body Exp_Ch11 is -- 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); @@ -2154,6 +2153,22 @@ package body Exp_Ch11 is end case; 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 -- ---------------------------- diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index cdd53de626e..99efdeb2305 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -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 @@ package Exp_Ch11 is -- 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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c7cd2a664e1..bca7e5deae4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -712,7 +712,8 @@ package body Exp_Ch6 is 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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2fb0e88346f..16eaf186996 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10978,7 +10978,8 @@ package body Exp_Util is 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 -- @@ -10990,6 +10991,7 @@ package body Exp_Util is Related_Nod : Node_Id := Empty) return Entity_Id is Temp_Nam : Name_Id; + Temp_Id : Entity_Id; begin -- The context requires an external symbol @@ -11001,13 +11003,17 @@ package body Exp_Util is 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 diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 513cfa97daa..6b6d524bcd7 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -109,10 +109,12 @@ extern Nat Serious_Errors_Detected; #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: */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 4ddd0f0a8d2..a957de5e589 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -312,9 +312,9 @@ extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, 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; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index a7579378cca..0e46e5a921c 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -211,9 +211,9 @@ typedef struct loop_info_d *loop_info; static GTY(()) vec *gnu_loop_stack; /* The stacks for N_{Push,Pop}_*_Label. */ -static GTY(()) vec *gnu_constraint_error_label_stack; -static GTY(()) vec *gnu_storage_error_label_stack; -static GTY(()) vec *gnu_program_error_label_stack; +static vec gnu_constraint_error_label_stack; +static vec gnu_storage_error_label_stack; +static vec 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 record_code_position (Node_Id); 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 **, 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,9 +646,10 @@ gigi (Node_Id gnat_root, 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))) @@ -5614,7 +5614,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) 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 @@ gnat_to_gnu (Node_Id gnat_node) 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 @@ gnat_to_gnu (Node_Id gnat_node) 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 @@ gnat_to_gnu_external (Node_Id gnat_node) 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 **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_2 (const char *msg, Node_Id node, Entity_Id ent, tree t, 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. */ diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 6f109c73146..dcd4134a434 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1787,9 +1787,10 @@ build_call_n_expr (tree fndecl, int n, ...) 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 @@ build_goto_raise (tree label, int msg) = build2 (COMPOUND_EXPR, void_type_node, gnu_call, gnu_result); } + TREE_USED (gnu_label) = 1; return gnu_result; } @@ -1859,13 +1861,13 @@ expand_sloc (Node_Id gnat_node, tree *filename, tree *line, tree *col) 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 @@ build_call_raise (int msg, Node_Id gnat_node, char kind) 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 @@ tree 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); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 08e4b4bff94..9488b888941 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Oct 14, 2017 +GNAT User's Guide for Native Platforms , Oct 20, 2017 AdaCore @@ -12474,8 +12474,8 @@ should not complain at you. 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} @@ -22901,12 +22901,12 @@ combine a dimensioned and dimensionless value. Thus an expression such as @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 @@ -22915,12 +22915,21 @@ is equivalent to @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}: diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9820330f523..ac5035fd1bc 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6459,10 +6459,11 @@ package body Sem_Ch12 is 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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a85ca60cd5f..4f719e9b81c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -442,18 +442,12 @@ package body Sem_Ch6 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 982b2221632..5f4cd47786a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -9075,7 +9075,7 @@ package body Sem_Ch8 is 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; @@ -9084,7 +9084,7 @@ package body Sem_Ch8 is 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; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 2363eedc69a..19a3cfbbc6c 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1577,6 +1577,20 @@ package body Sem_Dim is 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; @@ -2724,6 +2738,24 @@ package body Sem_Dim is 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; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 3dcba585cff..4802055a076 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -27,6 +27,7 @@ with Atree; use Atree; 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 @@ package body Sem_Elab is -- 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 @@ package body Sem_Elab is 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 @@ package body Sem_Elab is -- 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 @@ -8271,7 +8291,7 @@ package body Sem_Elab is -- 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 diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 05315852511..812682a846e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2838,11 +2838,8 @@ package body Sem_Type is 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)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0eefd505c25..13f030e7133 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3354,10 +3354,13 @@ package body Sem_Util is 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; @@ -12545,9 +12548,7 @@ package body Sem_Util is 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)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 30d3203b186..0a8f11222a8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-10-20 Justin Squirek + + * gnat.dg/default_pkg_actual.adb, gnat.dg/default_pkg_actual2.adb: New + testcases. + 2017-10-20 Ed Schonberg * gnat.dg/dimensions.adb, gnat.dg/dimensions.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/default_pkg_actual.adb b/gcc/testsuite/gnat.dg/default_pkg_actual.adb new file mode 100644 index 00000000000..d10ae0c152b --- /dev/null +++ b/gcc/testsuite/gnat.dg/default_pkg_actual.adb @@ -0,0 +1,32 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/default_pkg_actual2.adb b/gcc/testsuite/gnat.dg/default_pkg_actual2.adb new file mode 100644 index 00000000000..7ab614a0994 --- /dev/null +++ b/gcc/testsuite/gnat.dg/default_pkg_actual2.adb @@ -0,0 +1,27 @@ +-- { 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; -- 2.30.2