From 643827e99051c3ce6077d8bb332290741dc90571 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Wed, 6 Sep 2017 12:01:13 +0000 Subject: [PATCH] exp_util.adb (Side_Effect_Free): For CodePeer (only) treat uses of 'Image and related attributes as having side... 2017-09-06 Steve Baird * exp_util.adb (Side_Effect_Free): For CodePeer (only) treat uses of 'Image and related attributes as having side effects in order to avoid replicating such uses. * pprint.ads (Expression_Image) Add new generic formal flag Hide_Temp_Derefs. The flag defaults to False; CodePeer will (eventually) override the default. * pprint.adb (Expression_Image) If the new flag is set, then suppress the ".all" suffix when displaying a dereference whose prefix is a use of a value-capturing compiler temp of the sort generated by Expr_Util.Remove_Side_Effects . * exp_attr.adb, g-catiio.adb, inline.adb, sem_attr.adb, sem_ch13.adb, sem_ch7.adb, sem_dim.adb, sem_util.adb, sem_util.ads, sem_warn.adb: Minor reformatting. * inline.adb: Minor wording change. From-SVN: r251784 --- gcc/ada/ChangeLog | 17 +++++++++++ gcc/ada/exp_attr.adb | 9 +++--- gcc/ada/exp_util.adb | 51 +++++++++++++++++++++++++++---- gcc/ada/g-catiio.adb | 48 +++++++++++++++-------------- gcc/ada/inline.adb | 15 ++++----- gcc/ada/pprint.adb | 72 +++++++++++++++++++++++++++++++++++--------- gcc/ada/pprint.ads | 7 ++++- gcc/ada/sem_attr.adb | 4 +-- gcc/ada/sem_ch13.adb | 2 ++ gcc/ada/sem_ch7.adb | 1 - gcc/ada/sem_dim.adb | 1 - gcc/ada/sem_util.adb | 7 +++-- gcc/ada/sem_util.ads | 2 +- gcc/ada/sem_warn.adb | 8 ++--- 14 files changed, 176 insertions(+), 68 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd11670e146..b7a86799165 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2017-09-06 Steve Baird + + * exp_util.adb (Side_Effect_Free): For CodePeer (only) treat + uses of 'Image and related attributes as having side effects in + order to avoid replicating such uses. + * pprint.ads (Expression_Image) Add new generic formal flag + Hide_Temp_Derefs. The flag defaults to False; CodePeer will + (eventually) override the default. + * pprint.adb (Expression_Image) If the new flag is set, then + suppress the ".all" suffix when displaying a dereference whose + prefix is a use of a value-capturing compiler temp of the sort + generated by Expr_Util.Remove_Side_Effects . + * exp_attr.adb, g-catiio.adb, inline.adb, sem_attr.adb, sem_ch13.adb, + sem_ch7.adb, sem_dim.adb, sem_util.adb, sem_util.ads, sem_warn.adb: + Minor reformatting. + * inline.adb: Minor wording change. + 2017-09-06 Eric Botcazou * sem_ch7.adb: Update comment. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 60a975fe049..ce115b98327 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3613,6 +3613,7 @@ package body Exp_Attr is -- Image attribute is handled in separate unit Exp_Imgv when Attribute_Image => + -- Leave attribute unexpanded in CodePeer mode: the gnat2scil -- back-end knows how to handle this attribute directly. @@ -3620,7 +3621,7 @@ package body Exp_Attr is return; end if; - Exp_Imgv.Expand_Image_Attribute (N); + Expand_Image_Attribute (N); --------- -- Img -- @@ -3629,7 +3630,7 @@ package body Exp_Attr is -- X'Img is expanded to typ'Image (X), where typ is the type of X when Attribute_Img => - Exp_Imgv.Expand_Image_Attribute (N); + Expand_Image_Attribute (N); ----------- -- Input -- @@ -6886,13 +6887,13 @@ package body Exp_Attr is elsif Is_Record_Type (Ftyp) and then Present (Declaration_Node (Ftyp)) and then Nkind (Type_Definition (Declaration_Node (Ftyp))) = - N_Record_Definition + N_Record_Definition then Rewrite (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc), - Parameter_Associations => New_List (Pref))); + Parameter_Associations => New_List (Pref))); -- Other record types or types with discriminants diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index baffe28ad69..10d9b1d1c82 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -12901,12 +12901,51 @@ package body Exp_Util is -- Is this right? what about x'first where x is a variable??? when N_Attribute_Reference => - return - Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) - and then Attribute_Name (N) /= Name_Input - and then (Is_Entity_Name (Prefix (N)) - or else Side_Effect_Free - (Prefix (N), Name_Req, Variable_Ref)); + Attribute_Reference : declare + + function Side_Effect_Free_Attribute + (Attribute_Name : Name_Id) return Boolean; + -- Returns True if evaluation of the given attribute is + -- considered side-effect free (independent of prefix and + -- arguments). + + -------------------------------- + -- Side_Effect_Free_Attribute -- + -------------------------------- + + function Side_Effect_Free_Attribute + (Attribute_Name : Name_Id) return Boolean + is + begin + case Attribute_Name is + when Name_Input => + return False; + + when Name_Image + | Name_Img + | Name_Wide_Image + | Name_Wide_Wide_Image + => + -- CodePeer doesn't want to see replicated copies of + -- 'Image calls. + + return not CodePeer_Mode; + + when others => + return True; + end case; + end Side_Effect_Free_Attribute; + + -- Start of processing for Attribute_Reference + + begin + return + Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref) + and then Side_Effect_Free_Attribute (Attribute_Name (N)) + and then (Is_Entity_Name (Prefix (N)) + or else Side_Effect_Free + (Prefix (N), Name_Req, Variable_Ref)); + end Attribute_Reference; -- A binary operator is side effect free if and both operands are -- side effect free. For this purpose binary operators include diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb index 17ce098ab9e..6677a9b1b84 100644 --- a/gcc/ada/g-catiio.adb +++ b/gcc/ada/g-catiio.adb @@ -574,7 +574,7 @@ package body GNAT.Calendar.Time_IO is Time : out Ada.Calendar.Time; Success : out Boolean) is - Index : Positive := Date'First; + Index : Positive := Date'First; -- The current character scan index. After a call to Advance, Index -- points to the next character. @@ -582,7 +582,7 @@ package body GNAT.Calendar.Time_IO is -- An exception used to signal that the scan pointer has reached the -- end of the source string. - Wrong_Syntax : exception; + Wrong_Syntax : exception; -- An exception used to signal that the scan pointer has reached an -- unexpected character in the source string. @@ -815,20 +815,21 @@ package body GNAT.Calendar.Time_IO is Date_Separator : constant Character := '-'; Hour_Separator : constant Character := ':'; - Day : Day_Number; - Month : Month_Number; - Year : Year_Number; - Hour : Hour_Number := 0; - Minute : Minute_Number := 0; - Second : Second_Number := 0; - Subsec : Second_Duration := 0.0; - - Local_Hour : Hour_Number := 0; - Local_Minute : Minute_Number := 0; - Local_Sign : Character := ' '; - Local_Disp : Duration; - - Sep_Required : Boolean := False; + + Day : Day_Number; + Month : Month_Number; + Year : Year_Number; + Hour : Hour_Number := 0; + Minute : Minute_Number := 0; + Second : Second_Number := 0; + Subsec : Second_Duration := 0.0; + + Local_Hour : Hour_Number := 0; + Local_Minute : Minute_Number := 0; + Local_Sign : Character := ' '; + Local_Disp : Duration; + + Sep_Required : Boolean := False; -- True if a separator is seen (and therefore required after it!) begin @@ -929,14 +930,16 @@ package body GNAT.Calendar.Time_IO is -- Compute time with positive local displacement elsif Local_Sign = '+' then - Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) - - Local_Disp; + Time := + Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) - + Local_Disp; -- Compute time with negative local displacement elsif Local_Sign = '-' then - Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) - + Local_Disp; + Time := + Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) + + Local_Disp; end if; -- Notify that the input string was successfully parsed @@ -944,8 +947,9 @@ package body GNAT.Calendar.Time_IO is Success := True; exception - when End_Of_Source_Reached | - Wrong_Syntax => + when End_Of_Source_Reached + | Wrong_Syntax + => Success := False; end Parse_ISO_8861_UTC; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 15efcef5519..70d1f84866a 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1607,7 +1607,6 @@ package body Inline is -------------------------- procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is - procedure Generate_Subprogram_Body (N : Node_Id; Body_To_Inline : out Node_Id); @@ -1683,11 +1682,10 @@ package body Inline is Save_Env (Scope (Current_Scope), Scope (Current_Scope)); end if; - -- We need to capture references to the formals in order - -- to substitute the actuals at the point of inlining, i.e. - -- instantiation. To treat the formals as globals to the body to - -- inline, we nest it within a dummy parameterless subprogram, - -- declared within the real one. + -- Capture references to formals in order to substitute the actuals + -- at the point of inlining or instantiation. To treat the formals + -- as globals to the body to inline, nest the body within a dummy + -- parameterless subprogram, declared within the real one. Generate_Subprogram_Body (N, Original_Body); Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); @@ -1730,8 +1728,7 @@ package body Inline is -- Can_Split_Unconstrained_Function -- -------------------------------------- - function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean - is + function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is Ret_Node : constant Node_Id := First (Statements (Handled_Statement_Sequence (N))); D : Node_Id; @@ -2925,7 +2922,7 @@ package body Inline is -- The semantic analyzer checked that frontend-inlined functions -- returning unconstrained types have no declarations and have -- a single extended return statement. As part of its processing - -- the function was split in two subprograms: a procedure P' and + -- the function was split into two subprograms: a procedure P' and -- a function F' that has a block with a call to procedure P' (see -- Split_Unconstrained_Function). diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index fcfccd316f8..912af392ec2 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-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- -- @@ -325,22 +325,66 @@ package body Pprint is end if; when N_Explicit_Dereference => + Explicit_Dereference : declare + function Deref_Suffix return String; + -- Usually returns ".all", but will return "" if + -- Hide_Temp_Derefs is true and the prefix is a use of a + -- not-from-source object declared as + -- X : constant Some_Access_Type := Some_Expr'Reference; + -- (as is sometimes done in Exp_Util.Remove_Side_Effects). - -- Return "Foo" instead of "Parameter_Block.Foo.all" + ------------------ + -- Deref_Suffix -- + ------------------ - if Hide_Parameter_Blocks - and then Nkind (Prefix (Expr)) = N_Selected_Component - and then Present (Etype (Prefix (Expr))) - and then Is_Access_Type (Etype (Prefix (Expr))) - and then Is_Param_Block_Component_Type (Etype (Prefix (Expr))) - then - return Expr_Name (Selector_Name (Prefix (Expr))); + function Deref_Suffix return String is + Decl : Node_Id; - elsif Take_Prefix then - return Expr_Name (Prefix (Expr)) & ".all"; - else - return ".all"; - end if; + begin + if Hide_Temp_Derefs + and then Nkind (Prefix (Expr)) = N_Identifier + and then Nkind (Entity (Prefix (Expr))) = + N_Defining_Identifier + then + Decl := Parent (Entity (Prefix (Expr))); + + if Present (Decl) + and then Nkind (Decl) = N_Object_Declaration + and then not Comes_From_Source (Decl) + and then Constant_Present (Decl) + and then Present (Sinfo.Expression (Decl)) + and then Nkind (Sinfo.Expression (Decl)) = + N_Reference + then + return ""; + end if; + end if; + + -- The default case + + return ".all"; + end Deref_Suffix; + + -- Start of processing for Explicit_Dereference + + begin + if Hide_Parameter_Blocks + and then Nkind (Prefix (Expr)) = N_Selected_Component + and then Present (Etype (Prefix (Expr))) + and then Is_Access_Type (Etype (Prefix (Expr))) + and then Is_Param_Block_Component_Type + (Etype (Prefix (Expr))) + then + -- Return "Foo" instead of "Parameter_Block.Foo.all" + + return Expr_Name (Selector_Name (Prefix (Expr))); + + elsif Take_Prefix then + return Expr_Name (Prefix (Expr)) & Deref_Suffix; + else + return Deref_Suffix; + end if; + end Explicit_Dereference; when N_Expanded_Name | N_Selected_Component diff --git a/gcc/ada/pprint.ads b/gcc/ada/pprint.ads index 23160a04801..932d7bab9c6 100644 --- a/gcc/ada/pprint.ads +++ b/gcc/ada/pprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-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- -- @@ -50,6 +50,11 @@ package Pprint is -- If true, then "Parameter_Block.Field_Name.all" is -- instead displayed as "Field_Name". + Hide_Temp_Derefs : Boolean := False; + -- If true, then "Foo.all" is instead displayed as "Foo" + -- in the case where Foo is a compiler-generated constant + -- initialized to Some_Captured_Value'Reference. + function Expression_Image (Expr : Node_Id; Default : String) return String; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 748df60736c..991f2b5aff9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -264,7 +264,7 @@ package body Sem_Attr is procedure Analyze_Image_Attribute (Str_Typ : Entity_Id); -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and -- 'Wide_Wide_Image. The routine checks that the prefix is valid and - -- sets the entity type to the one specified by Str_Typ (e.g. + -- sets the type of the attribute to the one specified by Str_Typ (e.g. -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image). procedure Bad_Attribute_For_Predicate; @@ -1475,7 +1475,7 @@ package body Sem_Attr is if Ada_Version > Ada_2005 then Error_Attr_P ("prefix of % attribute must be a scalar type or a scalar " - & "object name"); + & "object name"); else Error_Attr_P ("prefix of % attribute must be a scalar type"); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 441dad584cc..21abd063b8a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12707,8 +12707,10 @@ package body Sem_Ch13 is declare A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); Expr : constant Node_Id := Expression (ASN); + begin case A_Id is + -- For now we only deal with aspects that do not generate -- subprograms, or that may mention current instances of -- types. These will require special handling (???TBD). diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 3da7987fa57..b0f6bd90f1a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -248,7 +248,6 @@ package body Sem_Ch7 is -------------------------- procedure Hide_Public_Entities (Decls : List_Id) is - function Has_Referencer (Decls : List_Id; Top_Level : Boolean := False) return Boolean; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index d5f724d5e63..2b4b84319f8 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1200,7 +1200,6 @@ package body Sem_Dim is end if; when N_Unary_Op => - Analyze_Dimension_Unary_Op (N); when others => diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0440d89edd2..d20cafbe63b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14130,7 +14130,7 @@ package body Sem_Util is function Is_Object_Image (Prefix : Node_Id) return Boolean is begin - -- When the type of the prefix is not scalar then the prefix is not + -- When the type of the prefix is not scalar, then the prefix is not -- valid in any scenario. if not Is_Scalar_Type (Etype (Prefix)) then @@ -14228,9 +14228,9 @@ package body Sem_Util is return not Nkind_In (Original_Node (N), N_Case_Expression, N_If_Expression); - when N_Type_Conversion => - -- A view conversion of a tagged object is an object reference + -- A view conversion of a tagged object is an object reference + when N_Type_Conversion => return Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))) and then Is_Object_Reference (Expression (N)); @@ -22569,6 +22569,7 @@ package body Sem_Util is if Ekind (Scop) = E_Protected_Type then return True; end if; + Scop := Scope (Scop); end loop; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 7d3bd0920d7..a80d3fc21d8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1672,7 +1672,7 @@ package Sem_Util is -- null component list. function Is_Object_Image (Prefix : Node_Id) return Boolean; - -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute + -- Returns True if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute -- is applied to a given object or named value prefix (see below). -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index ecc47e4f24c..9e1b2c3f3c2 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1388,10 +1388,10 @@ package body Sem_Warn is -- an expression with actions. UR := Original_Node (UR); - while Nkind (UR) = N_Type_Conversion - or else Nkind (UR) = N_Qualified_Expression - or else Nkind (UR) = N_Expression_With_Actions - or else Nkind (UR) = N_Attribute_Reference + while Nkind_In (UR, N_Attribute_Reference, + N_Expression_With_Actions, + N_Qualified_Expression, + N_Type_Conversion) loop if Nkind (UR) = N_Attribute_Reference then UR := Prefix (UR); -- 2.30.2