From d84eb7c511b163473c272f846905631fc4a66a52 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 16 Mar 2020 15:22:25 -0400 Subject: [PATCH] [Ada] Put_Image attribute 2020-06-11 Bob Duff 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. --- gcc/ada/exp_put_image.adb | 20 ++++++++++++++++---- gcc/ada/libgnat/s-putima.adb | 6 ++++-- gcc/ada/libgnat/s-putima.ads | 4 ++-- 3 files changed, 22 insertions(+), 8 deletions(-) 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; -- 2.30.2