From acc20d256c51f394904b904e8a8ceea3a44855fc Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 31 Mar 2020 18:59:11 -0400 Subject: [PATCH] [Ada] T'Image calls T'Put_Image 2020-06-15 Bob Duff 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. --- gcc/ada/exp_imgv.adb | 48 ++++++++++++++++++++---- gcc/ada/exp_put_image.adb | 73 ++++++++++++++++++++++++++++++++++++ gcc/ada/exp_put_image.ads | 9 +++++ gcc/ada/libgnat/a-stoufo.adb | 20 +++++----- gcc/ada/libgnat/a-stoufo.ads | 10 ++--- gcc/ada/rtsfind.adb | 4 +- gcc/ada/rtsfind.ads | 11 ++++++ gcc/ada/sem_attr.adb | 4 +- 8 files changed, 151 insertions(+), 28 deletions(-) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index bae292c7958..8cad1020a4f 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 0fa4304e194..d550a1d2cce 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 3ee8f8b42cc..00b3371474b 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 0cbcd565019..3b99cf7d03b 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 3636ae6c1f6..dd80dff3160 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 d190115083a..7e617b6a705 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 0200c1d0f51..f440147f669 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 10b332bea3b..a7d07841458 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 -- 2.30.2