1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- E X P _ P U T _ I M A G E --
9 -- Copyright (C) 2020-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Csets
; use Csets
;
29 with Einfo
; use Einfo
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Rtsfind
; use Rtsfind
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
44 with Sinfo
.Utils
; use Sinfo
.Utils
;
45 with Snames
; use Snames
;
47 with Stringt
; use Stringt
;
48 with Tbuild
; use Tbuild
;
49 with Ttypes
; use Ttypes
;
50 with Uintp
; use Uintp
;
52 package body Exp_Put_Image
is
54 -----------------------
55 -- Local Subprograms --
56 -----------------------
58 procedure Build_Put_Image_Proc
64 -- Build an array or record Put_Image procedure. Stms is the list of
65 -- statements for the body and Pnam is the name of the constructed
66 -- procedure. (The declaration list is always null.)
68 function Make_Put_Image_Name
69 (Loc
: Source_Ptr
; Typ
: Entity_Id
) return Entity_Id
;
70 -- Return the entity that identifies the Put_Image subprogram for Typ. This
71 -- procedure deals with the difference between tagged types (where a single
72 -- subprogram associated with the type is generated) and all other cases
73 -- (where a subprogram is generated at the point of the attribute
74 -- reference). The Loc parameter is used as the Sloc of the created entity.
76 function Put_Image_Base_Type
(E
: Entity_Id
) return Entity_Id
;
77 -- Returns the base type, except for an array type whose whose first
78 -- subtype is constrained, in which case it returns the first subtype.
80 -------------------------------------
81 -- Build_Array_Put_Image_Procedure --
82 -------------------------------------
84 procedure Build_Array_Put_Image_Procedure
90 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
95 Index_Subtype
: Entity_Id
;
96 Between_Proc
: RE_Id
) return Node_Id
;
97 -- Wrap Stms in a loop and if statement of the form:
99 -- if V'First (Dim) <= V'Last (Dim) then -- nonempty range?
101 -- LDim : Index_Type_For_Dim := V'First (Dim);
105 -- exit when LDim = V'Last (Dim);
107 -- LDim := Index_Type_For_Dim'Succ (LDim);
112 -- This is called once per dimension, from inner to outer.
114 function Wrap_In_Loop
117 Index_Subtype
: Entity_Id
;
118 Between_Proc
: RE_Id
) return Node_Id
120 Index
: constant Entity_Id
:=
121 Make_Defining_Identifier
122 (Loc
, Chars
=> New_External_Name
('L', Dim
));
123 Decl
: constant Node_Id
:=
124 Make_Object_Declaration
(Loc
,
125 Defining_Identifier
=> Index
,
127 New_Occurrence_Of
(Index_Subtype
, Loc
),
129 Make_Attribute_Reference
(Loc
,
130 Prefix
=> Make_Identifier
(Loc
, Name_V
),
131 Attribute_Name
=> Name_First
,
132 Expressions
=> New_List
(
133 Make_Integer_Literal
(Loc
, Dim
))));
134 Loop_Stm
: constant Node_Id
:=
135 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stms
);
136 Exit_Stm
: constant Node_Id
:=
137 Make_Exit_Statement
(Loc
,
140 Left_Opnd
=> New_Occurrence_Of
(Index
, Loc
),
142 Make_Attribute_Reference
(Loc
,
144 Make_Identifier
(Loc
, Name_V
),
145 Attribute_Name
=> Name_Last
,
146 Expressions
=> New_List
(
147 Make_Integer_Literal
(Loc
, Dim
)))));
148 Increment
: constant Node_Id
:=
149 Make_Increment
(Loc
, Index
, Index_Subtype
);
150 Between
: constant Node_Id
:=
151 Make_Procedure_Call_Statement
(Loc
,
153 New_Occurrence_Of
(RTE
(Between_Proc
), Loc
),
154 Parameter_Associations
=> New_List
155 (Make_Identifier
(Loc
, Name_S
)));
156 Block
: constant Node_Id
:=
157 Make_Block_Statement
(Loc
,
158 Declarations
=> New_List
(Decl
),
159 Handled_Statement_Sequence
=>
160 Make_Handled_Sequence_Of_Statements
(Loc
,
161 Statements
=> New_List
(Loop_Stm
)));
163 Append_To
(Stms
, Exit_Stm
);
164 Append_To
(Stms
, Between
);
165 Append_To
(Stms
, Increment
);
166 -- Note that we're appending to the Stms list passed in
169 Make_If_Statement
(Loc
,
173 Make_Attribute_Reference
(Loc
,
174 Prefix
=> Make_Identifier
(Loc
, Name_V
),
175 Attribute_Name
=> Name_First
,
176 Expressions
=> New_List
(
177 Make_Integer_Literal
(Loc
, Dim
))),
179 Make_Attribute_Reference
(Loc
,
180 Prefix
=> Make_Identifier
(Loc
, Name_V
),
181 Attribute_Name
=> Name_Last
,
182 Expressions
=> New_List
(
183 Make_Integer_Literal
(Loc
, Dim
)))),
184 Then_Statements
=> New_List
(Block
));
187 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
188 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
191 Exl
: constant List_Id
:= New_List
;
192 PI_Entity
: Entity_Id
;
194 Indices
: array (1 .. Ndim
) of Entity_Id
;
196 -- Start of processing for Build_Array_Put_Image_Procedure
200 Make_Defining_Identifier
(Loc
,
201 Chars
=> Make_TSS_Name_Local
(Typ
, TSS_Put_Image
));
206 Index_Subtype
: Node_Id
:= First_Index
(Typ
);
208 for Dim
in 1 .. Ndim
loop
209 Indices
(Dim
) := Etype
(Index_Subtype
);
210 Next_Index
(Index_Subtype
);
212 pragma Assert
(No
(Index_Subtype
));
215 -- Build the inner attribute call
217 for Dim
in 1 .. Ndim
loop
218 Append_To
(Exl
, Make_Identifier
(Loc
, New_External_Name
('L', Dim
)));
222 Make_Attribute_Reference
(Loc
,
223 Prefix
=> New_Occurrence_Of
(Put_Image_Base_Type
(Ctyp
), Loc
),
224 Attribute_Name
=> Name_Put_Image
,
225 Expressions
=> New_List
(
226 Make_Identifier
(Loc
, Name_S
),
227 Make_Indexed_Component
(Loc
,
228 Prefix
=> Make_Identifier
(Loc
, Name_V
),
229 Expressions
=> Exl
)));
231 -- The corresponding attribute for the component type of the array might
232 -- be user-defined, and frozen after the array type. In that case,
233 -- freeze the Put_Image attribute of the component type, whose
234 -- declaration could not generate any additional freezing actions in any
237 PI_Entity
:= TSS
(Base_Type
(Ctyp
), TSS_Put_Image
);
239 if Present
(PI_Entity
) and then not Is_Frozen
(PI_Entity
) then
240 Set_Is_Frozen
(PI_Entity
);
243 -- Loop through the dimensions, innermost first, generating a loop for
247 Stms
: List_Id
:= New_List
(Stm
);
249 for Dim
in reverse 1 .. Ndim
loop
251 New_Stms
: constant List_Id
:= New_List
;
252 Between_Proc
: RE_Id
;
254 -- For a one-dimensional array of elementary type, use
255 -- RE_Simple_Array_Between. The same applies to the last
256 -- dimension of a multidimensional array.
258 if Is_Elementary_Type
(Ctyp
) and then Dim
= Ndim
then
259 Between_Proc
:= RE_Simple_Array_Between
;
261 Between_Proc
:= RE_Array_Between
;
265 Make_Procedure_Call_Statement
(Loc
,
266 Name
=> New_Occurrence_Of
(RTE
(RE_Array_Before
), Loc
),
267 Parameter_Associations
=> New_List
268 (Make_Identifier
(Loc
, Name_S
))));
272 Wrap_In_Loop
(Stms
, Dim
, Indices
(Dim
), Between_Proc
));
275 Make_Procedure_Call_Statement
(Loc
,
276 Name
=> New_Occurrence_Of
(RTE
(RE_Array_After
), Loc
),
277 Parameter_Associations
=> New_List
278 (Make_Identifier
(Loc
, Name_S
))));
284 Build_Put_Image_Proc
(Loc
, Typ
, Decl
, Pnam
, Stms
);
286 end Build_Array_Put_Image_Procedure
;
288 -------------------------------------
289 -- Build_Elementary_Put_Image_Call --
290 -------------------------------------
292 function Build_Elementary_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
293 Loc
: constant Source_Ptr
:= Sloc
(N
);
294 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
295 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
296 FST
: constant Entity_Id
:= First_Subtype
(U_Type
);
297 Sink
: constant Node_Id
:= First
(Expressions
(N
));
298 Item
: constant Node_Id
:= Next
(Sink
);
299 P_Size
: constant Uint
:= Esize
(FST
);
303 if Is_Signed_Integer_Type
(U_Type
) then
304 if P_Size
<= Standard_Integer_Size
then
305 Lib_RE
:= RE_Put_Image_Integer
;
306 elsif P_Size
<= Standard_Long_Long_Integer_Size
then
307 Lib_RE
:= RE_Put_Image_Long_Long_Integer
;
309 pragma Assert
(P_Size
<= Standard_Long_Long_Long_Integer_Size
);
310 Lib_RE
:= RE_Put_Image_Long_Long_Long_Integer
;
313 elsif Is_Modular_Integer_Type
(U_Type
) then
314 if P_Size
<= Standard_Integer_Size
then -- Yes, Integer
315 Lib_RE
:= RE_Put_Image_Unsigned
;
316 elsif P_Size
<= Standard_Long_Long_Integer_Size
then
317 Lib_RE
:= RE_Put_Image_Long_Long_Unsigned
;
319 pragma Assert
(P_Size
<= Standard_Long_Long_Long_Integer_Size
);
320 Lib_RE
:= RE_Put_Image_Long_Long_Long_Unsigned
;
323 elsif Is_Access_Type
(U_Type
) then
324 if Is_Access_Protected_Subprogram_Type
(Base_Type
(U_Type
)) then
325 Lib_RE
:= RE_Put_Image_Access_Prot_Subp
;
326 elsif Is_Access_Subprogram_Type
(Base_Type
(U_Type
)) then
327 Lib_RE
:= RE_Put_Image_Access_Subp
;
328 elsif P_Size
= System_Address_Size
then
329 Lib_RE
:= RE_Put_Image_Thin_Pointer
;
331 pragma Assert
(P_Size
= 2 * System_Address_Size
);
332 Lib_RE
:= RE_Put_Image_Fat_Pointer
;
337 (Is_Enumeration_Type
(U_Type
) or else Is_Real_Type
(U_Type
));
339 -- For other elementary types, generate:
341 -- Wide_Wide_Put (Root_Buffer_Type'Class (Sink),
342 -- U_Type'Wide_Wide_Image (Item));
344 -- It would be more elegant to do it the other way around (define
345 -- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier
346 -- to implement, because we already have support for
347 -- 'Wide_Wide_Image. Furthermore, we don't want to remove the
348 -- existing support for '[[Wide_]Wide_]Image, because we don't
349 -- currently plan to support 'Put_Image on restricted runtimes.
353 -- Put_UTF_8 (Sink, U_Type'Image (Item));
355 -- because we need to generate UTF-8, but 'Image for enumeration
356 -- types uses the character encoding of the source file.
358 -- Note that this is putting a leading space for reals.
361 Image
: constant Node_Id
:=
362 Make_Attribute_Reference
(Loc
,
363 Prefix
=> New_Occurrence_Of
(U_Type
, Loc
),
364 Attribute_Name
=> Name_Wide_Wide_Image
,
365 Expressions
=> New_List
(Relocate_Node
(Item
)));
366 Sink_Exp
: constant Node_Id
:=
367 Make_Type_Conversion
(Loc
,
370 (Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
)), Loc
),
371 Expression
=> Relocate_Node
(Sink
));
372 Put_Call
: constant Node_Id
:=
373 Make_Procedure_Call_Statement
(Loc
,
375 New_Occurrence_Of
(RTE
(RE_Wide_Wide_Put
), Loc
),
376 Parameter_Associations
=> New_List
379 -- We have built a dispatching call to handle calls to
380 -- descendants (since they are not available through rtsfind).
381 -- Further details available in the body of Put_String_Exp.
387 -- Unchecked-convert parameter to the required type (i.e. the type of
388 -- the corresponding parameter), and call the appropriate routine.
389 -- We could use a normal type conversion for scalars, but the
390 -- "unchecked" is needed for access and private types.
393 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
396 Make_Procedure_Call_Statement
(Loc
,
397 Name
=> New_Occurrence_Of
(Libent
, Loc
),
398 Parameter_Associations
=> New_List
(
399 Relocate_Node
(Sink
),
401 (Etype
(Next_Formal
(First_Formal
(Libent
))),
402 Relocate_Node
(Item
))));
404 end Build_Elementary_Put_Image_Call
;
406 -------------------------------------
407 -- Build_String_Put_Image_Call --
408 -------------------------------------
410 function Build_String_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
411 Loc
: constant Source_Ptr
:= Sloc
(N
);
412 P_Type
: constant Entity_Id
:= Entity
(Prefix
(N
));
413 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
414 R
: constant Entity_Id
:= Root_Type
(U_Type
);
415 Sink
: constant Node_Id
:= First
(Expressions
(N
));
416 Item
: constant Node_Id
:= Next
(Sink
);
420 if R
= Standard_String
then
421 Lib_RE
:= RE_Put_Image_String
;
422 elsif R
= Standard_Wide_String
then
423 Lib_RE
:= RE_Put_Image_Wide_String
;
424 elsif R
= Standard_Wide_Wide_String
then
425 Lib_RE
:= RE_Put_Image_Wide_Wide_String
;
430 -- Convert parameter to the required type (i.e. the type of the
431 -- corresponding parameter), and call the appropriate routine.
432 -- We set the Conversion_OK flag in case the type is private.
435 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
436 Conv
: constant Node_Id
:=
438 (Etype
(Next_Formal
(First_Formal
(Libent
))),
439 Relocate_Node
(Item
));
441 -- Do not output string delimiters if this is part of an
442 -- interpolated string literal.
444 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
445 and then Nkind
(Original_Node
(Parent
(N
)))
446 = N_Interpolated_String_Literal
449 Make_Procedure_Call_Statement
(Loc
,
450 Name
=> New_Occurrence_Of
(Libent
, Loc
),
451 Parameter_Associations
=> New_List
(
452 Relocate_Node
(Sink
),
454 New_Occurrence_Of
(Stand
.Standard_False
, Loc
)));
457 Make_Procedure_Call_Statement
(Loc
,
458 Name
=> New_Occurrence_Of
(Libent
, Loc
),
459 Parameter_Associations
=> New_List
(
460 Relocate_Node
(Sink
),
464 end Build_String_Put_Image_Call
;
466 ------------------------------------
467 -- Build_Protected_Put_Image_Call --
468 ------------------------------------
470 -- For "Protected_Type'Put_Image (S, Protected_Object)", build:
472 -- Put_Image_Protected (S);
474 -- The protected object is not passed.
476 function Build_Protected_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
477 Loc
: constant Source_Ptr
:= Sloc
(N
);
478 Sink
: constant Node_Id
:= First
(Expressions
(N
));
479 Lib_RE
: constant RE_Id
:= RE_Put_Image_Protected
;
480 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
483 Make_Procedure_Call_Statement
(Loc
,
484 Name
=> New_Occurrence_Of
(Libent
, Loc
),
485 Parameter_Associations
=> New_List
(
486 Relocate_Node
(Sink
)));
487 end Build_Protected_Put_Image_Call
;
489 ------------------------------------
490 -- Build_Task_Put_Image_Call --
491 ------------------------------------
493 -- For "Task_Type'Put_Image (S, Task_Object)", build:
495 -- Put_Image_Task (S, Task_Object'Identity);
497 -- The task object is not passed; its Task_Id is.
499 function Build_Task_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
500 Loc
: constant Source_Ptr
:= Sloc
(N
);
501 Sink
: constant Node_Id
:= First
(Expressions
(N
));
502 Item
: constant Node_Id
:= Next
(Sink
);
503 Lib_RE
: constant RE_Id
:= RE_Put_Image_Task
;
504 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
506 Task_Id
: constant Node_Id
:=
507 Make_Attribute_Reference
(Loc
,
508 Prefix
=> Relocate_Node
(Item
),
509 Attribute_Name
=> Name_Identity
,
510 Expressions
=> No_List
);
514 Make_Procedure_Call_Statement
(Loc
,
515 Name
=> New_Occurrence_Of
(Libent
, Loc
),
516 Parameter_Associations
=> New_List
(
517 Relocate_Node
(Sink
),
519 end Build_Task_Put_Image_Call
;
521 --------------------------------------
522 -- Build_Record_Put_Image_Procedure --
523 --------------------------------------
525 -- The form of the record Put_Image procedure is as shown by the
526 -- following example:
528 -- procedure Put_Image (S : in out Sink'Class; V : Typ) is
530 -- Component_Type'Put_Image (S, V.component);
531 -- Component_Type'Put_Image (S, V.component);
533 -- Component_Type'Put_Image (S, V.component);
535 -- case V.discriminant is
537 -- Component_Type'Put_Image (S, V.component);
538 -- Component_Type'Put_Image (S, V.component);
540 -- Component_Type'Put_Image (S, V.component);
543 -- Component_Type'Put_Image (S, V.component);
544 -- Component_Type'Put_Image (S, V.component);
546 -- Component_Type'Put_Image (S, V.component);
551 procedure Build_Record_Put_Image_Procedure
555 Pnam
: out Entity_Id
)
557 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
558 pragma Assert
(not Is_Class_Wide_Type
(Btyp
));
559 pragma Assert
(not Is_Unchecked_Union
(Btyp
));
561 First_Time
: Boolean := True;
563 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
;
564 -- Returns a sequence of Component_Type'Put_Image attribute_references
565 -- to process the components that are referenced in the given component
566 -- list. Called for the main component list, and then recursively for
569 function Make_Component_Attributes
(Clist
: List_Id
) return List_Id
;
570 -- Given Clist, a component items list, construct series of
571 -- Component_Type'Put_Image attribute_references for componentwise
572 -- processing of the corresponding components. Called for the
573 -- discriminants, and then from Make_Component_List_Attributes for each
574 -- list (including in variants).
576 procedure Append_Component_Attr
(Clist
: List_Id
; C
: Entity_Id
);
577 -- Given C, the entity for a discriminant or component, build a call to
578 -- Component_Type'Put_Image for the corresponding component value, and
579 -- append it onto Clist. Called from Make_Component_Attributes.
581 function Make_Component_Name
(C
: Entity_Id
) return Node_Id
;
582 -- Create a call that prints "Comp_Name => "
584 ------------------------------------
585 -- Make_Component_List_Attributes --
586 ------------------------------------
588 function Make_Component_List_Attributes
(CL
: Node_Id
) return List_Id
is
589 CI
: constant List_Id
:= Component_Items
(CL
);
590 VP
: constant Node_Id
:= Variant_Part
(CL
);
600 Result
:= Make_Component_Attributes
(CI
);
605 V
:= First_Non_Pragma
(Variants
(VP
));
606 while Present
(V
) loop
609 DC
:= First
(Discrete_Choices
(V
));
610 while Present
(DC
) loop
611 Append_To
(DCH
, New_Copy_Tree
(DC
));
616 Make_Case_Statement_Alternative
(Loc
,
617 Discrete_Choices
=> DCH
,
619 Make_Component_List_Attributes
(Component_List
(V
))));
623 -- Note: in the following, we use New_Occurrence_Of for the
624 -- selector, since there are cases in which we make a reference
625 -- to a hidden discriminant that is not visible.
628 Make_Selected_Component
(Loc
,
629 Prefix
=> Make_Identifier
(Loc
, Name_V
),
631 New_Occurrence_Of
(Entity
(Name
(VP
)), Loc
));
634 Make_Case_Statement
(Loc
,
636 Alternatives
=> Alts
));
640 end Make_Component_List_Attributes
;
642 --------------------------------
643 -- Append_Component_Attr --
644 --------------------------------
646 procedure Append_Component_Attr
(Clist
: List_Id
; C
: Entity_Id
) is
647 Component_Typ
: constant Entity_Id
:= Put_Image_Base_Type
(Etype
(C
));
649 if Ekind
(C
) /= E_Void
then
651 Make_Attribute_Reference
(Loc
,
652 Prefix
=> New_Occurrence_Of
(Component_Typ
, Loc
),
653 Attribute_Name
=> Name_Put_Image
,
654 Expressions
=> New_List
(
655 Make_Identifier
(Loc
, Name_S
),
656 Make_Selected_Component
(Loc
,
657 Prefix
=> Make_Identifier
(Loc
, Name_V
),
658 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)))));
660 end Append_Component_Attr
;
662 -------------------------------
663 -- Make_Component_Attributes --
664 -------------------------------
666 function Make_Component_Attributes
(Clist
: List_Id
) return List_Id
is
673 if Present
(Clist
) then
674 Item
:= First
(Clist
);
676 -- Loop through components, skipping all internal components,
677 -- which are not part of the value (e.g. _Tag), except that we
678 -- don't skip the _Parent, since we do want to process that
681 while Present
(Item
) loop
683 N_Component_Declaration | N_Discriminant_Specification
685 if Chars
(Defining_Identifier
(Item
)) = Name_uParent
then
687 Parent_Type
: constant Entity_Id
:=
688 Implementation_Base_Type
689 (Etype
(Defining_Identifier
(Item
)));
691 Parent_Aspect_Spec
: constant Node_Id
:=
692 Find_Aspect
(Parent_Type
, Aspect_Put_Image
);
694 Parent_Type_Decl
: constant Node_Id
:=
695 Declaration_Node
(Parent_Type
);
697 Parent_Rdef
: Node_Id
:=
698 Type_Definition
(Parent_Type_Decl
);
700 -- If parent type has an noninherited
701 -- explicitly-specified Put_Image aspect spec, then
702 -- display parent part by calling specified procedure,
703 -- and then use extension-aggregate syntax for the
704 -- remaining components as per RM 4.10(15/5);
705 -- otherwise, "look through" the parent component
706 -- to its components - we don't want the image text
707 -- to include mention of an "_parent" component.
709 if Present
(Parent_Aspect_Spec
) and then
710 Entity
(Parent_Aspect_Spec
) = Parent_Type
712 Append_Component_Attr
713 (Result
, Defining_Identifier
(Item
));
715 -- Omit the " with " if no subsequent components.
717 if not Is_Null_Extension_Of
719 Ancestor
=> Parent_Type
)
722 Make_Procedure_Call_Statement
(Loc
,
725 (RTE
(RE_Put_UTF_8
), Loc
),
726 Parameter_Associations
=> New_List
727 (Make_Identifier
(Loc
, Name_S
),
728 Make_String_Literal
(Loc
, " with "))));
731 if Nkind
(Parent_Rdef
) = N_Derived_Type_Definition
734 Record_Extension_Part
(Parent_Rdef
);
737 if Present
(Component_List
(Parent_Rdef
)) then
738 Append_List_To
(Result
,
739 Make_Component_List_Attributes
740 (Component_List
(Parent_Rdef
)));
745 elsif not Is_Internal_Name
746 (Chars
(Defining_Identifier
(Item
)))
752 Make_Procedure_Call_Statement
(Loc
,
754 New_Occurrence_Of
(RTE
(RE_Record_Between
), Loc
),
755 Parameter_Associations
=> New_List
756 (Make_Identifier
(Loc
, Name_S
))));
759 Append_To
(Result
, Make_Component_Name
(Item
));
760 Append_Component_Attr
761 (Result
, Defining_Identifier
(Item
));
770 end Make_Component_Attributes
;
772 -------------------------
773 -- Make_Component_Name --
774 -------------------------
776 function Make_Component_Name
(C
: Entity_Id
) return Node_Id
is
777 Name
: constant Name_Id
:= Chars
(Defining_Identifier
(C
));
778 pragma Assert
(Name
/= Name_uParent
);
780 function To_Upper
(S
: String) return String;
781 -- Same as Ada.Characters.Handling.To_Upper, but withing
782 -- Ada.Characters.Handling seems to cause mailserver problems.
788 function To_Upper
(S
: String) return String is
790 return Result
: String := S
do
791 for Char
of Result
loop
792 Char
:= Fold_Upper
(Char
);
797 -- Start of processing for Make_Component_Name
801 Make_Procedure_Call_Statement
(Loc
,
802 Name
=> New_Occurrence_Of
(RTE
(RE_Put_UTF_8
), Loc
),
803 Parameter_Associations
=> New_List
804 (Make_Identifier
(Loc
, Name_S
),
805 Make_String_Literal
(Loc
,
806 To_Upper
(Get_Name_String
(Name
)) & " => ")));
807 end Make_Component_Name
;
809 Stms
: constant List_Id
:= New_List
;
811 Type_Decl
: constant Node_Id
:=
812 Declaration_Node
(Base_Type
(Underlying_Type
(Btyp
)));
814 -- Start of processing for Build_Record_Put_Image_Procedure
817 if Ada_Version
< Ada_2022
818 or else not Put_Image_Enabled
(Btyp
)
820 -- generate a very simple Put_Image implementation
822 if Is_RTE
(Typ
, RE_Root_Buffer_Type
) then
823 -- Avoid introducing a cyclic dependency between
824 -- Ada.Strings.Text_Buffers and System.Put_Images.
827 Make_Raise_Program_Error
(Loc
,
828 Reason
=> PE_Explicit_Raise
));
831 Make_Procedure_Call_Statement
(Loc
,
832 Name
=> New_Occurrence_Of
(RTE
(RE_Put_Image_Unknown
), Loc
),
833 Parameter_Associations
=> New_List
834 (Make_Identifier
(Loc
, Name_S
),
835 Make_String_Literal
(Loc
,
836 To_String
(Fully_Qualified_Name_String
(Btyp
))))));
838 elsif Is_Null_Record_Type
(Btyp
, Ignore_Privacy
=> True) then
840 -- Interface types take this path.
843 Make_Procedure_Call_Statement
(Loc
,
844 Name
=> New_Occurrence_Of
(RTE
(RE_Put_UTF_8
), Loc
),
845 Parameter_Associations
=> New_List
846 (Make_Identifier
(Loc
, Name_S
),
847 Make_String_Literal
(Loc
, "(NULL RECORD)"))));
849 elsif Is_Derived_Type
(Btyp
)
850 and then (not Is_Tagged_Type
(Btyp
) or else Is_Null_Extension
(Btyp
))
853 Parent_Type
: constant Entity_Id
:= Base_Type
(Etype
(Btyp
));
856 Make_Attribute_Reference
(Loc
,
857 Prefix
=> New_Occurrence_Of
(Parent_Type
, Loc
),
858 Attribute_Name
=> Name_Put_Image
,
859 Expressions
=> New_List
(
860 Make_Identifier
(Loc
, Name_S
),
861 Make_Type_Conversion
(Loc
,
862 Subtype_Mark
=> New_Occurrence_Of
864 Expression
=> Make_Identifier
870 Make_Procedure_Call_Statement
(Loc
,
871 Name
=> New_Occurrence_Of
(RTE
(RE_Record_Before
), Loc
),
872 Parameter_Associations
=> New_List
873 (Make_Identifier
(Loc
, Name_S
))));
875 -- Generate Put_Images for the discriminants of the type
877 Append_List_To
(Stms
,
878 Make_Component_Attributes
879 (Discriminant_Specifications
(Type_Decl
)));
881 Rdef
:= Type_Definition
(Type_Decl
);
883 -- In the record extension case, the components we want are to be
884 -- found in the extension (although we have to process the
885 -- _Parent component to find inherited components).
887 if Nkind
(Rdef
) = N_Derived_Type_Definition
then
888 Rdef
:= Record_Extension_Part
(Rdef
);
891 if Present
(Component_List
(Rdef
)) then
892 Append_List_To
(Stms
,
893 Make_Component_List_Attributes
(Component_List
(Rdef
)));
897 Make_Procedure_Call_Statement
(Loc
,
898 Name
=> New_Occurrence_Of
(RTE
(RE_Record_After
), Loc
),
899 Parameter_Associations
=> New_List
900 (Make_Identifier
(Loc
, Name_S
))));
903 Pnam
:= Make_Put_Image_Name
(Loc
, Btyp
);
904 Build_Put_Image_Proc
(Loc
, Btyp
, Decl
, Pnam
, Stms
);
905 end Build_Record_Put_Image_Procedure
;
907 -------------------------------
908 -- Build_Put_Image_Profile --
909 -------------------------------
911 function Build_Put_Image_Profile
912 (Loc
: Source_Ptr
; Typ
: Entity_Id
) return List_Id
916 Make_Parameter_Specification
(Loc
,
917 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
922 (Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
)), Loc
)),
924 Make_Parameter_Specification
(Loc
,
925 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
926 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
927 end Build_Put_Image_Profile
;
929 --------------------------
930 -- Build_Put_Image_Proc --
931 --------------------------
933 procedure Build_Put_Image_Proc
940 Spec
: constant Node_Id
:=
941 Make_Procedure_Specification
(Loc
,
942 Defining_Unit_Name
=> Pnam
,
943 Parameter_Specifications
=> Build_Put_Image_Profile
(Loc
, Typ
));
946 Make_Subprogram_Body
(Loc
,
947 Specification
=> Spec
,
948 Declarations
=> Empty_List
,
949 Handled_Statement_Sequence
=>
950 Make_Handled_Sequence_Of_Statements
(Loc
,
951 Statements
=> Stms
));
952 end Build_Put_Image_Proc
;
954 ------------------------------------
955 -- Build_Unknown_Put_Image_Call --
956 ------------------------------------
958 function Build_Unknown_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
959 Loc
: constant Source_Ptr
:= Sloc
(N
);
960 Sink
: constant Node_Id
:= First
(Expressions
(N
));
961 Lib_RE
: constant RE_Id
:= RE_Put_Image_Unknown
;
962 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
965 Make_Procedure_Call_Statement
(Loc
,
966 Name
=> New_Occurrence_Of
(Libent
, Loc
),
967 Parameter_Associations
=> New_List
(
968 Relocate_Node
(Sink
),
969 Make_String_Literal
(Loc
,
970 Exp_Util
.Fully_Qualified_Name_String
(
971 Entity
(Prefix
(N
)), Append_NUL
=> False))));
972 end Build_Unknown_Put_Image_Call
;
974 -----------------------
975 -- Put_Image_Enabled --
976 -----------------------
978 function Put_Image_Enabled
(Typ
: Entity_Id
) return Boolean is
980 -- If this function returns False for a non-scalar type Typ, then
981 -- a) calls to Typ'Image will result in calls to
982 -- System.Put_Images.Put_Image_Unknown to generate the image.
983 -- b) If Typ is a tagged type, then similarly the implementation
984 -- of Typ's Put_Image procedure will call Put_Image_Unknown
985 -- and will ignore its formal parameter of type Typ.
986 -- Note that Typ will still have a Put_Image procedure
987 -- in this case, albeit one with a simplified implementation.
989 -- The name "Sink" here is a short nickname for
990 -- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
993 -- Put_Image does not work for Remote_Types. We check the containing
994 -- package, rather than the type itself, because we want to include
995 -- types in the private part of a Remote_Types package.
997 if Is_Remote_Types
(Scope
(Typ
))
998 or else Is_Remote_Call_Interface
(Typ
)
1003 -- No sense in generating code for Put_Image if there are errors. This
1004 -- avoids certain cascade errors.
1006 if Total_Errors_Detected
> 0 then
1010 -- If type Sink is unavailable in this runtime, disable Put_Image
1013 if No_Run_Time_Mode
or else not RTE_Available
(RE_Root_Buffer_Type
) then
1017 if Is_Tagged_Type
(Typ
) then
1018 if Is_Class_Wide_Type
(Typ
) then
1019 return Put_Image_Enabled
(Find_Specific_Type
(Base_Type
(Typ
)));
1020 elsif Present
(Find_Aspect
(Typ
, Aspect_Put_Image
,
1021 Or_Rep_Item
=> True))
1024 elsif Is_Derived_Type
(Typ
) then
1025 return Put_Image_Enabled
(Etype
(Base_Type
(Typ
)));
1026 elsif Is_Predefined_Unit
(Get_Code_Unit
(Typ
)) then
1031 -- ???Disable Put_Image on type Root_Buffer_Type declared in
1032 -- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
1033 -- Ada_Strings_Text_Buffers, because it's not known yet (we might be
1034 -- compiling it). But this is insufficient to allow support for tagged
1035 -- predefined types.
1038 Parent_Scope
: constant Entity_Id
:= Scope
(Scope
(Typ
));
1040 if Present
(Parent_Scope
)
1041 and then Is_RTU
(Parent_Scope
, Ada_Strings
)
1042 and then Chars
(Scope
(Typ
)) = Name_Find
("text_buffers")
1048 -- Disable for CPP types, because the components are unavailable on the
1051 if Is_Tagged_Type
(Typ
)
1052 and then Convention
(Typ
) = Convention_CPP
1053 and then Is_CPP_Class
(Root_Type
(Typ
))
1058 -- Disable for unchecked unions, because there is no way to know the
1059 -- discriminant value, and therefore no way to know which components
1060 -- should be printed.
1062 if Is_Unchecked_Union
(Typ
) then
1067 end Put_Image_Enabled
;
1069 -------------------------
1070 -- Make_Put_Image_Name --
1071 -------------------------
1073 function Make_Put_Image_Name
1074 (Loc
: Source_Ptr
; Typ
: Entity_Id
) return Entity_Id
1078 -- For tagged types, we are dealing with a TSS associated with the
1079 -- declaration, so we use the standard primitive function name. For
1080 -- other types, generate a local TSS name since we are generating
1081 -- the subprogram at the point of use.
1083 if Is_Tagged_Type
(Typ
) then
1084 Sname
:= Make_TSS_Name
(Typ
, TSS_Put_Image
);
1086 Sname
:= Make_TSS_Name_Local
(Typ
, TSS_Put_Image
);
1089 return Make_Defining_Identifier
(Loc
, Sname
);
1090 end Make_Put_Image_Name
;
1092 ---------------------------------
1093 -- Image_Should_Call_Put_Image --
1094 ---------------------------------
1096 function Image_Should_Call_Put_Image
(N
: Node_Id
) return Boolean is
1098 if Ada_Version
< Ada_2022
then
1102 -- In Ada 2022, T'Image calls T'Put_Image if there is an explicit
1103 -- (or inherited) aspect_specification for Put_Image, or if
1104 -- U_Type'Image is illegal in pre-2022 versions of Ada.
1107 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Prefix
(N
)));
1109 if Has_Aspect
(U_Type
, Aspect_Put_Image
) then
1113 return not Is_Scalar_Type
(U_Type
);
1115 end Image_Should_Call_Put_Image
;
1117 ----------------------
1118 -- Build_Image_Call --
1119 ----------------------
1121 function Build_Image_Call
(N
: Node_Id
) return Node_Id
is
1122 -- For T'[[Wide_]Wide_]Image (X) Generate an Expression_With_Actions
1127 -- U_Type'Put_Image (S, X);
1128 -- Result : constant [[Wide_]Wide_]String :=
1129 -- [[Wide_[Wide_]]Get (S);
1133 -- where U_Type is the underlying type, as needed to bypass privacy.
1135 Loc
: constant Source_Ptr
:= Sloc
(N
);
1136 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Prefix
(N
)));
1137 Sink_Entity
: constant Entity_Id
:=
1138 Make_Temporary
(Loc
, 'S');
1139 Sink_Decl
: constant Node_Id
:=
1140 Make_Object_Declaration
(Loc
,
1141 Defining_Identifier
=> Sink_Entity
,
1142 Object_Definition
=>
1143 New_Occurrence_Of
(RTE
(RE_Buffer_Type
), Loc
));
1145 Image_Prefix
: constant Node_Id
:=
1146 Duplicate_Subexpr
(First
(Expressions
(N
)));
1148 Put_Im
: constant Node_Id
:=
1149 Make_Attribute_Reference
(Loc
,
1150 Prefix
=> New_Occurrence_Of
(U_Type
, Loc
),
1151 Attribute_Name
=> Name_Put_Image
,
1152 Expressions
=> New_List
(
1153 New_Occurrence_Of
(Sink_Entity
, Loc
),
1155 Result_Entity
: constant Entity_Id
:=
1156 Make_Temporary
(Loc
, 'R');
1158 subtype Image_Name_Id
is Name_Id
with Static_Predicate
=>
1159 Image_Name_Id
in Name_Image | Name_Wide_Image | Name_Wide_Wide_Image
;
1160 -- Attribute names that will be mapped to the corresponding result types
1163 Attribute_Name_Id
: constant Name_Id
:=
1164 (if Attribute_Name
(N
) = Name_Img
then Name_Image
1165 else Attribute_Name
(N
));
1167 Result_Typ
: constant Entity_Id
:=
1168 (case Image_Name_Id
'(Attribute_Name_Id) is
1169 when Name_Image => Stand.Standard_String,
1170 when Name_Wide_Image => Stand.Standard_Wide_String,
1171 when Name_Wide_Wide_Image => Stand.Standard_Wide_Wide_String);
1172 Get_Func_Id : constant RE_Id :=
1173 (case Image_Name_Id'(Attribute_Name_Id
) is
1174 when Name_Image
=> RE_Get
,
1175 when Name_Wide_Image
=> RE_Wide_Get
,
1176 when Name_Wide_Wide_Image
=> RE_Wide_Wide_Get
);
1178 Result_Decl
: constant Node_Id
:=
1179 Make_Object_Declaration
(Loc
,
1180 Defining_Identifier
=> Result_Entity
,
1181 Object_Definition
=>
1182 New_Occurrence_Of
(Result_Typ
, Loc
),
1184 Make_Function_Call
(Loc
,
1185 Name
=> New_Occurrence_Of
(RTE
(Get_Func_Id
), Loc
),
1186 Parameter_Associations
=> New_List
(
1187 New_Occurrence_Of
(Sink_Entity
, Loc
))));
1190 function Put_String_Exp
(String_Exp
: Node_Id
;
1191 Wide_Wide
: Boolean := False) return Node_Id
;
1192 -- Generate a call to evaluate a String (or Wide_Wide_String, depending
1193 -- on the Wide_Wide Boolean parameter) expression and output it into
1196 --------------------
1197 -- Put_String_Exp --
1198 --------------------
1200 function Put_String_Exp
(String_Exp
: Node_Id
;
1201 Wide_Wide
: Boolean := False) return Node_Id
is
1202 Put_Id
: constant RE_Id
:=
1203 (if Wide_Wide
then RE_Wide_Wide_Put
else RE_Put_UTF_8
);
1205 -- We could build a nondispatching call here, but to make
1206 -- that work we'd have to change Rtsfind spec to make available
1207 -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded
1208 -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to
1209 -- introduce a type conversion and leave it to the optimizer to
1210 -- eliminate the dispatching. This does not *introduce* any problems
1211 -- if a no-dispatching-allowed restriction is in effect, since we
1212 -- are already in the middle of generating a call to T'Class'Image.
1214 Sink_Exp
: constant Node_Id
:=
1215 Make_Type_Conversion
(Loc
,
1218 (Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
)), Loc
),
1219 Expression
=> New_Occurrence_Of
(Sink_Entity
, Loc
));
1222 Make_Procedure_Call_Statement
(Loc
,
1223 Name
=> New_Occurrence_Of
(RTE
(Put_Id
), Loc
),
1224 Parameter_Associations
=> New_List
(Sink_Exp
, String_Exp
));
1231 -- Start of processing for Build_Image_Call
1234 if Is_Class_Wide_Type
(U_Type
) then
1236 -- For interface types we must generate code to displace the pointer
1237 -- to the object to reference the base of the underlying object.
1240 -- To_Tag_Ptr (Image_Prefix'Address).all
1242 -- Note that Image_Prefix'Address is recursively expanded into a
1243 -- call to Ada.Tags.Base_Address (Image_Prefix'Address).
1245 if Is_Interface
(U_Type
) then
1247 Make_Explicit_Dereference
(Loc
,
1248 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
1249 Make_Attribute_Reference
(Loc
,
1250 Prefix
=> Duplicate_Subexpr
(Image_Prefix
),
1251 Attribute_Name
=> Name_Address
)));
1257 Make_Attribute_Reference
(Loc
,
1258 Prefix
=> Duplicate_Subexpr
(Image_Prefix
),
1259 Attribute_Name
=> Name_Tag
);
1262 -- Generate qualified-expression syntax; qualification name comes
1263 -- from calling Ada.Tags.Wide_Wide_Expanded_Name.
1266 -- The copy of Image_Prefix will be evaluated before the
1267 -- original, which is ok if no side effects are involved.
1269 pragma Assert
(Side_Effect_Free
(Image_Prefix
));
1271 Specific_Type_Name
: constant Node_Id
:=
1273 (Make_Function_Call
(Loc
,
1274 Name
=> New_Occurrence_Of
1275 (RTE
(RE_Wide_Wide_Expanded_Name
), Loc
),
1276 Parameter_Associations
=> New_List
(Tag_Node
)),
1279 Qualification
: constant Node_Id
:=
1280 Put_String_Exp
(Make_String_Literal
(Loc
, "'"));
1290 Actions
:= New_List
(Sink_Decl
, Put_Im
, Result_Decl
);
1293 return Make_Expression_With_Actions
(Loc
,
1295 Expression
=> New_Occurrence_Of
(Result_Entity
, Loc
));
1296 end Build_Image_Call
;
1298 ------------------------------
1299 -- Preload_Root_Buffer_Type --
1300 ------------------------------
1302 procedure Preload_Root_Buffer_Type
(Compilation_Unit
: Node_Id
) is
1304 -- We can't call RTE (RE_Root_Buffer_Type) for at least some
1305 -- predefined units, because it would introduce cyclic dependences.
1306 -- The package where Root_Buffer_Type is declared, for example, and
1307 -- things it depends on.
1309 -- It's only needed for tagged types, so don't do it unless Put_Image is
1310 -- enabled for tagged types, and we've seen a tagged type. Note that
1311 -- Tagged_Seen is set True by the parser if the "tagged" reserved word
1312 -- is seen; this flag tells us whether we have any tagged types.
1313 -- It's unfortunate to have this Tagged_Seen processing so scattered
1314 -- about, but we need to know if there are tagged types where this is
1315 -- called in Analyze_Compilation_Unit, before we have analyzed any type
1316 -- declarations. This mechanism also prevents doing
1317 -- RTE (RE_Root_Buffer_Type) when compiling the compiler itself.
1318 -- Packages Ada.Strings.Buffer_Types and friends are not included
1321 -- Don't do it if type Root_Buffer_Type is unavailable in the runtime.
1323 if not In_Predefined_Unit
(Compilation_Unit
)
1324 and then Tagged_Seen
1325 and then not No_Run_Time_Mode
1326 and then RTE_Available
(RE_Root_Buffer_Type
)
1329 Ignore
: constant Entity_Id
:= RTE
(RE_Root_Buffer_Type
);
1334 end Preload_Root_Buffer_Type
;
1336 -------------------------
1337 -- Put_Image_Base_Type --
1338 -------------------------
1340 function Put_Image_Base_Type
(E
: Entity_Id
) return Entity_Id
is
1342 if Is_Array_Type
(E
) and then Is_First_Subtype
(E
) then
1345 return Base_Type
(E
);
1347 end Put_Image_Base_Type
;