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;
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
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;
-- 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.
-- 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
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 --
------------------
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
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);
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;
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;
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.
-- "\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
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;
-- 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)
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
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,
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
projects / gcc.git / commitdiff