From: Bob Duff <duff@adacore.com>
Date: Mon, 16 Mar 2020 19:22:25 +0000 (-0400)
Subject: [Ada] Put_Image attribute
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d84eb7c511b163473c272f846905631fc4a66a52;p=gcc.git

[Ada] Put_Image attribute

2020-06-11  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_put_image.adb (Build_Elementary_Put_Image_Call): If the
	underlying type is real, call Put_Image_Unknown.
	(Build_Unknown_Put_Image_Call): Pass the type name to
	Put_Image_Unknown.
	* libgnat/s-putima.ads, libgnat/s-putima.adb
	(Put_Image_Unknown): Add Type_Name parameter.  Remove
	overly-detailed documentation of what it does; better to leave
	it open.
---

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 3a6cbc1f667..db7c65bf7fb 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -27,6 +27,7 @@ with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Exp_Tss;  use Exp_Tss;
+with Exp_Util;
 with Lib;      use Lib;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -340,26 +341,34 @@ 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;
+
          declare
             Image : constant Node_Id :=
               Make_Attribute_Reference (Loc,
                 Prefix => New_Occurrence_Of (U_Type, Loc),
                 Attribute_Name => Name_Wide_Wide_Image,
                 Expressions => New_List (Relocate_Node (Item)));
-         begin
-            return
+            Put_Call : constant Node_Id :=
               Make_Procedure_Call_Statement (Loc,
                 Name =>
                   New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc),
                 Parameter_Associations => New_List
                   (Relocate_Node (Sink), Image));
+         begin
+            return Put_Call;
          end;
       end if;
 
       --  Unchecked-convert parameter to the required type (i.e. the type of
       --  the corresponding parameter), and call the appropriate routine.
       --  We could use a normal type conversion for scalars, but the
-      --  "unchecked" is needed for access types.
+      --  "unchecked" is needed for access and private types.
 
       declare
          Libent : constant Entity_Id := RTE (Lib_RE);
@@ -800,7 +809,10 @@ package body Exp_Put_Image is
         Make_Procedure_Call_Statement (Loc,
           Name => New_Occurrence_Of (Libent, Loc),
           Parameter_Associations => New_List (
-            Relocate_Node (Sink)));
+            Relocate_Node (Sink),
+            Make_String_Literal (Loc,
+              Exp_Util.Fully_Qualified_Name_String (
+                Entity (Prefix (N)), Append_NUL => False))));
    end Build_Unknown_Put_Image_Call;
 
    ----------------------
diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
index cad693f4996..50597b2422a 100644
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -212,9 +212,11 @@ package body System.Put_Images is
       Put_7bit (S, ')');
    end Record_After;
 
-   procedure Put_Image_Unknown (S : in out Sink'Class) is
+   procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is
    begin
-      Put_UTF_8 (S, "{unknown image}");
+      Put_UTF_8 (S, "{");
+      Put_String (S, Type_Name);
+      Put_UTF_8 (S, " object}");
    end Put_Image_Unknown;
 
 end System.Put_Images;
diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
index 0cfe2171e8f..0bedd3dace4 100644
--- a/gcc/ada/libgnat/s-putima.ads
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -86,8 +86,8 @@ package System.Put_Images is
    procedure Record_Between (S : in out Sink'Class);
    procedure Record_After (S : in out Sink'Class);
 
-   procedure Put_Image_Unknown (S : in out Sink'Class);
+   procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String);
    --  For Put_Image of types that don't have the attribute, such as type
-   --  Sink. Prints a canned string.
+   --  Sink.
 
 end System.Put_Images;