------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ P U T _ I M A G E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Tss; use Exp_Tss;
with Exp_Util;
with Debug; use Debug;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Put_Image is
Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
-- ???Set True to enable Put_Image for at least some tagged types
-----------------------
-- Local Subprograms --
-----------------------
procedure Build_Put_Image_Proc
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Stms : List_Id);
-- Build an array or record Put_Image procedure. Stms is the list of
-- statements for the body and Pnam is the name of the constructed
-- procedure. (The declaration list is always null.)
function Make_Put_Image_Name
(Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id;
-- Return the entity that identifies the Put_Image subprogram for Typ. This
-- procedure deals with the difference between tagged types (where a single
-- subprogram associated with the type is generated) and all other cases
-- (where a subprogram is generated at the point of the attribute
-- reference). The Loc parameter is used as the Sloc of the created entity.
function Put_Image_Base_Type (E : Entity_Id) return Entity_Id;
-- Returns the base type, except for an array type whose whose first
-- subtype is constrained, in which case it returns the first subtype.
-------------------------------------
-- Build_Array_Put_Image_Procedure --
-------------------------------------
procedure Build_Array_Put_Image_Procedure
(Nod : Node_Id;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
function Wrap_In_Loop
(Stms : List_Id;
Dim : Pos;
Index_Subtype : Entity_Id;
Between_Proc : RE_Id) return Node_Id;
-- Wrap Stms in a loop and if statement of the form:
--
-- if V'First (Dim) <= V'Last (Dim) then -- nonempty range?
-- declare
-- LDim : Index_Type_For_Dim := V'First (Dim);
-- begin
-- loop
-- Stms;
-- exit when LDim = V'Last (Dim);
-- Between_Proc (S);
-- LDim := Index_Type_For_Dim'Succ (LDim);
-- end loop;
-- end;
-- end if;
--
-- This is called once per dimension, from inner to outer.
function Wrap_In_Loop
(Stms : List_Id;
Dim : Pos;
Index_Subtype : Entity_Id;
Between_Proc : RE_Id) return Node_Id
is
Index : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars => New_External_Name ('L', Dim));
Decl : constant Node_Id :=
Make_Object_Declaration (Loc,
Defining_Identifier => Index,
Object_Definition =>
New_Occurrence_Of (Index_Subtype, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim))));
Loop_Stm : constant Node_Id :=
Make_Implicit_Loop_Statement (Nod, Statements => Stms);
Exit_Stm : constant Node_Id :=
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Index, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Identifier (Loc, Name_V),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)))));
Increment : constant Node_Id :=
Make_Increment (Loc, Index, Index_Subtype);
Between : constant Node_Id :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (Between_Proc), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S)));
Block : constant Node_Id :=
Make_Block_Statement (Loc,
Declarations => New_List (Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Loop_Stm)));
begin
Append_To (Stms, Exit_Stm);
Append_To (Stms, Between);
Append_To (Stms, Increment);
-- Note that we're appending to the Stms list passed in
return
Make_If_Statement (Loc,
Condition =>
Make_Op_Le (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)))),
Then_Statements => New_List (Block));
end Wrap_In_Loop;
Ndim : constant Pos := Number_Dimensions (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
Stm : Node_Id;
Exl : constant List_Id := New_List;
PI_Entity : Entity_Id;
Indices : array (1 .. Ndim) of Entity_Id;
-- Start of processing for Build_Array_Put_Image_Procedure
begin
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Put_Image));
-- Get the Indices
declare
Index_Subtype : Node_Id := First_Index (Typ);
begin
for Dim in 1 .. Ndim loop
Indices (Dim) := Etype (Index_Subtype);
Next_Index (Index_Subtype);
end loop;
pragma Assert (No (Index_Subtype));
end;
-- Build the inner attribute call
for Dim in 1 .. Ndim loop
Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim)));
end loop;
Stm :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc),
Attribute_Name => Name_Put_Image,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Expressions => Exl)));
-- The corresponding attribute for the component type of the array might
-- be user-defined, and frozen after the array type. In that case,
-- freeze the Put_Image attribute of the component type, whose
-- declaration could not generate any additional freezing actions in any
-- case.
PI_Entity := TSS (Base_Type (Ctyp), TSS_Put_Image);
if Present (PI_Entity) and then not Is_Frozen (PI_Entity) then
Set_Is_Frozen (PI_Entity);
end if;
-- Loop through the dimensions, innermost first, generating a loop for
-- each dimension.
declare
Stms : List_Id := New_List (Stm);
begin
for Dim in reverse 1 .. Ndim loop
declare
New_Stms : constant List_Id := New_List;
Between_Proc : RE_Id;
begin
-- For a one-dimensional array of elementary type, use
-- RE_Simple_Array_Between. The same applies to the last
-- dimension of a multidimensional array.
if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
Between_Proc := RE_Simple_Array_Between;
else
Between_Proc := RE_Array_Between;
end if;
Append_To (New_Stms,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S))));
Append_To
(New_Stms,
Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
Append_To (New_Stms,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Array_After), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S))));
Stms := New_Stms;
end;
end loop;
Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
end;
end Build_Array_Put_Image_Procedure;
-------------------------------------
-- Build_Elementary_Put_Image_Call --
-------------------------------------
function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
P_Type : constant Entity_Id := Entity (Prefix (N));
U_Type : constant Entity_Id := Underlying_Type (P_Type);
FST : constant Entity_Id := First_Subtype (U_Type);
Sink : constant Node_Id := First (Expressions (N));
Item : constant Node_Id := Next (Sink);
P_Size : constant Uint := Esize (FST);
Lib_RE : RE_Id;
begin
if Is_Signed_Integer_Type (U_Type) then
if P_Size <= Standard_Integer_Size then
Lib_RE := RE_Put_Image_Integer;
elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_Put_Image_Long_Long_Integer;
else
pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
Lib_RE := RE_Put_Image_Long_Long_Long_Integer;
end if;
elsif Is_Modular_Integer_Type (U_Type) then
if P_Size <= Standard_Integer_Size then -- Yes, Integer
Lib_RE := RE_Put_Image_Unsigned;
elsif P_Size <= Standard_Long_Long_Integer_Size then
Lib_RE := RE_Put_Image_Long_Long_Unsigned;
else
pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned;
end if;
elsif Is_Access_Type (U_Type) then
if Is_Access_Protected_Subprogram_Type (Base_Type (U_Type)) then
Lib_RE := RE_Put_Image_Access_Prot_Subp;
elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then
Lib_RE := RE_Put_Image_Access_Subp;
elsif P_Size = System_Address_Size then
Lib_RE := RE_Put_Image_Thin_Pointer;
else
pragma Assert (P_Size = 2 * System_Address_Size);
Lib_RE := RE_Put_Image_Fat_Pointer;
end if;
else
pragma Assert
(Is_Enumeration_Type (U_Type) or else Is_Real_Type (U_Type));
-- For other elementary types, generate:
--
-- Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item));
--
-- It would be more elegant to do it the other way around (define
-- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier
-- to implement, because we already have support for
-- 'Wide_Wide_Image. Furthermore, we don't want to remove the
-- existing support for '[[Wide_]Wide_]Image, because we don't
-- currently plan to support 'Put_Image on restricted runtimes.
-- We can't do this:
--
-- Put_UTF_8 (Sink, U_Type'Image (Item));
--
-- because we need to generate UTF-8, but 'Image for enumeration
-- types uses the character encoding of the source file.
--
-- Note that this is putting a leading space for reals.
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)));
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 and private types.
declare
Libent : constant Entity_Id := RTE (Lib_RE);
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Sink),
Unchecked_Convert_To
(Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item))));
end;
end Build_Elementary_Put_Image_Call;
-------------------------------------
-- Build_String_Put_Image_Call --
-------------------------------------
function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
P_Type : constant Entity_Id := Entity (Prefix (N));
U_Type : constant Entity_Id := Underlying_Type (P_Type);
R : constant Entity_Id := Root_Type (U_Type);
Sink : constant Node_Id := First (Expressions (N));
Item : constant Node_Id := Next (Sink);
Lib_RE : RE_Id;
use Stand;
begin
if R = Standard_String then
Lib_RE := RE_Put_Image_String;
elsif R = Standard_Wide_String then
Lib_RE := RE_Put_Image_Wide_String;
elsif R = Standard_Wide_Wide_String then
Lib_RE := RE_Put_Image_Wide_Wide_String;
else
raise Program_Error;
end if;
-- Convert parameter to the required type (i.e. the type of the
-- corresponding parameter), and call the appropriate routine.
-- We set the Conversion_OK flag in case the type is private.
declare
Libent : constant Entity_Id := RTE (Lib_RE);
Conv : constant Node_Id :=
OK_Convert_To
(Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item));
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Sink),
Conv));
end;
end Build_String_Put_Image_Call;
------------------------------------
-- Build_Protected_Put_Image_Call --
------------------------------------
-- For "Protected_Type'Put_Image (S, Protected_Object)", build:
--
-- Put_Image_Protected (S);
--
-- The protected object is not passed.
function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
Sink : constant Node_Id := First (Expressions (N));
Lib_RE : constant RE_Id := RE_Put_Image_Protected;
Libent : constant Entity_Id := RTE (Lib_RE);
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Sink)));
end Build_Protected_Put_Image_Call;
------------------------------------
-- Build_Task_Put_Image_Call --
------------------------------------
-- For "Task_Type'Put_Image (S, Task_Object)", build:
--
-- Put_Image_Task (S, Task_Object'Identity);
--
-- The task object is not passed; its Task_Id is.
function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
Sink : constant Node_Id := First (Expressions (N));
Item : constant Node_Id := Next (Sink);
Lib_RE : constant RE_Id := RE_Put_Image_Task;
Libent : constant Entity_Id := RTE (Lib_RE);
Task_Id : constant Node_Id :=
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Item),
Attribute_Name => Name_Identity,
Expressions => No_List);
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Sink),
Task_Id));
end Build_Task_Put_Image_Call;
--------------------------------------
-- Build_Record_Put_Image_Procedure --
--------------------------------------
-- The form of the record Put_Image procedure is as shown by the
-- following example:
-- procedure Put_Image (S : in out Sink'Class; V : Typ) is
-- begin
-- Component_Type'Put_Image (S, V.component);
-- Component_Type'Put_Image (S, V.component);
-- ...
-- Component_Type'Put_Image (S, V.component);
--
-- case V.discriminant is
-- when choices =>
-- Component_Type'Put_Image (S, V.component);
-- Component_Type'Put_Image (S, V.component);
-- ...
-- Component_Type'Put_Image (S, V.component);
--
-- when choices =>
-- Component_Type'Put_Image (S, V.component);
-- Component_Type'Put_Image (S, V.component);
-- ...
-- Component_Type'Put_Image (S, V.component);
-- ...
-- end case;
-- end Put_Image;
procedure Build_Record_Put_Image_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Btyp : constant Entity_Id := Base_Type (Typ);
pragma Assert (not Is_Unchecked_Union (Btyp));
First_Time : Boolean := True;
function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
-- Returns a sequence of Component_Type'Put_Image attribute_references
-- to process the components that are referenced in the given component
-- list. Called for the main component list, and then recursively for
-- variants.
function Make_Component_Attributes (Clist : List_Id) return List_Id;
-- Given Clist, a component items list, construct series of
-- Component_Type'Put_Image attribute_references for componentwise
-- processing of the corresponding components. Called for the
-- discriminants, and then from Make_Component_List_Attributes for each
-- list (including in variants).
procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id);
-- Given C, the entity for a discriminant or component, build a call to
-- Component_Type'Put_Image for the corresponding component value, and
-- append it onto Clist. Called from Make_Component_Attributes.
function Make_Component_Name (C : Entity_Id) return Node_Id;
-- Create a call that prints "Comp_Name => "
------------------------------------
-- Make_Component_List_Attributes --
------------------------------------
function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
Result : List_Id;
Alts : List_Id;
V : Node_Id;
DC : Node_Id;
DCH : List_Id;
D_Ref : Node_Id;
begin
Result := Make_Component_Attributes (CI);
if Present (VP) then
Alts := New_List;
V := First_Non_Pragma (Variants (VP));
while Present (V) loop
DCH := New_List;
DC := First (Discrete_Choices (V));
while Present (DC) loop
Append_To (DCH, New_Copy_Tree (DC));
Next (DC);
end loop;
Append_To (Alts,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => DCH,
Statements =>
Make_Component_List_Attributes (Component_List (V))));
Next_Non_Pragma (V);
end loop;
-- Note: in the following, we use New_Occurrence_Of for the
-- selector, since there are cases in which we make a reference
-- to a hidden discriminant that is not visible.
D_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name =>
New_Occurrence_Of (Entity (Name (VP)), Loc));
Append_To (Result,
Make_Case_Statement (Loc,
Expression => D_Ref,
Alternatives => Alts));
end if;
return Result;
end Make_Component_List_Attributes;
--------------------------------
-- Append_Component_Attr --
--------------------------------
procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
begin
if Ekind (C) /= E_Void then
Append_To (Clist,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Component_Typ, Loc),
Attribute_Name => Name_Put_Image,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name => New_Occurrence_Of (C, Loc)))));
end if;
end Append_Component_Attr;
-------------------------------
-- Make_Component_Attributes --
-------------------------------
function Make_Component_Attributes (Clist : List_Id) return List_Id is
Item : Node_Id;
Result : List_Id;
begin
Result := New_List;
if Present (Clist) then
Item := First (Clist);
-- Loop through components, skipping all internal components,
-- which are not part of the value (e.g. _Tag), except that we
-- don't skip the _Parent, since we do want to process that
-- recursively. If _Parent is an interface type, being abstract
-- with no components there is no need to handle it.
while Present (Item) loop
if Nkind (Item) in
N_Component_Declaration | N_Discriminant_Specification
and then
((Chars (Defining_Identifier (Item)) = Name_uParent
and then not Is_Interface
(Etype (Defining_Identifier (Item))))
or else
not Is_Internal_Name (Chars (Defining_Identifier (Item))))
then
if First_Time then
First_Time := False;
else
Append_To (Result,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Record_Between), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S))));
end if;
Append_To (Result, Make_Component_Name (Item));
Append_Component_Attr (Result, Defining_Identifier (Item));
end if;
Next (Item);
end loop;
end if;
return Result;
end Make_Component_Attributes;
-------------------------
-- Make_Component_Name --
-------------------------
function Make_Component_Name (C : Entity_Id) return Node_Id is
Name : constant Name_Id := Chars (Defining_Identifier (C));
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S),
Make_String_Literal (Loc, Get_Name_String (Name) & " => ")));
end Make_Component_Name;
Stms : constant List_Id := New_List;
Rdef : Node_Id;
Type_Decl : constant Node_Id :=
Declaration_Node (Base_Type (Underlying_Type (Btyp)));
-- Start of processing for Build_Record_Put_Image_Procedure
begin
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S))));
-- Generate Put_Images for the discriminants of the type
Append_List_To (Stms,
Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
Rdef := Type_Definition (Type_Decl);
-- In the record extension case, the components we want, including the
-- _Parent component representing the parent type, are to be found in
-- the extension. We will process the _Parent component using the type
-- of the parent.
if Nkind (Rdef) = N_Derived_Type_Definition then
Rdef := Record_Extension_Part (Rdef);
end if;
if Present (Component_List (Rdef)) then
Append_List_To (Stms,
Make_Component_List_Attributes (Component_List (Rdef)));
end if;
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Record_After), Loc),
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S))));
Pnam := Make_Put_Image_Name (Loc, Btyp);
Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
end Build_Record_Put_Image_Procedure;
-------------------------------
-- Build_Put_Image_Profile --
-------------------------------
function Build_Put_Image_Profile
(Loc : Source_Ptr; Typ : Entity_Id) return List_Id
is
begin
return New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
In_Present => True,
Out_Present => True,
Parameter_Type =>
New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
end Build_Put_Image_Profile;
--------------------------
-- Build_Put_Image_Proc --
--------------------------
procedure Build_Put_Image_Proc
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Stms : List_Id)
is
Spec : constant Node_Id :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Pnam,
Parameter_Specifications => Build_Put_Image_Profile (Loc, Typ));
begin
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_Put_Image_Proc;
------------------------------------
-- Build_Unknown_Put_Image_Call --
------------------------------------
function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
Sink : constant Node_Id := First (Expressions (N));
Lib_RE : constant RE_Id := RE_Put_Image_Unknown;
Libent : constant Entity_Id := RTE (Lib_RE);
begin
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
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;
----------------------
-- Enable_Put_Image --
----------------------
function Enable_Put_Image (Typ : Entity_Id) return Boolean is
begin
-- There's a bit of a chicken&egg problem. The compiler is likely to
-- have trouble if we refer to the Put_Image of Sink itself, because
-- Sink is part of the parameter profile:
--
-- function Sink'Put_Image (S : in out Sink'Class; V : T);
--
-- Likewise, the Ada.Strings.Text_Output package, where Sink is
-- declared, depends on various other packages, so if we refer to
-- Put_Image of types declared in those other packages, we could create
-- cyclic dependencies. Therefore, we disable Put_Image for some
-- types. It's not clear exactly what types should be disabled. Scalar
-- types are OK, even if predefined, because calls to Put_Image of
-- scalar types are expanded inline. We certainly want to be able to use
-- Integer'Put_Image, for example.
-- ???Temporarily disable to work around bugs:
--
-- Put_Image does not work for Remote_Types. We check the containing
-- package, rather than the type itself, because we want to include
-- types in the private part of a Remote_Types package.
--
-- Put_Image on tagged types triggers some bugs.
if Is_Remote_Types (Scope (Typ))
or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled)
then
return False;
end if;
-- End of workarounds.
-- No sense in generating code for Put_Image if there are errors. This
-- avoids certain cascade errors.
if Total_Errors_Detected > 0 then
return False;
end if;
-- If type Sink is unavailable in this runtime, disable Put_Image
-- altogether.
if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then
return False;
end if;
-- ???Disable Put_Image on type Sink declared in
-- Ada.Strings.Text_Output. Note that we can't call Is_RTU on
-- Ada_Strings_Text_Output, because it's not known yet (we might be
-- compiling it). But this is insufficient to allow support for tagged
-- predefined types.
declare
Parent_Scope : constant Entity_Id := Scope (Scope (Typ));
begin
if Present (Parent_Scope)
and then Is_RTU (Parent_Scope, Ada_Strings)
and then Chars (Scope (Typ)) = Name_Find ("text_output")
then
return False;
end if;
end;
-- Disable for CPP types, because the components are unavailable on the
-- Ada side.
if Is_Tagged_Type (Typ)
and then Convention (Typ) = Convention_CPP
and then Is_CPP_Class (Root_Type (Typ))
then
return False;
end if;
-- Disable for unchecked unions, because there is no way to know the
-- discriminant value, and therefore no way to know which components
-- should be printed.
if Is_Unchecked_Union (Typ) then
return False;
end if;
return True;
end Enable_Put_Image;
---------------------------------
-- Make_Put_Image_Name --
---------------------------------
function Make_Put_Image_Name
(Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id
is
Sname : Name_Id;
begin
-- For tagged types, we are dealing with a TSS associated with the
-- declaration, so we use the standard primitive function name. For
-- other types, generate a local TSS name since we are generating
-- the subprogram at the point of use.
if Is_Tagged_Type (Typ) then
Sname := Make_TSS_Name (Typ, TSS_Put_Image);
else
Sname := Make_TSS_Name_Local (Typ, TSS_Put_Image);
end if;
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 --
------------------
procedure Preload_Sink (Compilation_Unit : Node_Id) is
begin
-- We can't call RTE (RE_Sink) for at least some predefined units,
-- because it would introduce cyclic dependences. The package where Sink
-- is declared, for example, and things it depends on.
--
-- It's only needed for tagged types, so don't do it unless Put_Image is
-- enabled for tagged types, and we've seen a tagged type. Note that
-- Tagged_Seen is set True by the parser if the "tagged" reserved word
-- is seen; this flag tells us whether we have any tagged types.
-- It's unfortunate to have this Tagged_Seen processing so scattered
-- about, but we need to know if there are tagged types where this is
-- called in Analyze_Compilation_Unit, before we have analyzed any type
-- declarations. This mechanism also prevents doing RTE (RE_Sink) when
-- compiling the compiler itself. Packages Ada.Strings.Text_Output and
-- friends are not included in the compiler.
--
-- Don't do it if type Sink is unavailable in the runtime.
if not In_Predefined_Unit (Compilation_Unit)
and then Tagged_Put_Image_Enabled
and then Tagged_Seen
and then not No_Run_Time_Mode
and then RTE_Available (RE_Sink)
then
declare
Ignore : constant Entity_Id := RTE (RE_Sink);
begin
null;
end;
end if;
end Preload_Sink;
-------------------------
-- Put_Image_Base_Type --
-------------------------
function Put_Image_Base_Type (E : Entity_Id) return Entity_Id is
begin
if Is_Array_Type (E) and then Is_First_Subtype (E) then
return E;
else
return Base_Type (E);
end if;
end Put_Image_Base_Type;
end Exp_Put_Image;