From 304757d2ceec74e12ac43312b7eab9aa3b092126 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 27 Apr 2017 15:38:28 +0200 Subject: [PATCH] [multiple changes] 2017-04-27 Hristian Kirtchev * sem_eval.adb (Subtypes_Statically_Compatible): Remove duplicated check. (Subtypes_Statically_Match): Remove duplicate check. * sem_prag.adb (Check_Arg_Is_External_Name): Remove duplicate check. 2017-04-27 Hristian Kirtchev * exp_aggr.adb (Replace_Type): Remove the special processing for selected components. * exp_attr.adb (Expand_N_Attribute_Reference): Merge the processing for attributes Fixed_Value and Integer_Value. * exp_util.adb (Side_Effect_Free): Merge the processing for qualified expressions, type conversions, and unchecked type conversions. * g-comlin.adb (Is_In_Config): Merge the processing for No_Space and Optional. * par-ch3.adb (P_Declarative_Items): Merge the processing for tokens function, not, overriding, and procedure. * sem_ch6.adb (Fully_Conformant_Expressions): Merge the processing for qualified expressions, type conversions, and unchecked type conversions. * sem_util.adb (Compile_Time_Constraint_Error): Merge the processing for Ada 83 and instances. (Object_Access_Level): Merge the processing for indexed components and selected components. * uname.adb (Add_Node_Name): Merge the processing for stubs. 2017-04-27 Hristian Kirtchev * checks.adb (Install_Primitive_Elaboration_Check): Do not generate the check when restriction No_Elaboration_Code is in effect. 2017-04-27 Ed Schonberg * exp_disp.adb (Build_Class_Wide_Check): New subsidiary of Expand_Dispatching_Call. If the denoted subprogram has a class-wide precondition, this is the only precondition that applies to the call, rather that the class-wide preconditions that may apply to the body that is executed. (This is specified in AI12-0195). From-SVN: r247333 --- gcc/ada/ChangeLog | 44 ++++++++++++++++++ gcc/ada/checks.adb | 6 ++- gcc/ada/exp_aggr.adb | 12 +---- gcc/ada/exp_attr.adb | 49 +++++--------------- gcc/ada/exp_disp.adb | 108 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/exp_util.adb | 21 +++------ gcc/ada/g-comlin.adb | 11 ++--- gcc/ada/par-ch3.adb | 27 +++-------- gcc/ada/sem_ch6.adb | 17 ++----- gcc/ada/sem_eval.adb | 50 ++++++++------------ gcc/ada/sem_prag.adb | 21 ++------- gcc/ada/sem_util.adb | 37 +++++---------- gcc/ada/uname.adb | 10 ++-- 13 files changed, 227 insertions(+), 186 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7c4293d27c60..1be7e3e06dd9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2017-04-27 Hristian Kirtchev + + * sem_eval.adb (Subtypes_Statically_Compatible): Remove duplicated + check. + (Subtypes_Statically_Match): Remove duplicate check. + * sem_prag.adb (Check_Arg_Is_External_Name): Remove duplicate check. + +2017-04-27 Hristian Kirtchev + + * exp_aggr.adb (Replace_Type): Remove the special processing + for selected components. + * exp_attr.adb (Expand_N_Attribute_Reference): Merge the + processing for attributes Fixed_Value and Integer_Value. + * exp_util.adb (Side_Effect_Free): Merge the processing for + qualified expressions, type conversions, and unchecked type + conversions. + * g-comlin.adb (Is_In_Config): Merge the processing for No_Space + and Optional. + * par-ch3.adb (P_Declarative_Items): Merge the processing for + tokens function, not, overriding, and procedure. + * sem_ch6.adb (Fully_Conformant_Expressions): Merge the processing + for qualified expressions, type conversions, and unchecked + type conversions. + * sem_util.adb (Compile_Time_Constraint_Error): Merge the + processing for Ada 83 and instances. + (Object_Access_Level): Merge the processing for indexed components + and selected components. + * uname.adb (Add_Node_Name): Merge the processing for stubs. + +2017-04-27 Hristian Kirtchev + + * checks.adb (Install_Primitive_Elaboration_Check): + Do not generate the check when restriction No_Elaboration_Code + is in effect. + +2017-04-27 Ed Schonberg + + * exp_disp.adb (Build_Class_Wide_Check): New subsidiary + of Expand_Dispatching_Call. If the denoted subprogram has a + class-wide precondition, this is the only precondition that + applies to the call, rather that the class-wide preconditions + that may apply to the body that is executed. (This is specified + in AI12-0195). + 2017-04-27 Yannick Moy * gnat1drv.adb (Adjust_Global_Switches): Issue diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d9a36df32a99..fa55615db7f3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7740,7 +7740,6 @@ package body Checks is ----------------------------------------- procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is - function Within_Compilation_Unit_Instance (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id appears within an instance which @@ -7796,6 +7795,11 @@ package body Checks is if ASIS_Mode or GNATprove_Mode then return; + -- Do not generate an elaboration check if such code is not desirable + + elsif Restriction_Active (No_Elaboration_Code) then + return; + -- Do not generate an elaboration check if the related subprogram is -- not subjected to accessibility checks. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 685edaafa724..0cbbd01875d3 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.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- -- @@ -3042,15 +3042,7 @@ package body Exp_Aggr is and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr))) then if Is_Entity_Name (Lhs) then - Rewrite (Prefix (Expr), - New_Occurrence_Of (Entity (Lhs), Loc)); - - elsif Nkind (Lhs) = N_Selected_Component then - Rewrite (Expr, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Unrestricted_Access, - Prefix => New_Copy_Tree (Lhs))); - Set_Analyzed (Parent (Expr), False); + Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc)); else Rewrite (Expr, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ad6ab41cc730..21a17716acaf 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3360,24 +3360,30 @@ package body Exp_Attr is end if; end First_Bit_Attr; - ----------------- - -- Fixed_Value -- - ----------------- + -------------------------------- + -- Fixed_Value, Integer_Value -- + -------------------------------- - -- We transform: + -- We transform -- fixtype'Fixed_Value (integer-value) + -- inttype'Fixed_Value (fixed-value) -- into - -- fixtype(integer-value) + -- fixtype (integer-value) + -- inttype (fixed-value) + + -- respectively. -- We do all the required analysis of the conversion here, because we do -- not want this to go through the fixed-point conversion circuits. Note -- that the back end always treats fixed-point as equivalent to the -- corresponding integer type anyway. - when Attribute_Fixed_Value => + when Attribute_Fixed_Value + | Attribute_Integer_Value + => Rewrite (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), @@ -3923,37 +3929,6 @@ package body Exp_Attr is end if; end Input; - ------------------- - -- Integer_Value -- - ------------------- - - -- We transform - - -- inttype'Fixed_Value (fixed-value) - - -- into - - -- inttype(integer-value)) - - -- we do all the required analysis of the conversion here, because we do - -- not want this to go through the fixed-point conversion circuits. Note - -- that the back end always treats fixed-point as equivalent to the - -- corresponding integer type anyway. - - when Attribute_Integer_Value => - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), - Expression => Relocate_Node (First (Exprs)))); - Set_Etype (N, Entity (Pref)); - Set_Analyzed (N); - - -- Note: it might appear that a properly analyzed unchecked - -- conversion would be just fine here, but that's not the case, since - -- the full range check performed by the following call is critical. - - Apply_Type_Conversion_Checks (N); - ------------------- -- Invalid_Value -- ------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 0a6a03b7fd5f..d1822c4df466 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -58,6 +58,7 @@ with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -649,11 +650,112 @@ package body Exp_Disp is Eq_Prim_Op : Entity_Id := Empty; Controlling_Tag : Node_Id; + procedure Build_Class_Wide_Check; + -- If the denoted subprogram has a class-wide precondition, generate + -- a check using that precondition before the dispatching call, because + -- this is the only class-wide precondition that applies to the call. + function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an -- access parameter. + ---------------------------- + -- Build_Class_Wide_Check -- + ---------------------------- + + procedure Build_Class_Wide_Check is + Prec : Node_Id; + Cond : Node_Id; + Msg : Node_Id; + Str_Loc : constant String := Build_Location_String (Loc); + + function Replace_Formals (N : Node_Id) return Traverse_Result; + -- Replace occurrences of the formals of the subprogram by the + -- corresponding actuals in the call, given that this check is + -- performed outside of the body of the subprogram. + + --------------------- + -- Replace_Formals -- + --------------------- + + function Replace_Formals (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Formal (Entity (N)) + then + declare + A : Node_Id; + F : Entity_Id; + + begin + F := First_Formal (Subp); + A := First_Actual (Call_Node); + while Present (F) loop + if F = Entity (N) then + Rewrite (N, New_Copy_Tree (A)); + exit; + end if; + Next_Formal (F); + Next_Actual (A); + end loop; + end; + end if; + + return OK; + end Replace_Formals; + + procedure Update is new Traverse_Proc (Replace_Formals); + begin + + -- Locate class-wide precondition, if any + + if Present (Contract (Subp)) + and then Present (Pre_Post_Conditions (Contract (Subp))) + then + Prec := Pre_Post_Conditions (Contract (Subp)); + + while Present (Prec) loop + exit when Pragma_Name (Prec) = Name_Precondition + and then Class_Present (Prec); + Prec := Next_Pragma (Prec); + end loop; + + if No (Prec) then + return; + end if; + + -- The expression for the precondition is analyzed within the + -- generated pragma. The message text is the last parameter + -- of the generated pragma, indicating source of precondition. + + Cond := New_Copy_Tree + (Expression (First (Pragma_Argument_Associations (Prec)))); + Update (Cond); + + -- Build message indicating the failed precondition and the + -- dispatching call that caused it. + + Msg := Expression (Last (Pragma_Argument_Associations (Prec))); + Name_Len := 0; + Append (Global_Name_Buffer, Strval (Msg)); + Append (Global_Name_Buffer, " in dispatching call at "); + Append (Global_Name_Buffer, Str_Loc); + Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + + Insert_Action (Call_Node, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List (Msg))))); + end if; + end Build_Class_Wide_Check; + --------------- -- New_Value -- --------------- @@ -714,6 +816,8 @@ package body Exp_Disp is Subp := Alias (Subp); end if; + Build_Class_Wide_Check; + -- Definition of the class-wide type and the tagged type -- If the controlling argument is itself a tag rather than a tagged @@ -1174,7 +1278,7 @@ package body Exp_Disp is if not Tagged_Type_Expansion then return; - -- A static conversion to an interface type that is not classwide is + -- A static conversion to an interface type that is not class-wide is -- curious but legal if the interface operation is a null procedure. -- If the operation is abstract it will be rejected later. @@ -1190,7 +1294,7 @@ package body Exp_Disp is if not Is_Static then - -- Give error if configurable run time and Displace not available + -- Give error if configurable run-time and Displace not available if not RTE_Available (RE_Displace) then Error_Msg_CRT ("dynamic interface conversion", N); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2c23841f465c..0c87e1f9739d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -12942,10 +12942,13 @@ package body Exp_Util is Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) and then Safe_Prefixed_Reference (N); - -- A type qualification is side effect free if the expression - -- is side effect free. + -- A type qualification, type conversion, or unchecked expression is + -- side effect free if the expression is side effect free. - when N_Qualified_Expression => + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Expression + => return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); -- A selected component is side effect free only if it is a side @@ -12969,12 +12972,6 @@ package body Exp_Util is Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref) and then Safe_Prefixed_Reference (N); - -- A type conversion is side effect free if the expression to be - -- converted is side effect free. - - when N_Type_Conversion => - return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); - -- A unary operator is side effect free if the operand -- is side effect free. @@ -12990,12 +12987,6 @@ package body Exp_Util is and then Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); - -- An unchecked expression is side effect free if its expression - -- is side effect free. - - when N_Unchecked_Expression => - return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref); - -- A literal is side effect free when N_Character_Literal diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index ef76fee3f68f..978040ea78da 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -2002,12 +2002,9 @@ package body GNAT.Command_Line is Found_In_Config := True; return False; - when Parameter_No_Space => - Callback (Switch, "", Parameter, Index); - Found_In_Config := True; - return False; - - when Parameter_Optional => + when Parameter_No_Space + | Parameter_Optional + => Callback (Switch, "", Parameter, Index); Found_In_Config := True; return False; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 5c846645e9d0..529c501f26db 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.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- -- @@ -4319,7 +4319,11 @@ package body Ch3 is end if; case Token is - when Tok_Function => + when Tok_Function + | Tok_Not + | Tok_Overriding + | Tok_Procedure + => Check_Bad_Layout; Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; @@ -4374,20 +4378,6 @@ package body Ch3 is P_Identifier_Declarations (Decls, Done, In_Spec); end if; - -- Ada 2005: A subprogram declaration can start with "not" or - -- "overriding". In older versions, "overriding" is handled - -- like an identifier, with the appropriate messages. - - when Tok_Not => - Check_Bad_Layout; - Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); - Done := False; - - when Tok_Overriding => - Check_Bad_Layout; - Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); - Done := False; - when Tok_Package => Check_Bad_Layout; Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); @@ -4397,11 +4387,6 @@ package body Ch3 is Append (P_Pragma, Decls); Done := False; - when Tok_Procedure => - Check_Bad_Layout; - Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); - Done := False; - when Tok_Protected => Check_Bad_Layout; Scan; -- past PROTECTED diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 32384d9e6199..9ba68b1ec3f8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8981,7 +8981,10 @@ package body Sem_Ch6 is and then FCE (Explicit_Actual_Parameter (E1), Explicit_Actual_Parameter (E2)); - when N_Qualified_Expression => + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) and then @@ -9084,24 +9087,12 @@ package body Sem_Ch6 is end if; end; - when N_Type_Conversion => - return - FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then - FCE (Expression (E1), Expression (E2)); - when N_Unary_Op => return Entity (E1) = Entity (E2) and then FCE (Right_Opnd (E1), Right_Opnd (E2)); - when N_Unchecked_Type_Conversion => - return - FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then - FCE (Expression (E1), Expression (E2)); - -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore -- the nodes. This means that if anyone makes a mistake in the diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 24e0963c88e5..41941ba50b04 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5681,14 +5681,6 @@ package body Sem_Eval is then return False; - -- If either type has constraint error bounds, then consider that - -- they match to avoid junk cascaded errors here. - - elsif not Is_OK_Static_Subtype (T1) - or else not Is_OK_Static_Subtype (T2) - then - return True; - -- Base types must match, but we don't check that (should we???) but -- we do at least check that both types are real, or both types are -- not real. @@ -5708,19 +5700,17 @@ package body Sem_Eval is begin if Is_Real_Type (T1) then return - (Expr_Value_R (LB1) > Expr_Value_R (HB1)) + Expr_Value_R (LB1) > Expr_Value_R (HB1) or else - (Expr_Value_R (LB2) <= Expr_Value_R (LB1) - and then - Expr_Value_R (HB1) <= Expr_Value_R (HB2)); + (Expr_Value_R (LB2) <= Expr_Value_R (LB1) + and then Expr_Value_R (HB1) <= Expr_Value_R (HB2)); else return - (Expr_Value (LB1) > Expr_Value (HB1)) + Expr_Value (LB1) > Expr_Value (HB1) or else - (Expr_Value (LB2) <= Expr_Value (LB1) - and then - Expr_Value (HB1) <= Expr_Value (HB2)); + (Expr_Value (LB2) <= Expr_Value (LB1) + and then Expr_Value (HB1) <= Expr_Value (HB2)); end if; end; end if; @@ -5728,17 +5718,20 @@ package body Sem_Eval is -- Access types elsif Is_Access_Type (T1) then - return (not Is_Constrained (T2) - or else (Subtypes_Statically_Match - (Designated_Type (T1), Designated_Type (T2)))) + return + (not Is_Constrained (T2) + or else Subtypes_Statically_Match + (Designated_Type (T1), Designated_Type (T2))) and then not (Can_Never_Be_Null (T2) and then not Can_Never_Be_Null (T1)); -- All other cases else - return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) - or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching); + return + (Is_Composite_Type (T1) and then not Is_Constrained (T2)) + or else Subtypes_Statically_Match + (T1, T2, Formal_Derived_Matching); end if; end Subtypes_Statically_Compatible; @@ -5856,23 +5849,16 @@ package body Sem_Eval is else if not Is_OK_Static_Subtype (T1) - or else not Is_OK_Static_Subtype (T2) + or else + not Is_OK_Static_Subtype (T2) then return False; - -- If either type has constraint error bounds, then say that - -- they match to avoid junk cascaded errors here. - - elsif not Is_OK_Static_Subtype (T1) - or else not Is_OK_Static_Subtype (T2) - then - return True; - elsif Is_Real_Type (T1) then return - (Expr_Value_R (LB1) = Expr_Value_R (LB2)) + Expr_Value_R (LB1) = Expr_Value_R (LB2) and then - (Expr_Value_R (HB1) = Expr_Value_R (HB2)); + Expr_Value_R (HB1) = Expr_Value_R (HB2); else return diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 5e90f7b15a0c..9cbd22426418 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4905,25 +4905,15 @@ package body Sem_Prag is then return; - -- Static expression that raises Constraint_Error. This has - -- already been flagged, so just exit from pragma processing. - - elsif Is_OK_Static_Expression (Argx) then - raise Pragma_Exit; - -- Here we have a real error (non-static expression) else Error_Msg_Name_1 := Pname; + Flag_Non_Static_Expr + (Fix_Error ("argument for pragma% must be a identifier or " + & "static string expression!"), Argx); - declare - Msg : constant String := - "argument for pragma% must be a identifier or " - & "static string expression!"; - begin - Flag_Non_Static_Expr (Fix_Error (Msg), Argx); - raise Pragma_Exit; - end; + raise Pragma_Exit; end if; end if; end Check_Arg_Is_External_Name; @@ -4936,8 +4926,7 @@ package body Sem_Prag is Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin if Nkind (Argx) /= N_Identifier then - Error_Pragma_Arg - ("argument for pragma% must be identifier", Argx); + Error_Pragma_Arg ("argument for pragma% must be identifier", Argx); end if; end Check_Arg_Is_Identifier; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 200417a5de0e..b01ee08d2b47 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4958,8 +4958,8 @@ package body Sem_Util is Eloc := Sloc (N); end if; - -- Copy message to Msgc, converting any ? in the message into - -- < instead, so that we have an error in GNATprove mode. + -- Copy message to Msgc, converting any ? in the message into < + -- instead, so that we have an error in GNATprove mode. Msgl := Msg'Length; @@ -4976,12 +4976,13 @@ package body Sem_Util is if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then Wmsg := True; - -- In Ada 83, all messages are warnings. In the private part and - -- the body of an instance, constraint_checks are only warnings. - -- We also make this a warning if the Warn parameter is set. + -- In Ada 83, all messages are warnings. In the private part and the + -- body of an instance, constraint_checks are only warnings. We also + -- make this a warning if the Warn parameter is set. elsif Warn or else (Ada_Version = Ada_83 and then Comes_From_Source (N)) + or else In_Instance_Not_Visible then Msgl := Msgl + 1; Msgc (Msgl) := '<'; @@ -4989,18 +4990,11 @@ package body Sem_Util is Msgc (Msgl) := '<'; Wmsg := True; - elsif In_Instance_Not_Visible then - Msgl := Msgl + 1; - Msgc (Msgl) := '<'; - Msgl := Msgl + 1; - Msgc (Msgl) := '<'; - Wmsg := True; - - -- Otherwise we have a real error message (Ada 95 static case) - -- and we make this an unconditional message. Note that in the - -- warning case we do not make the message unconditional, it seems - -- quite reasonable to delete messages like this (about exceptions - -- that will be raised) in dead code. + -- Otherwise we have a real error message (Ada 95 static case) and we + -- make this an unconditional message. Note that in the warning case + -- we do not make the message unconditional, it seems reasonable to + -- delete messages like this (about exceptions that will be raised) + -- in dead code. else Wmsg := False; @@ -19118,14 +19112,7 @@ package body Sem_Util is end if; end if; - elsif Nkind (Obj) = N_Selected_Component then - if Is_Access_Type (Etype (Prefix (Obj))) then - return Type_Access_Level (Etype (Prefix (Obj))); - else - return Object_Access_Level (Prefix (Obj)); - end if; - - elsif Nkind (Obj) = N_Indexed_Component then + elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then if Is_Access_Type (Etype (Prefix (Obj))) then return Type_Access_Level (Etype (Prefix (Obj))); else diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb index 562ee0e8412e..e5a6c87c2a59 100644 --- a/gcc/ada/uname.adb +++ b/gcc/ada/uname.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- -- @@ -300,12 +300,8 @@ package body Uname is when N_Compilation_Unit => Add_Node_Name (Unit (Node)); - when N_Package_Body_Stub => - Add_Node_Name (Get_Parent (Node)); - Add_Char ('.'); - Add_Node_Name (Defining_Identifier (Node)); - - when N_Protected_Body_Stub + when N_Package_Body_Stub + | N_Protected_Body_Stub | N_Task_Body_Stub => Add_Node_Name (Get_Parent (Node)); -- 2.43.5