exp_util.adb (Side_Effect_Free): For CodePeer (only) treat uses of 'Image and related attributes as having side...

2017-09-06  Steve Baird  <baird@adacore.com>

	* 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

14 files changed, 176 insertions, 68 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fd11670..b7a8679 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2017-09-06  Steve Baird  <baird@adacore.com>
+
+	* 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  <ebotcazou@adacore.com>
 
 	* sem_ch7.adb: Update comment.
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 60a975f..ce115b9 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 baffe28..10d9b1d 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 17ce098..6677a9b 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 15efcef..70d1f848 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 fcfccd3..912af39 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 23160a0..932d7ba 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 748df60..991f2b5 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 441dad5..21abd06 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 3da7987..b0f6bd9 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 d5f724d..2b4b843 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 0440d89..d20cafb 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 7d3bd09..a80d3fc 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 ecc47e4..9e1b2c3 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);