diff options
| -rw-r--r-- | gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst | 4 | ||||
| -rw-r--r-- | gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst | 16 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/fe.h | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 73 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils2.c | 24 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 9 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/default_pkg_actual.adb | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/default_pkg_actual2.adb | 27 |
22 files changed, 259 insertions, 111 deletions
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 046fe35..90d29e1 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 ac45cee..8f9f37c 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 2b2a838..bfe14fc 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 8711c89..7941cbd 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); @@ -2155,6 +2154,22 @@ package body Exp_Ch11 is 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 cdd53de..99efdeb 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 c7cd2a6..bca7e5d 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 2fb0e88..16eaf18 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 513cfa9..6b6d524 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 4ddd0f0..a957de5 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 a757937..0e46e5a 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<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 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<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,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<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_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 6f109c7..dcd4134 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 08e4b4b..9488b88 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 9820330..ac5035f 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 a85ca60..4f719e9 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 982b222..5f4cd47 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 2363eed..19a3cfb 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 3dcba58..4802055 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 0531585..812682a 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 0eefd505..13f030e 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 30d3203..0a8f112 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +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. 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 0000000..d10ae0c --- /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 0000000..7ab614a --- /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; |