[gcc(refs/users/guojiufu/heads/guojiufu-branch)] [Ada] Put_Image attribute

[Jiu Fu Guo <guojiufu@gcc.gnu.org>]

https://gcc.gnu.org/g:c324c77eeda3203bc9280b7aeefc9aea13503792

commit c324c77eeda3203bc9280b7aeefc9aea13503792
Author: Bob Duff <duff@adacore.com>
Date:   Thu Mar 19 18:17:36 2020 -0400

    [Ada] Put_Image attribute
    
    2020-06-12  Bob Duff  <duff@adacore.com>
    
    gcc/ada/
    
            * debug.adb: Remove usage of -gnatd_z.
            * exp_attr.adb, exp_put_image.ads, exp_put_image.adb: Clean up
            the enable/disable code. If Put_Image is disabled for a type,
            systematically call the "unknown" version.  Improve comments.
            Consolidate workarounds.  Remove usage of -gnatd_z.

Diff:
---
 gcc/ada/debug.adb         |  5 +----
 gcc/ada/exp_attr.adb      | 15 ++++++++++++---
 gcc/ada/exp_put_image.adb | 38 ++++++++++++++++++--------------------
 gcc/ada/exp_put_image.ads |  5 +++--
 4 files changed, 34 insertions(+), 29 deletions(-)

diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 0c86d96dddd..1d614eb70c5 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -170,7 +170,7 @@ package body Debug is
    --  d_w
    --  d_x
    --  d_y
-   --  d_z  Enable Put_Image
+   --  d_z
 
    --  d_A  Stop generation of ALI file
    --  d_B
@@ -993,9 +993,6 @@ package body Debug is
    --       a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
    --       or Ada.Synchronous_Barriers.Wait_For_Release.
 
-   --  d_z  The Put_Image attribute is a work in progress, and is disabled by
-   --       default. This enables it.
-
    --  d_A  Do not generate ALI files by setting Opt.Disable_ALI_File.
 
    --  d_F  The compiler encodes the full path from an invocation construct to
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 356d3dbd069..fc7aefadf28 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5463,7 +5463,9 @@ package body Exp_Attr is
             return;
          end if;
 
-         --  If there is a TSS for Put_Image, just call it
+         --  If there is a TSS for Put_Image, just call it. This is true for
+         --  tagged types (if enabled) and if there is a user-specified
+         --  Put_Image.
 
          Pname := TSS (U_Type, TSS_Put_Image);
          if No (Pname) then
@@ -5478,10 +5480,17 @@ package body Exp_Attr is
          end if;
 
          if No (Pname) then
+            --  If Put_Image is disabled, call the "unknown" version
+
+            if not Enable_Put_Image (U_Type) then
+               Rewrite (N, Build_Unknown_Put_Image_Call (N));
+               Analyze (N);
+               return;
+
             --  For elementary types, we call the routine in System.Put_Images
             --  directly.
 
-            if Is_Elementary_Type (U_Type) then
+            elsif Is_Elementary_Type (U_Type) then
                Rewrite (N, Build_Elementary_Put_Image_Call (N));
                Analyze (N);
                return;
@@ -5535,7 +5544,7 @@ package body Exp_Attr is
                Analyze (N);
                return;
 
-            --  All other record type cases, including protected records
+            --  All other record type cases
 
             else
                pragma Assert (Is_Record_Type (U_Type));
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index db7c65bf7fb..c8119c73d42 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -24,7 +24,6 @@
 ------------------------------------------------------------------------------
 
 with Atree;    use Atree;
-with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util;
@@ -341,9 +340,6 @@ package body Exp_Put_Image is
          --
          --  Note that this is putting a leading space for reals.
 
-         --  ???Work around the fact that Put_Image doesn't work for private
-         --  types whose full type is real.
-
          if Is_Real_Type (U_Type) then
             return Build_Unknown_Put_Image_Call (N);
          end if;
@@ -620,9 +616,7 @@ package body Exp_Put_Image is
       procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
          Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
       begin
-         if Ekind (C) /= E_Void
-           and then Enable_Put_Image (Component_Typ)
-         then
+         if Ekind (C) /= E_Void then
             Append_To (Clist,
               Make_Attribute_Reference (Loc,
                 Prefix         => New_Occurrence_Of (Component_Typ, Loc),
@@ -819,12 +813,8 @@ package body Exp_Put_Image is
    -- Enable_Put_Image --
    ----------------------
 
-   function Enable_Put_Image (T : Entity_Id) return Boolean is
+   function Enable_Put_Image (Typ : Entity_Id) return Boolean is
    begin
-      if not Debug_Flag_Underscore_Z then -- ????True to disable for all types
-         return False;
-      end if;
-
       --  There's a bit of a chicken&egg problem. The compiler is likely to
       --  have trouble if we refer to the Put_Image of Sink itself, because
       --  Sink is part of the parameter profile:
@@ -840,12 +830,20 @@ package body Exp_Put_Image is
       --  scalar types are expanded inline. We certainly want to be able to use
       --  Integer'Put_Image, for example.
 
-      --  ???Work around a bug: Put_Image does not work for Remote_Types.
-      --  We check the containing package, rather than the type itself, because
-      --  we want to include types in the private part of a Remote_Types
-      --  package.
+      --  ???Temporarily disable to work around bugs:
+      --
+      --  Put_Image does not work for Remote_Types. We check the containing
+      --  package, rather than the type itself, because we want to include
+      --  types in the private part of a Remote_Types package.
+      --
+      --  Put_Image on tagged types triggers some bugs.
+      --
+      --  Put_Image doesn't work for private types whose full type is real.
 
-      if Is_Remote_Types (Scope (T)) then
+      if Is_Remote_Types (Scope (Typ))
+        or else Is_Tagged_Type (Typ)
+        or else Is_Real_Type (Typ)
+      then
          return False;
       end if;
 
@@ -856,17 +854,17 @@ package body Exp_Put_Image is
       --  predefined types.
 
       declare
-         Parent_Scope : constant Entity_Id := Scope (Scope (T));
+         Parent_Scope : constant Entity_Id := Scope (Scope (Typ));
       begin
          if Present (Parent_Scope)
            and then Is_RTU (Parent_Scope, Ada_Strings)
-           and then Chars (Scope (T)) = Name_Find ("text_output")
+           and then Chars (Scope (Typ)) = Name_Find ("text_output")
          then
             return False;
          end if;
       end;
 
-      return Is_Scalar_Type (T) or else not In_Predefined_Unit (T);
+      return Is_Scalar_Type (Typ) or else not In_Predefined_Unit (Typ);
    end Enable_Put_Image;
 
    ---------------------------------
diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
index b245b0502dd..82c1c59a782 100644
--- a/gcc/ada/exp_put_image.ads
+++ b/gcc/ada/exp_put_image.ads
@@ -38,8 +38,9 @@ package Exp_Put_Image is
    --  are calls to T'Put_Image in different units, there will be duplicates;
    --  each unit will get a copy of the T'Put_Image procedure.
 
-   function Enable_Put_Image (T : Entity_Id) return Boolean;
-   --  True if Put_Image should be enabled for type T
+   function Enable_Put_Image (Typ : Entity_Id) return Boolean;
+   --  True if the predefined Put_Image should be enabled for type T. Put_Image
+   --  is always enabled if there is a user-specified one.
 
    function Build_Put_Image_Profile
      (Loc : Source_Ptr; Typ : Entity_Id) return List_Id;