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 Enable_Put_Image
(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)"))));
850 Make_Procedure_Call_Statement
(Loc
,
851 Name
=> New_Occurrence_Of
(RTE
(RE_Record_Before
), Loc
),
852 Parameter_Associations
=> New_List
853 (Make_Identifier
(Loc
, Name_S
))));
855 -- Generate Put_Images for the discriminants of the type
857 Append_List_To
(Stms
,
858 Make_Component_Attributes
859 (Discriminant_Specifications
(Type_Decl
)));
861 Rdef
:= Type_Definition
(Type_Decl
);
863 -- In the record extension case, the components we want are to be
864 -- found in the extension (although we have to process the
865 -- _Parent component to find inherited components).
867 if Nkind
(Rdef
) = N_Derived_Type_Definition
then
868 Rdef
:= Record_Extension_Part
(Rdef
);
871 if Present
(Component_List
(Rdef
)) then
872 Append_List_To
(Stms
,
873 Make_Component_List_Attributes
(Component_List
(Rdef
)));
877 Make_Procedure_Call_Statement
(Loc
,
878 Name
=> New_Occurrence_Of
(RTE
(RE_Record_After
), Loc
),
879 Parameter_Associations
=> New_List
880 (Make_Identifier
(Loc
, Name_S
))));
883 Pnam
:= Make_Put_Image_Name
(Loc
, Btyp
);
884 Build_Put_Image_Proc
(Loc
, Btyp
, Decl
, Pnam
, Stms
);
885 end Build_Record_Put_Image_Procedure
;
887 -------------------------------
888 -- Build_Put_Image_Profile --
889 -------------------------------
891 function Build_Put_Image_Profile
892 (Loc
: Source_Ptr
; Typ
: Entity_Id
) return List_Id
896 Make_Parameter_Specification
(Loc
,
897 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_S
),
902 (Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
)), Loc
)),
904 Make_Parameter_Specification
(Loc
,
905 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
906 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
907 end Build_Put_Image_Profile
;
909 --------------------------
910 -- Build_Put_Image_Proc --
911 --------------------------
913 procedure Build_Put_Image_Proc
920 Spec
: constant Node_Id
:=
921 Make_Procedure_Specification
(Loc
,
922 Defining_Unit_Name
=> Pnam
,
923 Parameter_Specifications
=> Build_Put_Image_Profile
(Loc
, Typ
));
926 Make_Subprogram_Body
(Loc
,
927 Specification
=> Spec
,
928 Declarations
=> Empty_List
,
929 Handled_Statement_Sequence
=>
930 Make_Handled_Sequence_Of_Statements
(Loc
,
931 Statements
=> Stms
));
932 end Build_Put_Image_Proc
;
934 ------------------------------------
935 -- Build_Unknown_Put_Image_Call --
936 ------------------------------------
938 function Build_Unknown_Put_Image_Call
(N
: Node_Id
) return Node_Id
is
939 Loc
: constant Source_Ptr
:= Sloc
(N
);
940 Sink
: constant Node_Id
:= First
(Expressions
(N
));
941 Lib_RE
: constant RE_Id
:= RE_Put_Image_Unknown
;
942 Libent
: constant Entity_Id
:= RTE
(Lib_RE
);
945 Make_Procedure_Call_Statement
(Loc
,
946 Name
=> New_Occurrence_Of
(Libent
, Loc
),
947 Parameter_Associations
=> New_List
(
948 Relocate_Node
(Sink
),
949 Make_String_Literal
(Loc
,
950 Exp_Util
.Fully_Qualified_Name_String
(
951 Entity
(Prefix
(N
)), Append_NUL
=> False))));
952 end Build_Unknown_Put_Image_Call
;
954 ----------------------
955 -- Enable_Put_Image --
956 ----------------------
958 function Enable_Put_Image
(Typ
: Entity_Id
) return Boolean is
960 -- If this function returns False for a non-scalar type Typ, then
961 -- a) calls to Typ'Image will result in calls to
962 -- System.Put_Images.Put_Image_Unknown to generate the image.
963 -- b) If Typ is a tagged type, then similarly the implementation
964 -- of Typ's Put_Image procedure will call Put_Image_Unknown
965 -- and will ignore its formal parameter of type Typ.
966 -- Note that Typ will still have a Put_Image procedure
967 -- in this case, albeit one with a simplified implementation.
969 -- The name "Sink" here is a short nickname for
970 -- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
972 -- Put_Image does not work for Remote_Types. We check the containing
973 -- package, rather than the type itself, because we want to include
974 -- types in the private part of a Remote_Types package.
976 if Is_Remote_Types
(Scope
(Typ
))
977 or else Is_Remote_Call_Interface
(Typ
)
978 or else (Is_Tagged_Type
(Typ
) and then In_Predefined_Unit
(Typ
))
983 -- No sense in generating code for Put_Image if there are errors. This
984 -- avoids certain cascade errors.
986 if Total_Errors_Detected
> 0 then
990 -- If type Sink is unavailable in this runtime, disable Put_Image
993 if No_Run_Time_Mode
or else not RTE_Available
(RE_Root_Buffer_Type
) then
997 -- ???Disable Put_Image on type Root_Buffer_Type declared in
998 -- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
999 -- Ada_Strings_Text_Buffers, because it's not known yet (we might be
1000 -- compiling it). But this is insufficient to allow support for tagged
1001 -- predefined types.
1004 Parent_Scope
: constant Entity_Id
:= Scope
(Scope
(Typ
));
1006 if Present
(Parent_Scope
)
1007 and then Is_RTU
(Parent_Scope
, Ada_Strings
)
1008 and then Chars
(Scope
(Typ
)) = Name_Find
("text_buffers")
1014 -- Disable for CPP types, because the components are unavailable on the
1017 if Is_Tagged_Type
(Typ
)
1018 and then Convention
(Typ
) = Convention_CPP
1019 and then Is_CPP_Class
(Root_Type
(Typ
))
1024 -- Disable for unchecked unions, because there is no way to know the
1025 -- discriminant value, and therefore no way to know which components
1026 -- should be printed.
1028 if Is_Unchecked_Union
(Typ
) then
1033 end Enable_Put_Image
;
1035 -------------------------
1036 -- Make_Put_Image_Name --
1037 -------------------------
1039 function Make_Put_Image_Name
1040 (Loc
: Source_Ptr
; Typ
: Entity_Id
) return Entity_Id
1044 -- For tagged types, we are dealing with a TSS associated with the
1045 -- declaration, so we use the standard primitive function name. For
1046 -- other types, generate a local TSS name since we are generating
1047 -- the subprogram at the point of use.
1049 if Is_Tagged_Type
(Typ
) then
1050 Sname
:= Make_TSS_Name
(Typ
, TSS_Put_Image
);
1052 Sname
:= Make_TSS_Name_Local
(Typ
, TSS_Put_Image
);
1055 return Make_Defining_Identifier
(Loc
, Sname
);
1056 end Make_Put_Image_Name
;
1058 ---------------------------------
1059 -- Image_Should_Call_Put_Image --
1060 ---------------------------------
1062 function Image_Should_Call_Put_Image
(N
: Node_Id
) return Boolean is
1064 if Ada_Version
< Ada_2022
then
1068 -- In Ada 2022, T'Image calls T'Put_Image if there is an explicit
1069 -- (or inherited) aspect_specification for Put_Image, or if
1070 -- U_Type'Image is illegal in pre-2022 versions of Ada.
1073 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Prefix
(N
)));
1075 if Has_Aspect
(U_Type
, Aspect_Put_Image
) then
1079 return not Is_Scalar_Type
(U_Type
);
1081 end Image_Should_Call_Put_Image
;
1083 ----------------------
1084 -- Build_Image_Call --
1085 ----------------------
1087 function Build_Image_Call
(N
: Node_Id
) return Node_Id
is
1088 -- For T'[[Wide_]Wide_]Image (X) Generate an Expression_With_Actions
1093 -- U_Type'Put_Image (S, X);
1094 -- Result : constant [[Wide_]Wide_]String :=
1095 -- [[Wide_[Wide_]]Get (S);
1099 -- where U_Type is the underlying type, as needed to bypass privacy.
1101 Loc
: constant Source_Ptr
:= Sloc
(N
);
1102 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Prefix
(N
)));
1103 Sink_Entity
: constant Entity_Id
:=
1104 Make_Temporary
(Loc
, 'S');
1105 Sink_Decl
: constant Node_Id
:=
1106 Make_Object_Declaration
(Loc
,
1107 Defining_Identifier
=> Sink_Entity
,
1108 Object_Definition
=>
1109 New_Occurrence_Of
(RTE
(RE_Buffer_Type
), Loc
));
1111 Image_Prefix
: constant Node_Id
:=
1112 Duplicate_Subexpr
(First
(Expressions
(N
)));
1114 Put_Im
: constant Node_Id
:=
1115 Make_Attribute_Reference
(Loc
,
1116 Prefix
=> New_Occurrence_Of
(U_Type
, Loc
),
1117 Attribute_Name
=> Name_Put_Image
,
1118 Expressions
=> New_List
(
1119 New_Occurrence_Of
(Sink_Entity
, Loc
),
1121 Result_Entity
: constant Entity_Id
:=
1122 Make_Temporary
(Loc
, 'R');
1124 subtype Image_Name_Id
is Name_Id
with Static_Predicate
=>
1125 Image_Name_Id
in Name_Image | Name_Wide_Image | Name_Wide_Wide_Image
;
1126 -- Attribute names that will be mapped to the corresponding result types
1129 Attribute_Name_Id
: constant Name_Id
:= Attribute_Name
(N
);
1131 Result_Typ
: constant Entity_Id
:=
1132 (case Image_Name_Id
'(Attribute_Name_Id) is
1133 when Name_Image => Stand.Standard_String,
1134 when Name_Wide_Image => Stand.Standard_Wide_String,
1135 when Name_Wide_Wide_Image => Stand.Standard_Wide_Wide_String);
1136 Get_Func_Id : constant RE_Id :=
1137 (case Image_Name_Id'(Attribute_Name_Id
) is
1138 when Name_Image
=> RE_Get
,
1139 when Name_Wide_Image
=> RE_Wide_Get
,
1140 when Name_Wide_Wide_Image
=> RE_Wide_Wide_Get
);
1142 Result_Decl
: constant Node_Id
:=
1143 Make_Object_Declaration
(Loc
,
1144 Defining_Identifier
=> Result_Entity
,
1145 Object_Definition
=>
1146 New_Occurrence_Of
(Result_Typ
, Loc
),
1148 Make_Function_Call
(Loc
,
1149 Name
=> New_Occurrence_Of
(RTE
(Get_Func_Id
), Loc
),
1150 Parameter_Associations
=> New_List
(
1151 New_Occurrence_Of
(Sink_Entity
, Loc
))));
1154 function Put_String_Exp
(String_Exp
: Node_Id
;
1155 Wide_Wide
: Boolean := False) return Node_Id
;
1156 -- Generate a call to evaluate a String (or Wide_Wide_String, depending
1157 -- on the Wide_Wide Boolean parameter) expression and output it into
1160 --------------------
1161 -- Put_String_Exp --
1162 --------------------
1164 function Put_String_Exp
(String_Exp
: Node_Id
;
1165 Wide_Wide
: Boolean := False) return Node_Id
is
1166 Put_Id
: constant RE_Id
:=
1167 (if Wide_Wide
then RE_Wide_Wide_Put
else RE_Put_UTF_8
);
1169 -- We could build a nondispatching call here, but to make
1170 -- that work we'd have to change Rtsfind spec to make available
1171 -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded
1172 -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to
1173 -- introduce a type conversion and leave it to the optimizer to
1174 -- eliminate the dispatching. This does not *introduce* any problems
1175 -- if a no-dispatching-allowed restriction is in effect, since we
1176 -- are already in the middle of generating a call to T'Class'Image.
1178 Sink_Exp
: constant Node_Id
:=
1179 Make_Type_Conversion
(Loc
,
1182 (Class_Wide_Type
(RTE
(RE_Root_Buffer_Type
)), Loc
),
1183 Expression
=> New_Occurrence_Of
(Sink_Entity
, Loc
));
1186 Make_Procedure_Call_Statement
(Loc
,
1187 Name
=> New_Occurrence_Of
(RTE
(Put_Id
), Loc
),
1188 Parameter_Associations
=> New_List
(Sink_Exp
, String_Exp
));
1191 -- Start of processing for Build_Image_Call
1194 if Is_Class_Wide_Type
(U_Type
) then
1195 -- Generate qualified-expression syntax; qualification name comes
1196 -- from calling Ada.Tags.Wide_Wide_Expanded_Name.
1199 -- The copy of Image_Prefix will be evaluated before the
1200 -- original, which is ok if no side effects are involved.
1202 pragma Assert
(Side_Effect_Free
(Image_Prefix
));
1204 Specific_Type_Name
: constant Node_Id
:=
1206 (Make_Function_Call
(Loc
,
1207 Name
=> New_Occurrence_Of
1208 (RTE
(RE_Wide_Wide_Expanded_Name
), Loc
),
1209 Parameter_Associations
=> New_List
(
1210 Make_Attribute_Reference
(Loc
,
1211 Prefix
=> Duplicate_Subexpr
(Image_Prefix
),
1212 Attribute_Name
=> Name_Tag
))),
1215 Qualification
: constant Node_Id
:=
1216 Put_String_Exp
(Make_String_Literal
(Loc
, "'"));
1226 Actions
:= New_List
(Sink_Decl
, Put_Im
, Result_Decl
);
1229 return Make_Expression_With_Actions
(Loc
,
1231 Expression
=> New_Occurrence_Of
(Result_Entity
, Loc
));
1232 end Build_Image_Call
;
1234 ------------------------------
1235 -- Preload_Root_Buffer_Type --
1236 ------------------------------
1238 procedure Preload_Root_Buffer_Type
(Compilation_Unit
: Node_Id
) is
1240 -- We can't call RTE (RE_Root_Buffer_Type) for at least some
1241 -- predefined units, because it would introduce cyclic dependences.
1242 -- The package where Root_Buffer_Type is declared, for example, and
1243 -- things it depends on.
1245 -- It's only needed for tagged types, so don't do it unless Put_Image is
1246 -- enabled for tagged types, and we've seen a tagged type. Note that
1247 -- Tagged_Seen is set True by the parser if the "tagged" reserved word
1248 -- is seen; this flag tells us whether we have any tagged types.
1249 -- It's unfortunate to have this Tagged_Seen processing so scattered
1250 -- about, but we need to know if there are tagged types where this is
1251 -- called in Analyze_Compilation_Unit, before we have analyzed any type
1252 -- declarations. This mechanism also prevents doing
1253 -- RTE (RE_Root_Buffer_Type) when compiling the compiler itself.
1254 -- Packages Ada.Strings.Buffer_Types and friends are not included
1257 -- Don't do it if type Root_Buffer_Type is unavailable in the runtime.
1259 if not In_Predefined_Unit
(Compilation_Unit
)
1260 and then Tagged_Seen
1261 and then not No_Run_Time_Mode
1262 and then RTE_Available
(RE_Root_Buffer_Type
)
1265 Ignore
: constant Entity_Id
:= RTE
(RE_Root_Buffer_Type
);
1270 end Preload_Root_Buffer_Type
;
1272 -------------------------
1273 -- Put_Image_Base_Type --
1274 -------------------------
1276 function Put_Image_Base_Type
(E
: Entity_Id
) return Entity_Id
is
1278 if Is_Array_Type
(E
) and then Is_First_Subtype
(E
) then
1281 return Base_Type
(E
);
1283 end Put_Image_Base_Type
;