[Ada] T'Image calls T'Put_Image

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

gcc/ada/

	* exp_put_image.ads, exp_put_image.adb
	(Image_Should_Call_Put_Image): New function to determine whether
	the call to Put_Image should be generated.
	(Build_Image_Call): New procedure to generate the call to
	Put_Image.
	* exp_imgv.adb (Expand_Image_Attribute): Use underlying types to
	bypass privacy (only in Ada 2020). If
	Image_Should_Call_Put_Image is True (which happens only in Ada
	2020), then call Build_Image_Call.
	* rtsfind.ads, rtsfind.adb: Add the necessary declarations in
	Ada.Strings.Text_Output.Buffers.
	* sem_attr.adb (Check_Image_Type): Enable the Ada 2020 case.
	* libgnat/a-stoufo.ads, libgnat/a-stoufo.adb: Use the less
	restrictive type that allows newline characters.

8 files changed, 151 insertions, 28 deletions

diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index bae292c..8cad102 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -27,6 +27,7 @@ with Atree;    use Atree;
 with Casing;   use Casing;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Exp_Put_Image;
 with Exp_Util; use Exp_Util;
 with Lib;      use Lib;
 with Namet;    use Namet;
@@ -477,7 +478,15 @@ package body Exp_Imgv is
       end if;
 
       Ptyp := Entity (Pref);
-      Rtyp := Root_Type (Ptyp);
+
+      --  Ada 2020 allows 'Image on private types, so we need to fetch the
+      --  underlying type.
+
+      if Ada_Version >= Ada_2020 then
+         Rtyp := Underlying_Type (Ptyp);
+      else
+         Rtyp := Root_Type (Ptyp);
+      end if;
 
       --  Enable speed-optimized expansion of user-defined enumeration types
       --  if we are compiling with optimizations enabled and enumeration type
@@ -524,7 +533,15 @@ package body Exp_Imgv is
 
       Enum_Case := False;
 
-      if Rtyp = Standard_Boolean then
+      --  If this is a case where Image should be transformed using Put_Image,
+      --  then do so. See Exp_Put_Image for details.
+
+      if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
+         Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
+         Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
+         return;
+
+      elsif Rtyp = Standard_Boolean then
          Imid := RE_Image_Boolean;
          Tent := Rtyp;
 
@@ -587,8 +604,10 @@ package body Exp_Imgv is
       --  Only other possibility is user-defined enumeration type
 
       else
+         pragma Assert (Is_Enumeration_Type (Rtyp));
+
          if Discard_Names (First_Subtype (Ptyp))
-           or else No (Lit_Strings (Root_Type (Ptyp)))
+           or else No (Lit_Strings (Rtyp))
          then
             --  When pragma Discard_Names applies to the first subtype, build
             --  (Pref'Pos (Expr))'Img.
@@ -634,11 +653,24 @@ package body Exp_Imgv is
       --  Build first argument for call
 
       if Enum_Case then
-         Arg_List := New_List (
-           Make_Attribute_Reference (Loc,
-             Attribute_Name => Name_Pos,
-             Prefix         => New_Occurrence_Of (Ptyp, Loc),
-             Expressions    => New_List (Expr)));
+         declare
+            T : Entity_Id;
+         begin
+            --  In Ada 2020 we need the underlying type here, because 'Image is
+            --  allowed on private types.
+
+            if Ada_Version >= Ada_2020 then
+               T := Rtyp;
+            else
+               T := Ptyp;
+            end if;
+
+            Arg_List := New_List (
+              Make_Attribute_Reference (Loc,
+                Attribute_Name => Name_Pos,
+                Prefix         => New_Occurrence_Of (T, Loc),
+                Expressions    => New_List (Expr)));
+         end;
 
       --  AI12-0020: Ada 2020 allows 'Image for all types, including private
       --  types. If the full type is not a fixed-point type, then it is enough
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 0fa4304..d550a1d 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -915,6 +915,79 @@ package body Exp_Put_Image is
       return Make_Defining_Identifier (Loc, Sname);
    end Make_Put_Image_Name;
 
+   function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is
+   begin
+      if Ada_Version < Ada_2020 then
+         return False;
+      end if;
+
+      --  In Ada 2020, T'Image calls T'Put_Image if there is an explicit
+      --  aspect_specification for Put_Image, or if U_Type'Image is illegal
+      --  in pre-2020 versions of Ada.
+
+      declare
+         U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
+      begin
+         if Present (TSS (U_Type, TSS_Put_Image)) then
+            return True;
+         end if;
+
+         return not Is_Scalar_Type (U_Type);
+      end;
+   end Image_Should_Call_Put_Image;
+
+   function Build_Image_Call (N : Node_Id) return Node_Id is
+      --  For T'Image (X) Generate an Expression_With_Actions node:
+      --
+      --     do
+      --        S : Buffer := New_Buffer;
+      --        U_Type'Put_Image (S, X);
+      --        Result : constant String := Get (S);
+      --        Destroy (S);
+      --     in Result end
+      --
+      --  where U_Type is the underlying type, as needed to bypass privacy.
+
+      Loc : constant Source_Ptr := Sloc (N);
+      U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
+      Sink_Entity : constant Entity_Id :=
+        Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
+      Sink_Decl : constant Node_Id :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Sink_Entity,
+          Object_Definition =>
+            New_Occurrence_Of (RTE (RE_Buffer), Loc),
+          Expression =>
+            Make_Function_Call (Loc,
+              Name => New_Occurrence_Of (RTE (RE_New_Buffer), Loc),
+              Parameter_Associations => Empty_List));
+      Put_Im : constant Node_Id :=
+        Make_Attribute_Reference (Loc,
+          Prefix         => New_Occurrence_Of (U_Type, Loc),
+          Attribute_Name => Name_Put_Image,
+          Expressions    => New_List (
+            New_Occurrence_Of (Sink_Entity, Loc),
+            New_Copy_Tree (First (Expressions (N)))));
+      Result_Entity : constant Entity_Id :=
+        Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R'));
+      Result_Decl : constant Node_Id :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Result_Entity,
+          Object_Definition =>
+            New_Occurrence_Of (Stand.Standard_String, Loc),
+          Expression =>
+            Make_Function_Call (Loc,
+              Name => New_Occurrence_Of (RTE (RE_Get), Loc),
+              Parameter_Associations => New_List (
+                New_Occurrence_Of (Sink_Entity, Loc))));
+      Image : constant Node_Id :=
+        Make_Expression_With_Actions (Loc,
+          Actions => New_List (Sink_Decl, Put_Im, Result_Decl),
+          Expression => New_Occurrence_Of (Result_Entity, Loc));
+   begin
+      return Image;
+   end Build_Image_Call;
+
    ------------------
    -- Preload_Sink --
    ------------------
diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
index 3ee8f8b..00b3371 100644
--- a/gcc/ada/exp_put_image.ads
+++ b/gcc/ada/exp_put_image.ads
@@ -85,6 +85,15 @@ package Exp_Put_Image is
    function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id;
    --  Build a call to Put_Image_Unknown
 
+   function Image_Should_Call_Put_Image (N : Node_Id) return Boolean;
+   --  True if T'Image should call T'Put_Image. N is the attribute_reference
+   --  T'Image.
+
+   function Build_Image_Call (N : Node_Id) return Node_Id;
+   --  N is a call to T'Image, and this translates it into the appropriate code
+   --  to call T'Put_Image into a buffer and then extract the string from the
+   --  buffer.
+
    procedure Preload_Sink (Compilation_Unit : Node_Id);
    --  Call RTE (RE_Sink) if necessary, to load the packages involved in
    --  Put_Image. We need to do this explicitly, fairly early during
diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb
index 0cbcd56..3b99cf7 100644
--- a/gcc/ada/libgnat/a-stoufo.adb
+++ b/gcc/ada/libgnat/a-stoufo.adb
@@ -38,7 +38,7 @@ package body Ada.Strings.Text_Output.Formatting is
 
    procedure Put
      (S : in out Sink'Class; T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "")
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "")
    is
       J : Positive := T'First;
       Used : array (1 .. 6) of Boolean := (others => False);
@@ -62,22 +62,22 @@ package body Ada.Strings.Text_Output.Formatting is
 
                when '1' =>
                   Used (1) := True;
-                  Put_UTF_8 (S, X1);
+                  Put_UTF_8_Lines (S, X1);
                when '2' =>
                   Used (2) := True;
-                  Put_UTF_8 (S, X2);
+                  Put_UTF_8_Lines (S, X2);
                when '3' =>
                   Used (3) := True;
-                  Put_UTF_8 (S, X3);
+                  Put_UTF_8_Lines (S, X3);
                when '4' =>
                   Used (4) := True;
-                  Put_UTF_8 (S, X4);
+                  Put_UTF_8_Lines (S, X4);
                when '5' =>
                   Used (5) := True;
-                  Put_UTF_8 (S, X5);
+                  Put_UTF_8_Lines (S, X5);
                when '6' =>
                   Used (6) := True;
-                  Put_UTF_8 (S, X6);
+                  Put_UTF_8_Lines (S, X6);
 
                when others =>
                   raise Program_Error;
@@ -113,21 +113,21 @@ package body Ada.Strings.Text_Output.Formatting is
 
    procedure Put
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "") is
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") is
    begin
       Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6);
    end Put;
 
    procedure Err
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "") is
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") is
    begin
       Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6);
    end Err;
 
    function Format
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "")
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "")
      return UTF_8_Lines
    is
       Buf : Buffer := New_Buffer;
diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads
index 3636ae6..dd80dff 100644
--- a/gcc/ada/libgnat/a-stoufo.ads
+++ b/gcc/ada/libgnat/a-stoufo.ads
@@ -43,7 +43,7 @@ package Ada.Strings.Text_Output.Formatting is
    type Template is new UTF_8;
    procedure Put
      (S : in out Sink'Class; T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "");
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "");
    --  Prints the template as is, except for the following escape sequences:
    --    "\n" is end of line.
    --    "\i" indents by the default amount, and "\o" outdents.
@@ -51,23 +51,23 @@ package Ada.Strings.Text_Output.Formatting is
    --    "\1" is replaced with X1, and similarly for 2, 3, ....
    --    "\\" is "\".
 
-   --  Note that the template is not type UTF_8, to avoid this sort of thing:
+   --  Note that the template is not type String, to avoid this sort of thing:
    --
    --      https://xkcd.com/327/
 
    procedure Put
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "");
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "");
    --  Sends to standard output
 
    procedure Err
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "");
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "");
    --  Sends to standard error
 
    function Format
      (T : Template;
-      X1, X2, X3, X4, X5, X6 : UTF_8 := "")
+      X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "")
      return UTF_8_Lines;
    --  Returns a UTF-8-encoded String
 
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index d190115..7e617b6 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -570,10 +570,10 @@ package body Rtsfind is
      range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
 
    subtype Ada_Strings_Descendant is Ada_Descendant
-     range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Utils;
+     range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Buffers;
 
    subtype Ada_Strings_Text_Output_Descendant is Ada_Strings_Descendant
-     range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Utils;
+     range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Buffers;
 
    subtype Ada_Text_IO_Descendant is Ada_Descendant
      range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 0200c1d..f440147 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -130,6 +130,7 @@ package Rtsfind is
       --  Children of Ada.Strings.Text_Output
 
       Ada_Strings_Text_Output_Utils,
+      Ada_Strings_Text_Output_Buffers,
 
       --  Children of Ada.Text_IO (for Check_Text_IO_Special_Unit)
 
@@ -492,6 +493,11 @@ package Rtsfind is
      RE_Put_UTF_8,                       -- Ada.Strings.Text_Output.Utils
      RE_Put_Wide_Wide_String,            -- Ada.Strings.Text_Output.Utils
 
+     RE_Buffer,                          -- Ada.Strings.Text_Output.Buffers
+     RE_New_Buffer,                      -- Ada.Strings.Text_Output.Buffers
+     RE_Destroy,                         -- Ada.Strings.Text_Output.Buffers
+     RE_Get,                             -- Ada.Strings.Text_Output.Buffers
+
      RE_Wait_For_Release,                -- Ada.Synchronous_Barriers
 
      RE_Suspend_Until_True,              -- Ada.Synchronous_Task_Control
@@ -1771,6 +1777,11 @@ package Rtsfind is
      RE_Put_UTF_8                        => Ada_Strings_Text_Output_Utils,
      RE_Put_Wide_Wide_String             => Ada_Strings_Text_Output_Utils,
 
+     RE_Buffer                           => Ada_Strings_Text_Output_Buffers,
+     RE_New_Buffer                       => Ada_Strings_Text_Output_Buffers,
+     RE_Destroy                          => Ada_Strings_Text_Output_Buffers,
+     RE_Get                              => Ada_Strings_Text_Output_Buffers,
+
      RE_Wait_For_Release                 => Ada_Synchronous_Barriers,
 
      RE_Suspend_Until_True               => Ada_Synchronous_Task_Control,
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 10b332b..a7d0784 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1429,9 +1429,7 @@ package body Sem_Attr is
 
          procedure Check_Image_Type (Image_Type : Entity_Id) is
          begin
-            if False -- ???Disable 2020 feature until expander work is done
-              and then Ada_Version >= Ada_2020
-            then
+            if Ada_Version >= Ada_2020 then
                null; -- all types are OK
             elsif not Is_Scalar_Type (Image_Type) then
                if Ada_Version >= Ada_2012 then