]> gcc.gnu.org Git - gcc.git/blame - gcc/ada/exp_put_image.adb
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
ada: Support Put_Image for types in user-defined instances of predefined generics.
[gcc.git] / gcc / ada / exp_put_image.adb
CommitLineData
110d0820
BD		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- E X P _ P U T _ I M A G E --
6-- --
7-- B o d y --
8-- --
cccef051 9-- Copyright (C) 2020-2023, Free Software Foundation, Inc. --
110d0820
BD		 10-- --
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. --
20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc. --
23-- --
24------------------------------------------------------------------------------
25
b4b023c4 26with Aspects; use Aspects;
104f58db 27with Atree; use Atree;
b4b023c4 28with Csets; use Csets;
104f58db 29with Einfo; use Einfo;
76f9c7f4 30with Einfo.Entities; use Einfo.Entities;
104f58db
BD		 31with Einfo.Utils; use Einfo.Utils;
32with Exp_Tss; use Exp_Tss;
b4b023c4 33with Exp_Util; use Exp_Util;
104f58db
BD		 34with Lib; use Lib;
35with Namet; use Namet;
36with Nlists; use Nlists;
37with Nmake; use Nmake;
38with Opt; use Opt;
39with Rtsfind; use Rtsfind;
40with Sem_Aux; use Sem_Aux;
41with Sem_Util; use Sem_Util;
42with Sinfo; use Sinfo;
43with Sinfo.Nodes; use Sinfo.Nodes;
44with Sinfo.Utils; use Sinfo.Utils;
45with Snames; use Snames;
110d0820 46with Stand;
09768159 47with Stringt; use Stringt;
104f58db
BD		 48with Tbuild; use Tbuild;
49with Ttypes; use Ttypes;
50with Uintp; use Uintp;
110d0820
BD		 51
52package body Exp_Put_Image is
53
54 -----------------------
55 -- Local Subprograms --
56 -----------------------
57
58 procedure Build_Put_Image_Proc
59 (Loc : Source_Ptr;
60 Typ : Entity_Id;
61 Decl : out Node_Id;
62 Pnam : Entity_Id;
63 Stms : List_Id);
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.)
67
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.
75
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.
79
80 -------------------------------------
81 -- Build_Array_Put_Image_Procedure --
82 -------------------------------------
83
84 procedure Build_Array_Put_Image_Procedure
85 (Nod : Node_Id;
86 Typ : Entity_Id;
87 Decl : out Node_Id;
88 Pnam : out Entity_Id)
89 is
90 Loc : constant Source_Ptr := Sloc (Nod);
91
92 function Wrap_In_Loop
93 (Stms : List_Id;
94 Dim : Pos;
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:
98 --
99 -- if V'First (Dim) <= V'Last (Dim) then -- nonempty range?
100 -- declare
101 -- LDim : Index_Type_For_Dim := V'First (Dim);
102 -- begin
103 -- loop
104 -- Stms;
105 -- exit when LDim = V'Last (Dim);
106 -- Between_Proc (S);
107 -- LDim := Index_Type_For_Dim'Succ (LDim);
108 -- end loop;
109 -- end;
110 -- end if;
111 --
112 -- This is called once per dimension, from inner to outer.
113
114 function Wrap_In_Loop
115 (Stms : List_Id;
116 Dim : Pos;
117 Index_Subtype : Entity_Id;
118 Between_Proc : RE_Id) return Node_Id
119 is
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,
126 Object_Definition =>
127 New_Occurrence_Of (Index_Subtype, Loc),
128 Expression =>
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,
138 Condition =>
139 Make_Op_Eq (Loc,
140 Left_Opnd => New_Occurrence_Of (Index, Loc),
141 Right_Opnd =>
142 Make_Attribute_Reference (Loc,
143 Prefix =>
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,
152 Name =>
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)));
162 begin
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
167
168 return
169 Make_If_Statement (Loc,
170 Condition =>
171 Make_Op_Le (Loc,
172 Left_Opnd =>
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))),
178 Right_Opnd =>
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));
185 end Wrap_In_Loop;
186
187 Ndim : constant Pos := Number_Dimensions (Typ);
188 Ctyp : constant Entity_Id := Component_Type (Typ);
189
190 Stm : Node_Id;
191 Exl : constant List_Id := New_List;
192 PI_Entity : Entity_Id;
193
194 Indices : array (1 .. Ndim) of Entity_Id;
195
196 -- Start of processing for Build_Array_Put_Image_Procedure
197
198 begin
199 Pnam :=
200 Make_Defining_Identifier (Loc,
201 Chars => Make_TSS_Name_Local (Typ, TSS_Put_Image));
202
203 -- Get the Indices
204
205 declare
206 Index_Subtype : Node_Id := First_Index (Typ);
207 begin
208 for Dim in 1 .. Ndim loop
209 Indices (Dim) := Etype (Index_Subtype);
210 Next_Index (Index_Subtype);
211 end loop;
212 pragma Assert (No (Index_Subtype));
213 end;
214
215 -- Build the inner attribute call
216
217 for Dim in 1 .. Ndim loop
218 Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim)));
219 end loop;
220
221 Stm :=
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)));
230
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
235 -- case.
236
237 PI_Entity := TSS (Base_Type (Ctyp), TSS_Put_Image);
238
239 if Present (PI_Entity) and then not Is_Frozen (PI_Entity) then
240 Set_Is_Frozen (PI_Entity);
241 end if;
242
243 -- Loop through the dimensions, innermost first, generating a loop for
244 -- each dimension.
245
246 declare
247 Stms : List_Id := New_List (Stm);
248 begin
249 for Dim in reverse 1 .. Ndim loop
250 declare
251 New_Stms : constant List_Id := New_List;
252 Between_Proc : RE_Id;
253 begin
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.
257
258 if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
259 Between_Proc := RE_Simple_Array_Between;
260 else
261 Between_Proc := RE_Array_Between;
262 end if;
263
264 Append_To (New_Stms,
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))));
269
270 Append_To
271 (New_Stms,
272 Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
273
274 Append_To (New_Stms,
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))));
279
280 Stms := New_Stms;
281 end;
282 end loop;
283
284 Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
285 end;
286 end Build_Array_Put_Image_Procedure;
287
288 -------------------------------------
289 -- Build_Elementary_Put_Image_Call --
290 -------------------------------------
291
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);
300 Lib_RE : RE_Id;
301
302 begin
303 if Is_Signed_Integer_Type (U_Type) then
304 if P_Size <= Standard_Integer_Size then
305 Lib_RE := RE_Put_Image_Integer;
cb7584a4 306 elsif P_Size <= Standard_Long_Long_Integer_Size then
110d0820 307 Lib_RE := RE_Put_Image_Long_Long_Integer;
cb7584a4
EB		 308 else
309 pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
310 Lib_RE := RE_Put_Image_Long_Long_Long_Integer;
110d0820
BD		 311 end if;
312
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;
cb7584a4 316 elsif P_Size <= Standard_Long_Long_Integer_Size then
110d0820 317 Lib_RE := RE_Put_Image_Long_Long_Unsigned;
cb7584a4
EB		 318 else
319 pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
320 Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned;
110d0820
BD		 321 end if;
322
323 elsif Is_Access_Type (U_Type) then
26349b6d 324 if Is_Access_Protected_Subprogram_Type (Base_Type (U_Type)) then
6a920eb5 325 Lib_RE := RE_Put_Image_Access_Prot_Subp;
26349b6d 326 elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then
bfdb362c
BD		 327 Lib_RE := RE_Put_Image_Access_Subp;
328 elsif P_Size = System_Address_Size then
110d0820
BD		 329 Lib_RE := RE_Put_Image_Thin_Pointer;
330 else
331 pragma Assert (P_Size = 2 * System_Address_Size);
332 Lib_RE := RE_Put_Image_Fat_Pointer;
333 end if;
334
335 else
336 pragma Assert
337 (Is_Enumeration_Type (U_Type) or else Is_Real_Type (U_Type));
338
339 -- For other elementary types, generate:
340 --
9ef547a7
JM		 341 -- Wide_Wide_Put (Root_Buffer_Type'Class (Sink),
342 -- U_Type'Wide_Wide_Image (Item));
110d0820 343 --
a91b9833
BD		 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.
350
351 -- We can't do this:
110d0820
BD		 352 --
353 -- Put_UTF_8 (Sink, U_Type'Image (Item));
354 --
355 -- because we need to generate UTF-8, but 'Image for enumeration
356 -- types uses the character encoding of the source file.
357 --
358 -- Note that this is putting a leading space for reals.
359
360 declare
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)));
9ef547a7
JM		 366 Sink_Exp : constant Node_Id :=
367 Make_Type_Conversion (Loc,
368 Subtype_Mark =>
369 New_Occurrence_Of
370 (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc),
371 Expression => Relocate_Node (Sink));
d84eb7c5 372 Put_Call : constant Node_Id :=
110d0820
BD		 373 Make_Procedure_Call_Statement (Loc,
374 Name =>
20922782 375 New_Occurrence_Of (RTE (RE_Wide_Wide_Put), Loc),
110d0820 376 Parameter_Associations => New_List
9ef547a7 377 (Sink_Exp, Image));
d84eb7c5 378 begin
9ef547a7
JM		 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.
382
d84eb7c5 383 return Put_Call;
110d0820
BD		 384 end;
385 end if;
386
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
d84eb7c5 390 -- "unchecked" is needed for access and private types.
110d0820
BD		 391
392 declare
393 Libent : constant Entity_Id := RTE (Lib_RE);
394 begin
395 return
396 Make_Procedure_Call_Statement (Loc,
397 Name => New_Occurrence_Of (Libent, Loc),
398 Parameter_Associations => New_List (
399 Relocate_Node (Sink),
400 Unchecked_Convert_To
401 (Etype (Next_Formal (First_Formal (Libent))),
402 Relocate_Node (Item))));
403 end;
404 end Build_Elementary_Put_Image_Call;
405
406 -------------------------------------
407 -- Build_String_Put_Image_Call --
408 -------------------------------------
409
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);
417 Lib_RE : RE_Id;
418 use Stand;
419 begin
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;
426 else
427 raise Program_Error;
428 end if;
429
430 -- Convert parameter to the required type (i.e. the type of the
431 -- corresponding parameter), and call the appropriate routine.
eb725219 432 -- We set the Conversion_OK flag in case the type is private.
110d0820
BD		 433
434 declare
435 Libent : constant Entity_Id := RTE (Lib_RE);
eb725219
BD		 436 Conv : constant Node_Id :=
437 OK_Convert_To
438 (Etype (Next_Formal (First_Formal (Libent))),
439 Relocate_Node (Item));
110d0820 440 begin
9ef547a7
JM		 441 -- Do not output string delimiters if this is part of an
442 -- interpolated string literal.
443
444 if Nkind (Parent (N)) = N_Expression_With_Actions
445 and then Nkind (Original_Node (Parent (N)))
446 = N_Interpolated_String_Literal
447 then
448 return
449 Make_Procedure_Call_Statement (Loc,
450 Name => New_Occurrence_Of (Libent, Loc),
451 Parameter_Associations => New_List (
452 Relocate_Node (Sink),
453 Conv,
454 New_Occurrence_Of (Stand.Standard_False, Loc)));
455 else
456 return
457 Make_Procedure_Call_Statement (Loc,
458 Name => New_Occurrence_Of (Libent, Loc),
459 Parameter_Associations => New_List (
460 Relocate_Node (Sink),
461 Conv));
462 end if;
110d0820
BD		 463 end;
464 end Build_String_Put_Image_Call;
465
466 ------------------------------------
467 -- Build_Protected_Put_Image_Call --
468 ------------------------------------
469
470 -- For "Protected_Type'Put_Image (S, Protected_Object)", build:
471 --
472 -- Put_Image_Protected (S);
473 --
474 -- The protected object is not passed.
475
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);
481 begin
482 return
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;
488
489 ------------------------------------
490 -- Build_Task_Put_Image_Call --
491 ------------------------------------
492
493 -- For "Task_Type'Put_Image (S, Task_Object)", build:
494 --
495 -- Put_Image_Task (S, Task_Object'Identity);
496 --
497 -- The task object is not passed; its Task_Id is.
498
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);
505
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);
511
512 begin
513 return
514 Make_Procedure_Call_Statement (Loc,
515 Name => New_Occurrence_Of (Libent, Loc),
516 Parameter_Associations => New_List (
517 Relocate_Node (Sink),
518 Task_Id));
519 end Build_Task_Put_Image_Call;
520
521 --------------------------------------
522 -- Build_Record_Put_Image_Procedure --
523 --------------------------------------
524
525 -- The form of the record Put_Image procedure is as shown by the
526 -- following example:
527
528 -- procedure Put_Image (S : in out Sink'Class; V : Typ) is
529 -- begin
530 -- Component_Type'Put_Image (S, V.component);
531 -- Component_Type'Put_Image (S, V.component);
532 -- ...
533 -- Component_Type'Put_Image (S, V.component);
534 --
535 -- case V.discriminant is
536 -- when choices =>
537 -- Component_Type'Put_Image (S, V.component);
538 -- Component_Type'Put_Image (S, V.component);
539 -- ...
540 -- Component_Type'Put_Image (S, V.component);
541 --
542 -- when choices =>
543 -- Component_Type'Put_Image (S, V.component);
544 -- Component_Type'Put_Image (S, V.component);
545 -- ...
546 -- Component_Type'Put_Image (S, V.component);
547 -- ...
548 -- end case;
549 -- end Put_Image;
550
551 procedure Build_Record_Put_Image_Procedure
552 (Loc : Source_Ptr;
553 Typ : Entity_Id;
554 Decl : out Node_Id;
555 Pnam : out Entity_Id)
556 is
1e29b546 557 Btyp : constant Entity_Id := Base_Type (Typ);
09768159 558 pragma Assert (not Is_Class_Wide_Type (Btyp));
1e29b546 559 pragma Assert (not Is_Unchecked_Union (Btyp));
110d0820
BD		 560
561 First_Time : Boolean := True;
562
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
567 -- variants.
568
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).
575
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.
580
581 function Make_Component_Name (C : Entity_Id) return Node_Id;
582 -- Create a call that prints "Comp_Name => "
583
584 ------------------------------------
585 -- Make_Component_List_Attributes --
586 ------------------------------------
587
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);
591
592 Result : List_Id;
593 Alts : List_Id;
594 V : Node_Id;
595 DC : Node_Id;
596 DCH : List_Id;
597 D_Ref : Node_Id;
598
599 begin
600 Result := Make_Component_Attributes (CI);
601
602 if Present (VP) then
603 Alts := New_List;
604
605 V := First_Non_Pragma (Variants (VP));
606 while Present (V) loop
607 DCH := New_List;
608
609 DC := First (Discrete_Choices (V));
610 while Present (DC) loop
611 Append_To (DCH, New_Copy_Tree (DC));
612 Next (DC);
613 end loop;
614
615 Append_To (Alts,
616 Make_Case_Statement_Alternative (Loc,
617 Discrete_Choices => DCH,
618 Statements =>
619 Make_Component_List_Attributes (Component_List (V))));
620 Next_Non_Pragma (V);
621 end loop;
622
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.
626
eb725219
BD		 627 D_Ref :=
628 Make_Selected_Component (Loc,
629 Prefix => Make_Identifier (Loc, Name_V),
630 Selector_Name =>
631 New_Occurrence_Of (Entity (Name (VP)), Loc));
110d0820
BD		 632
633 Append_To (Result,
634 Make_Case_Statement (Loc,
635 Expression => D_Ref,
636 Alternatives => Alts));
637 end if;
638
639 return Result;
640 end Make_Component_List_Attributes;
641
642 --------------------------------
643 -- Append_Component_Attr --
644 --------------------------------
645
646 procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
647 Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
648 begin
c324c77e 649 if Ekind (C) /= E_Void then
110d0820
BD		 650 Append_To (Clist,
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)))));
659 end if;
660 end Append_Component_Attr;
661
662 -------------------------------
663 -- Make_Component_Attributes --
664 -------------------------------
665
666 function Make_Component_Attributes (Clist : List_Id) return List_Id is
667 Item : Node_Id;
668 Result : List_Id;
669
670 begin
671 Result := New_List;
672
673 if Present (Clist) then
674 Item := First (Clist);
675
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
b4b023c4 679 -- recursively.
110d0820
BD		 680
681 while Present (Item) loop
4a08c95c
AC		 682 if Nkind (Item) in
683 N_Component_Declaration | N_Discriminant_Specification
110d0820 684 then
b4b023c4
SB		 685 if Chars (Defining_Identifier (Item)) = Name_uParent then
686 declare
687 Parent_Type : constant Entity_Id :=
f377685e
BD		 688 Implementation_Base_Type
689 (Etype (Defining_Identifier (Item)));
b4b023c4
SB		 690
691 Parent_Aspect_Spec : constant Node_Id :=
692 Find_Aspect (Parent_Type, Aspect_Put_Image);
693
694 Parent_Type_Decl : constant Node_Id :=
695 Declaration_Node (Parent_Type);
696
697 Parent_Rdef : Node_Id :=
698 Type_Definition (Parent_Type_Decl);
699 begin
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.
708
709 if Present (Parent_Aspect_Spec) and then
710 Entity (Parent_Aspect_Spec) = Parent_Type
711 then
712 Append_Component_Attr
713 (Result, Defining_Identifier (Item));
714
715 -- Omit the " with " if no subsequent components.
716
717 if not Is_Null_Extension_Of
718 (Descendant => Typ,
719 Ancestor => Parent_Type)
720 then
721 Append_To (Result,
722 Make_Procedure_Call_Statement (Loc,
723 Name =>
724 New_Occurrence_Of
725 (RTE (RE_Put_UTF_8), Loc),
726 Parameter_Associations => New_List
727 (Make_Identifier (Loc, Name_S),
728 Make_String_Literal (Loc, " with "))));
729 end if;
730 else
731 if Nkind (Parent_Rdef) = N_Derived_Type_Definition
732 then
733 Parent_Rdef :=
734 Record_Extension_Part (Parent_Rdef);
735 end if;
736
737 if Present (Component_List (Parent_Rdef)) then
738 Append_List_To (Result,
739 Make_Component_List_Attributes
740 (Component_List (Parent_Rdef)));
741 end if;
742 end if;
743 end;
744
745 elsif not Is_Internal_Name
746 (Chars (Defining_Identifier (Item)))
747 then
748 if First_Time then
749 First_Time := False;
750 else
751 Append_To (Result,
752 Make_Procedure_Call_Statement (Loc,
753 Name =>
754 New_Occurrence_Of (RTE (RE_Record_Between), Loc),
755 Parameter_Associations => New_List
756 (Make_Identifier (Loc, Name_S))));
757 end if;
758
759 Append_To (Result, Make_Component_Name (Item));
760 Append_Component_Attr
761 (Result, Defining_Identifier (Item));
110d0820 762 end if;
110d0820
BD		 763 end if;
764
765 Next (Item);
766 end loop;
767 end if;
768
769 return Result;
770 end Make_Component_Attributes;
771
772 -------------------------
773 -- Make_Component_Name --
774 -------------------------
775
776 function Make_Component_Name (C : Entity_Id) return Node_Id is
777 Name : constant Name_Id := Chars (Defining_Identifier (C));
b4b023c4
SB		 778 pragma Assert (Name /= Name_uParent);
779
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.
783
784 --------------
785 -- To_Upper --
786 --------------
787
788 function To_Upper (S : String) return String is
789 begin
790 return Result : String := S do
791 for Char of Result loop
792 Char := Fold_Upper (Char);
793 end loop;
794 end return;
795 end To_Upper;
796
797 -- Start of processing for Make_Component_Name
798
110d0820
BD		 799 begin
800 return
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),
b4b023c4
SB		 805 Make_String_Literal (Loc,
806 To_Upper (Get_Name_String (Name)) & " => ")));
110d0820
BD		 807 end Make_Component_Name;
808
809 Stms : constant List_Id := New_List;
810 Rdef : Node_Id;
a91b9833 811 Type_Decl : constant Node_Id :=
1e29b546 812 Declaration_Node (Base_Type (Underlying_Type (Btyp)));
110d0820
BD		 813
814 -- Start of processing for Build_Record_Put_Image_Procedure
815
816 begin
8f563162 817 if Ada_Version < Ada_2022
46640baf 818 or else not Put_Image_Enabled (Btyp)
09768159
SB		 819 then
820 -- generate a very simple Put_Image implementation
821
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.
825
826 Append_To (Stms,
827 Make_Raise_Program_Error (Loc,
828 Reason => PE_Explicit_Raise));
829 else
830 Append_To (Stms,
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))))));
837 end if;
838 elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
839
840 -- Interface types take this path.
841
b4b023c4
SB		 842 Append_To (Stms,
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)"))));
46640baf
PO		 848
849 elsif Is_Derived_Type (Btyp)
850 and then (not Is_Tagged_Type (Btyp) or else Is_Null_Extension (Btyp))
851 then
852 declare
853 Parent_Type : constant Entity_Id := Base_Type (Etype (Btyp));
854 begin
855 Append_To (Stms,
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
863 (Parent_Type, Loc),
864 Expression => Make_Identifier
865 (Loc, Name_V)))));
866 end;
867
b4b023c4
SB		 868 else
869 Append_To (Stms,
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))));
110d0820 874
b4b023c4 875 -- Generate Put_Images for the discriminants of the type
110d0820 876
b4b023c4
SB		 877 Append_List_To (Stms,
878 Make_Component_Attributes
879 (Discriminant_Specifications (Type_Decl)));
110d0820 880
b4b023c4 881 Rdef := Type_Definition (Type_Decl);
110d0820 882
b4b023c4
SB		 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).
110d0820 886
b4b023c4
SB		 887 if Nkind (Rdef) = N_Derived_Type_Definition then
888 Rdef := Record_Extension_Part (Rdef);
889 end if;
110d0820 890
b4b023c4
SB		 891 if Present (Component_List (Rdef)) then
892 Append_List_To (Stms,
893 Make_Component_List_Attributes (Component_List (Rdef)));
894 end if;
110d0820 895
b4b023c4
SB		 896 Append_To (Stms,
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))));
901 end if;
110d0820 902
1e29b546
BD		 903 Pnam := Make_Put_Image_Name (Loc, Btyp);
904 Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
110d0820
BD		 905 end Build_Record_Put_Image_Procedure;
906
907 -------------------------------
908 -- Build_Put_Image_Profile --
909 -------------------------------
910
911 function Build_Put_Image_Profile
912 (Loc : Source_Ptr; Typ : Entity_Id) return List_Id
913 is
914 begin
915 return New_List (
916 Make_Parameter_Specification (Loc,
917 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
918 In_Present => True,
919 Out_Present => True,
920 Parameter_Type =>
20922782
SB		 921 New_Occurrence_Of
922 (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc)),
110d0820
BD		 923
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;
928
929 --------------------------
930 -- Build_Put_Image_Proc --
931 --------------------------
932
933 procedure Build_Put_Image_Proc
934 (Loc : Source_Ptr;
935 Typ : Entity_Id;
936 Decl : out Node_Id;
937 Pnam : Entity_Id;
938 Stms : List_Id)
939 is
940 Spec : constant Node_Id :=
941 Make_Procedure_Specification (Loc,
942 Defining_Unit_Name => Pnam,
943 Parameter_Specifications => Build_Put_Image_Profile (Loc, Typ));
944 begin
945 Decl :=
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;
953
954 ------------------------------------
955 -- Build_Unknown_Put_Image_Call --
956 ------------------------------------
957
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);
963 begin
964 return
965 Make_Procedure_Call_Statement (Loc,
966 Name => New_Occurrence_Of (Libent, Loc),
967 Parameter_Associations => New_List (
d84eb7c5
BD		 968 Relocate_Node (Sink),
969 Make_String_Literal (Loc,
970 Exp_Util.Fully_Qualified_Name_String (
971 Entity (Prefix (N)), Append_NUL => False))));
110d0820
BD		 972 end Build_Unknown_Put_Image_Call;
973
46640baf
PO		 974 -----------------------
975 -- Put_Image_Enabled --
976 -----------------------
110d0820 977
46640baf 978 function Put_Image_Enabled (Typ : Entity_Id) return Boolean is
110d0820 979 begin
09768159
SB		 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.
988 --
20922782
SB		 989 -- The name "Sink" here is a short nickname for
990 -- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
c324c77e 991 --
46640baf 992
c324c77e
BD		 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.
a91b9833 996
09768159
SB		 997 if Is_Remote_Types (Scope (Typ))
998 or else Is_Remote_Call_Interface (Typ)
c324c77e 999 then
a91b9833
BD		 1000 return False;
1001 end if;
1002
a3483a77
BD		 1003 -- No sense in generating code for Put_Image if there are errors. This
1004 -- avoids certain cascade errors.
1005
1006 if Total_Errors_Detected > 0 then
1007 return False;
1008 end if;
1009
1010 -- If type Sink is unavailable in this runtime, disable Put_Image
1011 -- altogether.
1012
20922782 1013 if No_Run_Time_Mode or else not RTE_Available (RE_Root_Buffer_Type) then
a3483a77
BD		 1014 return False;
1015 end if;
1016
46640baf
PO		 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))
1022 then
1023 null;
1024 elsif Is_Derived_Type (Typ) then
1025 return Put_Image_Enabled (Etype (Base_Type (Typ)));
262229e1 1026 elsif Is_Predefined_Unit (Get_Code_Unit (Typ)) then
46640baf
PO		 1027 return False;
1028 end if;
1029 end if;
1030
20922782
SB		 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
110d0820
BD		 1034 -- compiling it). But this is insufficient to allow support for tagged
1035 -- predefined types.
1036
1037 declare
c324c77e 1038 Parent_Scope : constant Entity_Id := Scope (Scope (Typ));
110d0820
BD		 1039 begin
1040 if Present (Parent_Scope)
1041 and then Is_RTU (Parent_Scope, Ada_Strings)
20922782 1042 and then Chars (Scope (Typ)) = Name_Find ("text_buffers")
110d0820
BD		 1043 then
1044 return False;
1045 end if;
1046 end;
1047
05f799de
BD		 1048 -- Disable for CPP types, because the components are unavailable on the
1049 -- Ada side.
1050
1051 if Is_Tagged_Type (Typ)
1052 and then Convention (Typ) = Convention_CPP
1053 and then Is_CPP_Class (Root_Type (Typ))
1054 then
1055 return False;
1056 end if;
1057
eb725219
BD		 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.
1061
1062 if Is_Unchecked_Union (Typ) then
1063 return False;
1064 end if;
1065
1066 return True;
46640baf 1067 end Put_Image_Enabled;
110d0820 1068
7802ee7b 1069 -------------------------
110d0820 1070 -- Make_Put_Image_Name --
7802ee7b 1071 -------------------------
110d0820
BD		 1072
1073 function Make_Put_Image_Name
1074 (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id
1075 is
1076 Sname : Name_Id;
1077 begin
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.
1082
1083 if Is_Tagged_Type (Typ) then
1084 Sname := Make_TSS_Name (Typ, TSS_Put_Image);
1085 else
1086 Sname := Make_TSS_Name_Local (Typ, TSS_Put_Image);
1087 end if;
1088
1089 return Make_Defining_Identifier (Loc, Sname);
1090 end Make_Put_Image_Name;
1091
7802ee7b
PT		 1092 ---------------------------------
1093 -- Image_Should_Call_Put_Image --
1094 ---------------------------------
1095
acc20d25
BD		 1096 function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is
1097 begin
81e68a19 1098 if Ada_Version < Ada_2022 then
acc20d25
BD		 1099 return False;
1100 end if;
1101
81e68a19 1102 -- In Ada 2022, T'Image calls T'Put_Image if there is an explicit
748976cf
SB		 1103 -- (or inherited) aspect_specification for Put_Image, or if
1104 -- U_Type'Image is illegal in pre-2022 versions of Ada.
acc20d25
BD		 1105
1106 declare
1107 U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
1108 begin
11f89257 1109 if Has_Aspect (U_Type, Aspect_Put_Image) then
acc20d25
BD		 1110 return True;
1111 end if;
1112
1113 return not Is_Scalar_Type (U_Type);
1114 end;
1115 end Image_Should_Call_Put_Image;
1116
7802ee7b
PT		 1117 ----------------------
1118 -- Build_Image_Call --
1119 ----------------------
1120
acc20d25 1121 function Build_Image_Call (N : Node_Id) return Node_Id is
c2596d45
PT		 1122 -- For T'[[Wide_]Wide_]Image (X) Generate an Expression_With_Actions
1123 -- node:
acc20d25
BD		 1124 --
1125 -- do
b4b023c4 1126 -- S : Buffer;
acc20d25 1127 -- U_Type'Put_Image (S, X);
c2596d45
PT		 1128 -- Result : constant [[Wide_]Wide_]String :=
1129 -- [[Wide_[Wide_]]Get (S);
acc20d25
BD		 1130 -- Destroy (S);
1131 -- in Result end
1132 --
1133 -- where U_Type is the underlying type, as needed to bypass privacy.
1134
1135 Loc : constant Source_Ptr := Sloc (N);
1136 U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
1137 Sink_Entity : constant Entity_Id :=
a8d89c45 1138 Make_Temporary (Loc, 'S');
acc20d25
BD		 1139 Sink_Decl : constant Node_Id :=
1140 Make_Object_Declaration (Loc,
1141 Defining_Identifier => Sink_Entity,
1142 Object_Definition =>
20922782
SB		 1143 New_Occurrence_Of (RTE (RE_Buffer_Type), Loc));
1144
b4b023c4
SB		 1145 Image_Prefix : constant Node_Id :=
1146 Duplicate_Subexpr (First (Expressions (N)));
1147
acc20d25
BD		 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),
b4b023c4 1154 Image_Prefix));
acc20d25 1155 Result_Entity : constant Entity_Id :=
a8d89c45 1156 Make_Temporary (Loc, 'R');
c2596d45
PT		 1157
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
1161 -- and functions.
1162
53d45e49
BD		 1163 Attribute_Name_Id : constant Name_Id :=
1164 (if Attribute_Name (N) = Name_Img then Name_Image
1165 else Attribute_Name (N));
c2596d45
PT		 1166
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);
1177
acc20d25
BD		 1178 Result_Decl : constant Node_Id :=
1179 Make_Object_Declaration (Loc,
1180 Defining_Identifier => Result_Entity,
1181 Object_Definition =>
c2596d45 1182 New_Occurrence_Of (Result_Typ, Loc),
acc20d25
BD		 1183 Expression =>
1184 Make_Function_Call (Loc,
c2596d45 1185 Name => New_Occurrence_Of (RTE (Get_Func_Id), Loc),
acc20d25
BD		 1186 Parameter_Associations => New_List (
1187 New_Occurrence_Of (Sink_Entity, Loc))));
b4b023c4
SB		 1188 Actions : List_Id;
1189
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
1194 -- the buffer.
1195
1196 --------------------
1197 -- Put_String_Exp --
1198 --------------------
1199
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);
1204
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.
1213
1214 Sink_Exp : constant Node_Id :=
1215 Make_Type_Conversion (Loc,
1216 Subtype_Mark =>
1217 New_Occurrence_Of
1218 (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc),
1219 Expression => New_Occurrence_Of (Sink_Entity, Loc));
1220 begin
1221 return
1222 Make_Procedure_Call_Statement (Loc,
1223 Name => New_Occurrence_Of (RTE (Put_Id), Loc),
1224 Parameter_Associations => New_List (Sink_Exp, String_Exp));
1225 end Put_String_Exp;
1226
99b45bbe
JM		 1227 -- Local variables
1228
1229 Tag_Node : Node_Id;
1230
b4b023c4
SB		 1231 -- Start of processing for Build_Image_Call
1232
acc20d25 1233 begin
b4b023c4 1234 if Is_Class_Wide_Type (U_Type) then
99b45bbe
JM		 1235
1236 -- For interface types we must generate code to displace the pointer
1237 -- to the object to reference the base of the underlying object.
1238
1239 -- Generate:
1240 -- To_Tag_Ptr (Image_Prefix'Address).all
1241
1242 -- Note that Image_Prefix'Address is recursively expanded into a
1243 -- call to Ada.Tags.Base_Address (Image_Prefix'Address).
1244
1245 if Is_Interface (U_Type) then
1246 Tag_Node :=
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)));
1252
1253 -- Common case
1254
1255 else
1256 Tag_Node :=
1257 Make_Attribute_Reference (Loc,
1258 Prefix => Duplicate_Subexpr (Image_Prefix),
1259 Attribute_Name => Name_Tag);
1260 end if;
1261
b4b023c4
SB		 1262 -- Generate qualified-expression syntax; qualification name comes
1263 -- from calling Ada.Tags.Wide_Wide_Expanded_Name.
1264
1265 declare
1266 -- The copy of Image_Prefix will be evaluated before the
1267 -- original, which is ok if no side effects are involved.
1268
1269 pragma Assert (Side_Effect_Free (Image_Prefix));
1270
1271 Specific_Type_Name : constant Node_Id :=
1272 Put_String_Exp
1273 (Make_Function_Call (Loc,
1274 Name => New_Occurrence_Of
1275 (RTE (RE_Wide_Wide_Expanded_Name), Loc),
99b45bbe 1276 Parameter_Associations => New_List (Tag_Node)),
b4b023c4
SB		 1277 Wide_Wide => True);
1278
1279 Qualification : constant Node_Id :=
1280 Put_String_Exp (Make_String_Literal (Loc, "'"));
1281 begin
1282 Actions := New_List
1283 (Sink_Decl,
1284 Specific_Type_Name,
1285 Qualification,
1286 Put_Im,
1287 Result_Decl);
1288 end;
1289 else
1290 Actions := New_List (Sink_Decl, Put_Im, Result_Decl);
1291 end if;
1292
1293 return Make_Expression_With_Actions (Loc,
1294 Actions => Actions,
1295 Expression => New_Occurrence_Of (Result_Entity, Loc));
acc20d25
BD		 1296 end Build_Image_Call;
1297
20922782
SB		 1298 ------------------------------
1299 -- Preload_Root_Buffer_Type --
1300 ------------------------------
05f799de 1301
20922782 1302 procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id) is
05f799de 1303 begin
20922782
SB		 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.
a3483a77
BD		 1308 --
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.
eb725219
BD		 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
20922782
SB		 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
1319 -- in the compiler.
a3483a77 1320 --
20922782 1321 -- Don't do it if type Root_Buffer_Type is unavailable in the runtime.
a3483a77
BD		 1322
1323 if not In_Predefined_Unit (Compilation_Unit)
a3483a77
BD		 1324 and then Tagged_Seen
1325 and then not No_Run_Time_Mode
20922782 1326 and then RTE_Available (RE_Root_Buffer_Type)
a3483a77 1327 then
05f799de 1328 declare
20922782 1329 Ignore : constant Entity_Id := RTE (RE_Root_Buffer_Type);
05f799de
BD		 1330 begin
1331 null;
1332 end;
1333 end if;
20922782 1334 end Preload_Root_Buffer_Type;
05f799de
BD		 1335
1336 -------------------------
110d0820 1337 -- Put_Image_Base_Type --
05f799de 1338 -------------------------
110d0820
BD		 1339
1340 function Put_Image_Base_Type (E : Entity_Id) return Entity_Id is
1341 begin
1342 if Is_Array_Type (E) and then Is_First_Subtype (E) then
1343 return E;
1344 else
1345 return Base_Type (E);
1346 end if;
1347 end Put_Image_Base_Type;
1348
1349end Exp_Put_Image;
GNU Compiler Collection
This page took 1.256039 seconds and 5 git commands to generate.