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--                                                                          --
9--             Copyright (C) 2020, Free Software Foundation, Inc.           --
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
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Exp_Tss;  use Exp_Tss;
29with Exp_Util;
30with Debug;    use Debug;
31with Lib;      use Lib;
32with Namet;    use Namet;
33with Nlists;   use Nlists;
34with Nmake;    use Nmake;
35with Opt;      use Opt;
36with Rtsfind;  use Rtsfind;
37with Sem_Aux;  use Sem_Aux;
38with Sem_Util; use Sem_Util;
39with Sinfo;    use Sinfo;
40with Snames;   use Snames;
41with Stand;
42with Tbuild;   use Tbuild;
43with Ttypes;   use Ttypes;
44with Uintp;    use Uintp;
45
46package body Exp_Put_Image is
47
48   Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
49   --  ???Set True to enable Put_Image for at least some tagged types
50
51   -----------------------
52   -- Local Subprograms --
53   -----------------------
54
55   procedure Build_Put_Image_Proc
56     (Loc  : Source_Ptr;
57      Typ  : Entity_Id;
58      Decl : out Node_Id;
59      Pnam : Entity_Id;
60      Stms : List_Id);
61   --  Build an array or record Put_Image procedure. Stms is the list of
62   --  statements for the body and Pnam is the name of the constructed
63   --  procedure. (The declaration list is always null.)
64
65   function Make_Put_Image_Name
66     (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id;
67   --  Return the entity that identifies the Put_Image subprogram for Typ. This
68   --  procedure deals with the difference between tagged types (where a single
69   --  subprogram associated with the type is generated) and all other cases
70   --  (where a subprogram is generated at the point of the attribute
71   --  reference). The Loc parameter is used as the Sloc of the created entity.
72
73   function Put_Image_Base_Type (E : Entity_Id) return Entity_Id;
74   --  Returns the base type, except for an array type whose whose first
75   --  subtype is constrained, in which case it returns the first subtype.
76
77   -------------------------------------
78   -- Build_Array_Put_Image_Procedure --
79   -------------------------------------
80
81   procedure Build_Array_Put_Image_Procedure
82     (Nod  : Node_Id;
83      Typ  : Entity_Id;
84      Decl : out Node_Id;
85      Pnam : out Entity_Id)
86   is
87      Loc  : constant Source_Ptr := Sloc (Nod);
88
89      function Wrap_In_Loop
90        (Stms : List_Id;
91         Dim : Pos;
92         Index_Subtype : Entity_Id;
93         Between_Proc : RE_Id) return Node_Id;
94      --  Wrap Stms in a loop and if statement of the form:
95      --
96      --     if V'First (Dim) <= V'Last (Dim) then -- nonempty range?
97      --        declare
98      --           LDim : Index_Type_For_Dim := V'First (Dim);
99      --        begin
100      --           loop
101      --              Stms;
102      --              exit when LDim = V'Last (Dim);
103      --              Between_Proc (S);
104      --              LDim := Index_Type_For_Dim'Succ (LDim);
105      --           end loop;
106      --        end;
107      --     end if;
108      --
109      --  This is called once per dimension, from inner to outer.
110
111      function Wrap_In_Loop
112        (Stms : List_Id;
113         Dim : Pos;
114         Index_Subtype : Entity_Id;
115         Between_Proc : RE_Id) return Node_Id
116      is
117         Index : constant Entity_Id :=
118           Make_Defining_Identifier
119             (Loc, Chars => New_External_Name ('L', Dim));
120         Decl : constant Node_Id :=
121           Make_Object_Declaration (Loc,
122             Defining_Identifier => Index,
123             Object_Definition =>
124               New_Occurrence_Of (Index_Subtype, Loc),
125             Expression =>
126               Make_Attribute_Reference (Loc,
127                 Prefix         => Make_Identifier (Loc, Name_V),
128                 Attribute_Name => Name_First,
129                 Expressions => New_List (
130                   Make_Integer_Literal (Loc, Dim))));
131         Loop_Stm : constant Node_Id :=
132           Make_Implicit_Loop_Statement (Nod, Statements => Stms);
133         Exit_Stm : constant Node_Id :=
134           Make_Exit_Statement (Loc,
135             Condition =>
136               Make_Op_Eq (Loc,
137                 Left_Opnd => New_Occurrence_Of (Index, Loc),
138                 Right_Opnd =>
139                   Make_Attribute_Reference (Loc,
140                     Prefix         =>
141                       Make_Identifier (Loc, Name_V),
142                     Attribute_Name => Name_Last,
143                     Expressions => New_List (
144                       Make_Integer_Literal (Loc, Dim)))));
145         Increment : constant Node_Id :=
146           Make_Increment (Loc, Index, Index_Subtype);
147         Between : constant Node_Id :=
148           Make_Procedure_Call_Statement (Loc,
149             Name =>
150               New_Occurrence_Of (RTE (Between_Proc), Loc),
151             Parameter_Associations => New_List
152               (Make_Identifier (Loc, Name_S)));
153         Block : constant Node_Id :=
154           Make_Block_Statement (Loc,
155             Declarations               => New_List (Decl),
156             Handled_Statement_Sequence =>
157               Make_Handled_Sequence_Of_Statements (Loc,
158                 Statements => New_List (Loop_Stm)));
159      begin
160         Append_To (Stms, Exit_Stm);
161         Append_To (Stms, Between);
162         Append_To (Stms, Increment);
163         --  Note that we're appending to the Stms list passed in
164
165         return
166           Make_If_Statement (Loc,
167             Condition =>
168               Make_Op_Le (Loc,
169                 Left_Opnd  =>
170                   Make_Attribute_Reference (Loc,
171                     Prefix => Make_Identifier (Loc, Name_V),
172                     Attribute_Name => Name_First,
173                     Expressions => New_List (
174                       Make_Integer_Literal (Loc, Dim))),
175                 Right_Opnd =>
176                   Make_Attribute_Reference (Loc,
177                     Prefix => Make_Identifier (Loc, Name_V),
178                     Attribute_Name => Name_Last,
179                     Expressions => New_List (
180                       Make_Integer_Literal (Loc, Dim)))),
181             Then_Statements => New_List (Block));
182      end Wrap_In_Loop;
183
184      Ndim : constant Pos        := Number_Dimensions (Typ);
185      Ctyp : constant Entity_Id  := Component_Type (Typ);
186
187      Stm         : Node_Id;
188      Exl         : constant List_Id := New_List;
189      PI_Entity   : Entity_Id;
190
191      Indices : array (1 .. Ndim) of Entity_Id;
192
193   --  Start of processing for Build_Array_Put_Image_Procedure
194
195   begin
196      Pnam :=
197        Make_Defining_Identifier (Loc,
198          Chars => Make_TSS_Name_Local (Typ, TSS_Put_Image));
199
200      --  Get the Indices
201
202      declare
203         Index_Subtype : Node_Id := First_Index (Typ);
204      begin
205         for Dim in 1 .. Ndim loop
206            Indices (Dim) := Etype (Index_Subtype);
207            Next_Index (Index_Subtype);
208         end loop;
209         pragma Assert (No (Index_Subtype));
210      end;
211
212      --  Build the inner attribute call
213
214      for Dim in 1 .. Ndim loop
215         Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim)));
216      end loop;
217
218      Stm :=
219        Make_Attribute_Reference (Loc,
220          Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc),
221          Attribute_Name => Name_Put_Image,
222          Expressions => New_List (
223            Make_Identifier (Loc, Name_S),
224            Make_Indexed_Component (Loc,
225              Prefix      => Make_Identifier (Loc, Name_V),
226              Expressions => Exl)));
227
228      --  The corresponding attribute for the component type of the array might
229      --  be user-defined, and frozen after the array type. In that case,
230      --  freeze the Put_Image attribute of the component type, whose
231      --  declaration could not generate any additional freezing actions in any
232      --  case.
233
234      PI_Entity := TSS (Base_Type (Ctyp), TSS_Put_Image);
235
236      if Present (PI_Entity) and then not Is_Frozen (PI_Entity) then
237         Set_Is_Frozen (PI_Entity);
238      end if;
239
240      --  Loop through the dimensions, innermost first, generating a loop for
241      --  each dimension.
242
243      declare
244         Stms : List_Id := New_List (Stm);
245      begin
246         for Dim in reverse 1 .. Ndim loop
247            declare
248               New_Stms : constant List_Id := New_List;
249               Between_Proc : RE_Id;
250            begin
251               --  For a one-dimensional array of elementary type, use
252               --  RE_Simple_Array_Between. The same applies to the last
253               --  dimension of a multidimensional array.
254
255               if Is_Elementary_Type (Ctyp) and then Dim = Ndim then
256                  Between_Proc := RE_Simple_Array_Between;
257               else
258                  Between_Proc := RE_Array_Between;
259               end if;
260
261               Append_To (New_Stms,
262                 Make_Procedure_Call_Statement (Loc,
263                   Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc),
264                   Parameter_Associations => New_List
265                     (Make_Identifier (Loc, Name_S))));
266
267               Append_To
268                 (New_Stms,
269                  Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc));
270
271               Append_To (New_Stms,
272                 Make_Procedure_Call_Statement (Loc,
273                   Name => New_Occurrence_Of (RTE (RE_Array_After), Loc),
274                   Parameter_Associations => New_List
275                     (Make_Identifier (Loc, Name_S))));
276
277               Stms := New_Stms;
278            end;
279         end loop;
280
281         Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
282      end;
283   end Build_Array_Put_Image_Procedure;
284
285   -------------------------------------
286   -- Build_Elementary_Put_Image_Call --
287   -------------------------------------
288
289   function Build_Elementary_Put_Image_Call (N : Node_Id) return Node_Id is
290      Loc     : constant Source_Ptr := Sloc (N);
291      P_Type  : constant Entity_Id  := Entity (Prefix (N));
292      U_Type  : constant Entity_Id  := Underlying_Type (P_Type);
293      FST     : constant Entity_Id  := First_Subtype (U_Type);
294      Sink    : constant Node_Id    := First (Expressions (N));
295      Item    : constant Node_Id    := Next (Sink);
296      P_Size  : constant Uint       := Esize (FST);
297      Lib_RE  : RE_Id;
298
299   begin
300      if Is_Signed_Integer_Type (U_Type) then
301         if P_Size <= Standard_Integer_Size then
302            Lib_RE := RE_Put_Image_Integer;
303         elsif P_Size <= Standard_Long_Long_Integer_Size then
304            Lib_RE := RE_Put_Image_Long_Long_Integer;
305         else
306            pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
307            Lib_RE := RE_Put_Image_Long_Long_Long_Integer;
308         end if;
309
310      elsif Is_Modular_Integer_Type (U_Type) then
311         if P_Size <= Standard_Integer_Size then -- Yes, Integer
312            Lib_RE := RE_Put_Image_Unsigned;
313         elsif P_Size <= Standard_Long_Long_Integer_Size then
314            Lib_RE := RE_Put_Image_Long_Long_Unsigned;
315         else
316            pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size);
317            Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned;
318         end if;
319
320      elsif Is_Access_Type (U_Type) then
321         if Is_Access_Protected_Subprogram_Type (Base_Type (U_Type)) then
322            Lib_RE := RE_Put_Image_Access_Prot_Subp;
323         elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then
324            Lib_RE := RE_Put_Image_Access_Subp;
325         elsif P_Size = System_Address_Size then
326            Lib_RE := RE_Put_Image_Thin_Pointer;
327         else
328            pragma Assert (P_Size = 2 * System_Address_Size);
329            Lib_RE := RE_Put_Image_Fat_Pointer;
330         end if;
331
332      else
333         pragma Assert
334           (Is_Enumeration_Type (U_Type) or else Is_Real_Type (U_Type));
335
336         --  For other elementary types, generate:
337         --
338         --     Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item));
339         --
340         --  It would be more elegant to do it the other way around (define
341         --  '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier
342         --  to implement, because we already have support for
343         --  'Wide_Wide_Image. Furthermore, we don't want to remove the
344         --  existing support for '[[Wide_]Wide_]Image, because we don't
345         --  currently plan to support 'Put_Image on restricted runtimes.
346
347         --  We can't do this:
348         --
349         --     Put_UTF_8 (Sink, U_Type'Image (Item));
350         --
351         --  because we need to generate UTF-8, but 'Image for enumeration
352         --  types uses the character encoding of the source file.
353         --
354         --  Note that this is putting a leading space for reals.
355
356         declare
357            Image : constant Node_Id :=
358              Make_Attribute_Reference (Loc,
359                Prefix => New_Occurrence_Of (U_Type, Loc),
360                Attribute_Name => Name_Wide_Wide_Image,
361                Expressions => New_List (Relocate_Node (Item)));
362            Put_Call : constant Node_Id :=
363              Make_Procedure_Call_Statement (Loc,
364                Name =>
365                  New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc),
366                Parameter_Associations => New_List
367                  (Relocate_Node (Sink), Image));
368         begin
369            return Put_Call;
370         end;
371      end if;
372
373      --  Unchecked-convert parameter to the required type (i.e. the type of
374      --  the corresponding parameter), and call the appropriate routine.
375      --  We could use a normal type conversion for scalars, but the
376      --  "unchecked" is needed for access and private types.
377
378      declare
379         Libent : constant Entity_Id := RTE (Lib_RE);
380      begin
381         return
382           Make_Procedure_Call_Statement (Loc,
383             Name => New_Occurrence_Of (Libent, Loc),
384             Parameter_Associations => New_List (
385               Relocate_Node (Sink),
386               Unchecked_Convert_To
387                (Etype (Next_Formal (First_Formal (Libent))),
388                 Relocate_Node (Item))));
389      end;
390   end Build_Elementary_Put_Image_Call;
391
392   -------------------------------------
393   -- Build_String_Put_Image_Call --
394   -------------------------------------
395
396   function Build_String_Put_Image_Call (N : Node_Id) return Node_Id is
397      Loc     : constant Source_Ptr := Sloc (N);
398      P_Type  : constant Entity_Id  := Entity (Prefix (N));
399      U_Type  : constant Entity_Id  := Underlying_Type (P_Type);
400      R       : constant Entity_Id  := Root_Type (U_Type);
401      Sink    : constant Node_Id    := First (Expressions (N));
402      Item    : constant Node_Id    := Next (Sink);
403      Lib_RE  : RE_Id;
404      use Stand;
405   begin
406      if R = Standard_String then
407         Lib_RE := RE_Put_Image_String;
408      elsif R = Standard_Wide_String then
409         Lib_RE := RE_Put_Image_Wide_String;
410      elsif R = Standard_Wide_Wide_String then
411         Lib_RE := RE_Put_Image_Wide_Wide_String;
412      else
413         raise Program_Error;
414      end if;
415
416      --  Convert parameter to the required type (i.e. the type of the
417      --  corresponding parameter), and call the appropriate routine.
418      --  We set the Conversion_OK flag in case the type is private.
419
420      declare
421         Libent : constant Entity_Id := RTE (Lib_RE);
422         Conv   : constant Node_Id :=
423           OK_Convert_To
424            (Etype (Next_Formal (First_Formal (Libent))),
425             Relocate_Node (Item));
426      begin
427         return
428           Make_Procedure_Call_Statement (Loc,
429             Name => New_Occurrence_Of (Libent, Loc),
430             Parameter_Associations => New_List (
431               Relocate_Node (Sink),
432               Conv));
433      end;
434   end Build_String_Put_Image_Call;
435
436   ------------------------------------
437   -- Build_Protected_Put_Image_Call --
438   ------------------------------------
439
440   --  For "Protected_Type'Put_Image (S, Protected_Object)", build:
441   --
442   --    Put_Image_Protected (S);
443   --
444   --  The protected object is not passed.
445
446   function Build_Protected_Put_Image_Call (N : Node_Id) return Node_Id is
447      Loc    : constant Source_Ptr := Sloc (N);
448      Sink   : constant Node_Id    := First (Expressions (N));
449      Lib_RE : constant RE_Id      := RE_Put_Image_Protected;
450      Libent : constant Entity_Id  := RTE (Lib_RE);
451   begin
452      return
453        Make_Procedure_Call_Statement (Loc,
454          Name => New_Occurrence_Of (Libent, Loc),
455          Parameter_Associations => New_List (
456            Relocate_Node (Sink)));
457   end Build_Protected_Put_Image_Call;
458
459   ------------------------------------
460   -- Build_Task_Put_Image_Call --
461   ------------------------------------
462
463   --  For "Task_Type'Put_Image (S, Task_Object)", build:
464   --
465   --    Put_Image_Task (S, Task_Object'Identity);
466   --
467   --  The task object is not passed; its Task_Id is.
468
469   function Build_Task_Put_Image_Call (N : Node_Id) return Node_Id is
470      Loc    : constant Source_Ptr := Sloc (N);
471      Sink   : constant Node_Id    := First (Expressions (N));
472      Item   : constant Node_Id    := Next (Sink);
473      Lib_RE : constant RE_Id      := RE_Put_Image_Task;
474      Libent : constant Entity_Id  := RTE (Lib_RE);
475
476      Task_Id : constant Node_Id :=
477        Make_Attribute_Reference (Loc,
478          Prefix => Relocate_Node (Item),
479          Attribute_Name => Name_Identity,
480          Expressions => No_List);
481
482   begin
483      return
484        Make_Procedure_Call_Statement (Loc,
485          Name => New_Occurrence_Of (Libent, Loc),
486          Parameter_Associations => New_List (
487            Relocate_Node (Sink),
488            Task_Id));
489   end Build_Task_Put_Image_Call;
490
491   --------------------------------------
492   -- Build_Record_Put_Image_Procedure --
493   --------------------------------------
494
495   --  The form of the record Put_Image procedure is as shown by the
496   --  following example:
497
498   --    procedure Put_Image (S : in out Sink'Class; V : Typ) is
499   --    begin
500   --       Component_Type'Put_Image (S, V.component);
501   --       Component_Type'Put_Image (S, V.component);
502   --       ...
503   --       Component_Type'Put_Image (S, V.component);
504   --
505   --       case V.discriminant is
506   --          when choices =>
507   --             Component_Type'Put_Image (S, V.component);
508   --             Component_Type'Put_Image (S, V.component);
509   --             ...
510   --             Component_Type'Put_Image (S, V.component);
511   --
512   --          when choices =>
513   --             Component_Type'Put_Image (S, V.component);
514   --             Component_Type'Put_Image (S, V.component);
515   --             ...
516   --             Component_Type'Put_Image (S, V.component);
517   --          ...
518   --       end case;
519   --    end Put_Image;
520
521   procedure Build_Record_Put_Image_Procedure
522     (Loc  : Source_Ptr;
523      Typ  : Entity_Id;
524      Decl : out Node_Id;
525      Pnam : out Entity_Id)
526   is
527      Btyp : constant Entity_Id := Base_Type (Typ);
528      pragma Assert (not Is_Unchecked_Union (Btyp));
529
530      First_Time : Boolean := True;
531
532      function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
533      --  Returns a sequence of Component_Type'Put_Image attribute_references
534      --  to process the components that are referenced in the given component
535      --  list. Called for the main component list, and then recursively for
536      --  variants.
537
538      function Make_Component_Attributes (Clist : List_Id) return List_Id;
539      --  Given Clist, a component items list, construct series of
540      --  Component_Type'Put_Image attribute_references for componentwise
541      --  processing of the corresponding components. Called for the
542      --  discriminants, and then from Make_Component_List_Attributes for each
543      --  list (including in variants).
544
545      procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id);
546      --  Given C, the entity for a discriminant or component, build a call to
547      --  Component_Type'Put_Image for the corresponding component value, and
548      --  append it onto Clist. Called from Make_Component_Attributes.
549
550      function Make_Component_Name (C : Entity_Id) return Node_Id;
551      --  Create a call that prints "Comp_Name => "
552
553      ------------------------------------
554      -- Make_Component_List_Attributes --
555      ------------------------------------
556
557      function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
558         CI : constant List_Id := Component_Items (CL);
559         VP : constant Node_Id := Variant_Part (CL);
560
561         Result : List_Id;
562         Alts   : List_Id;
563         V      : Node_Id;
564         DC     : Node_Id;
565         DCH    : List_Id;
566         D_Ref  : Node_Id;
567
568      begin
569         Result := Make_Component_Attributes (CI);
570
571         if Present (VP) then
572            Alts := New_List;
573
574            V := First_Non_Pragma (Variants (VP));
575            while Present (V) loop
576               DCH := New_List;
577
578               DC := First (Discrete_Choices (V));
579               while Present (DC) loop
580                  Append_To (DCH, New_Copy_Tree (DC));
581                  Next (DC);
582               end loop;
583
584               Append_To (Alts,
585                 Make_Case_Statement_Alternative (Loc,
586                   Discrete_Choices => DCH,
587                   Statements =>
588                     Make_Component_List_Attributes (Component_List (V))));
589               Next_Non_Pragma (V);
590            end loop;
591
592            --  Note: in the following, we use New_Occurrence_Of for the
593            --  selector, since there are cases in which we make a reference
594            --  to a hidden discriminant that is not visible.
595
596            D_Ref :=
597               Make_Selected_Component (Loc,
598                 Prefix        => Make_Identifier (Loc, Name_V),
599                 Selector_Name =>
600                   New_Occurrence_Of (Entity (Name (VP)), Loc));
601
602            Append_To (Result,
603              Make_Case_Statement (Loc,
604                Expression   => D_Ref,
605                Alternatives => Alts));
606         end if;
607
608         return Result;
609      end Make_Component_List_Attributes;
610
611      --------------------------------
612      -- Append_Component_Attr --
613      --------------------------------
614
615      procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is
616         Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C));
617      begin
618         if Ekind (C) /= E_Void then
619            Append_To (Clist,
620              Make_Attribute_Reference (Loc,
621                Prefix         => New_Occurrence_Of (Component_Typ, Loc),
622                Attribute_Name => Name_Put_Image,
623                Expressions    => New_List (
624                  Make_Identifier (Loc, Name_S),
625                  Make_Selected_Component (Loc,
626                    Prefix        => Make_Identifier (Loc, Name_V),
627                    Selector_Name => New_Occurrence_Of (C, Loc)))));
628         end if;
629      end Append_Component_Attr;
630
631      -------------------------------
632      -- Make_Component_Attributes --
633      -------------------------------
634
635      function Make_Component_Attributes (Clist : List_Id) return List_Id is
636         Item   : Node_Id;
637         Result : List_Id;
638
639      begin
640         Result := New_List;
641
642         if Present (Clist) then
643            Item := First (Clist);
644
645            --  Loop through components, skipping all internal components,
646            --  which are not part of the value (e.g. _Tag), except that we
647            --  don't skip the _Parent, since we do want to process that
648            --  recursively. If _Parent is an interface type, being abstract
649            --  with no components there is no need to handle it.
650
651            while Present (Item) loop
652               if Nkind (Item) in
653                    N_Component_Declaration | N_Discriminant_Specification
654                 and then
655                   ((Chars (Defining_Identifier (Item)) = Name_uParent
656                       and then not Is_Interface
657                                      (Etype (Defining_Identifier (Item))))
658                     or else
659                    not Is_Internal_Name (Chars (Defining_Identifier (Item))))
660               then
661                  if First_Time then
662                     First_Time := False;
663                  else
664                     Append_To (Result,
665                       Make_Procedure_Call_Statement (Loc,
666                         Name =>
667                           New_Occurrence_Of (RTE (RE_Record_Between), Loc),
668                         Parameter_Associations => New_List
669                           (Make_Identifier (Loc, Name_S))));
670                  end if;
671
672                  Append_To (Result, Make_Component_Name (Item));
673                  Append_Component_Attr (Result, Defining_Identifier (Item));
674               end if;
675
676               Next (Item);
677            end loop;
678         end if;
679
680         return Result;
681      end Make_Component_Attributes;
682
683      -------------------------
684      -- Make_Component_Name --
685      -------------------------
686
687      function Make_Component_Name (C : Entity_Id) return Node_Id is
688         Name : constant Name_Id := Chars (Defining_Identifier (C));
689      begin
690         return
691           Make_Procedure_Call_Statement (Loc,
692             Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
693             Parameter_Associations => New_List
694               (Make_Identifier (Loc, Name_S),
695                Make_String_Literal (Loc, Get_Name_String (Name) & " => ")));
696      end Make_Component_Name;
697
698      Stms : constant List_Id := New_List;
699      Rdef : Node_Id;
700      Type_Decl : constant Node_Id :=
701        Declaration_Node (Base_Type (Underlying_Type (Btyp)));
702
703   --  Start of processing for Build_Record_Put_Image_Procedure
704
705   begin
706      Append_To (Stms,
707        Make_Procedure_Call_Statement (Loc,
708          Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc),
709          Parameter_Associations => New_List
710            (Make_Identifier (Loc, Name_S))));
711
712      --  Generate Put_Images for the discriminants of the type
713
714      Append_List_To (Stms,
715        Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
716
717      Rdef := Type_Definition (Type_Decl);
718
719      --  In the record extension case, the components we want, including the
720      --  _Parent component representing the parent type, are to be found in
721      --  the extension. We will process the _Parent component using the type
722      --  of the parent.
723
724      if Nkind (Rdef) = N_Derived_Type_Definition then
725         Rdef := Record_Extension_Part (Rdef);
726      end if;
727
728      if Present (Component_List (Rdef)) then
729         Append_List_To (Stms,
730           Make_Component_List_Attributes (Component_List (Rdef)));
731      end if;
732
733      Append_To (Stms,
734        Make_Procedure_Call_Statement (Loc,
735          Name => New_Occurrence_Of (RTE (RE_Record_After), Loc),
736          Parameter_Associations => New_List
737            (Make_Identifier (Loc, Name_S))));
738
739      Pnam := Make_Put_Image_Name (Loc, Btyp);
740      Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
741   end Build_Record_Put_Image_Procedure;
742
743   -------------------------------
744   -- Build_Put_Image_Profile --
745   -------------------------------
746
747   function Build_Put_Image_Profile
748     (Loc : Source_Ptr; Typ : Entity_Id) return List_Id
749   is
750   begin
751      return New_List (
752        Make_Parameter_Specification (Loc,
753          Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
754          In_Present          => True,
755          Out_Present         => True,
756          Parameter_Type      =>
757            New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)),
758
759        Make_Parameter_Specification (Loc,
760          Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
761          Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
762   end Build_Put_Image_Profile;
763
764   --------------------------
765   -- Build_Put_Image_Proc --
766   --------------------------
767
768   procedure Build_Put_Image_Proc
769     (Loc  : Source_Ptr;
770      Typ  : Entity_Id;
771      Decl : out Node_Id;
772      Pnam : Entity_Id;
773      Stms : List_Id)
774   is
775      Spec : constant Node_Id :=
776        Make_Procedure_Specification (Loc,
777          Defining_Unit_Name => Pnam,
778          Parameter_Specifications => Build_Put_Image_Profile (Loc, Typ));
779   begin
780      Decl :=
781        Make_Subprogram_Body (Loc,
782          Specification              => Spec,
783          Declarations               => Empty_List,
784          Handled_Statement_Sequence =>
785            Make_Handled_Sequence_Of_Statements (Loc,
786              Statements => Stms));
787   end Build_Put_Image_Proc;
788
789   ------------------------------------
790   -- Build_Unknown_Put_Image_Call --
791   ------------------------------------
792
793   function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id is
794      Loc    : constant Source_Ptr := Sloc (N);
795      Sink   : constant Node_Id    := First (Expressions (N));
796      Lib_RE : constant RE_Id      := RE_Put_Image_Unknown;
797      Libent : constant Entity_Id  := RTE (Lib_RE);
798   begin
799      return
800        Make_Procedure_Call_Statement (Loc,
801          Name => New_Occurrence_Of (Libent, Loc),
802          Parameter_Associations => New_List (
803            Relocate_Node (Sink),
804            Make_String_Literal (Loc,
805              Exp_Util.Fully_Qualified_Name_String (
806                Entity (Prefix (N)), Append_NUL => False))));
807   end Build_Unknown_Put_Image_Call;
808
809   ----------------------
810   -- Enable_Put_Image --
811   ----------------------
812
813   function Enable_Put_Image (Typ : Entity_Id) return Boolean is
814   begin
815      --  There's a bit of a chicken&egg problem. The compiler is likely to
816      --  have trouble if we refer to the Put_Image of Sink itself, because
817      --  Sink is part of the parameter profile:
818      --
819      --     function Sink'Put_Image (S : in out Sink'Class; V : T);
820      --
821      --  Likewise, the Ada.Strings.Text_Output package, where Sink is
822      --  declared, depends on various other packages, so if we refer to
823      --  Put_Image of types declared in those other packages, we could create
824      --  cyclic dependencies. Therefore, we disable Put_Image for some
825      --  types. It's not clear exactly what types should be disabled. Scalar
826      --  types are OK, even if predefined, because calls to Put_Image of
827      --  scalar types are expanded inline. We certainly want to be able to use
828      --  Integer'Put_Image, for example.
829
830      --  ???Temporarily disable to work around bugs:
831      --
832      --  Put_Image does not work for Remote_Types. We check the containing
833      --  package, rather than the type itself, because we want to include
834      --  types in the private part of a Remote_Types package.
835      --
836      --  Put_Image on tagged types triggers some bugs.
837
838      if Is_Remote_Types (Scope (Typ))
839        or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
840        or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled)
841      then
842         return False;
843      end if;
844
845      --  End of workarounds.
846
847      --  No sense in generating code for Put_Image if there are errors. This
848      --  avoids certain cascade errors.
849
850      if Total_Errors_Detected > 0 then
851         return False;
852      end if;
853
854      --  If type Sink is unavailable in this runtime, disable Put_Image
855      --  altogether.
856
857      if No_Run_Time_Mode or else not RTE_Available (RE_Sink) then
858         return False;
859      end if;
860
861      --  ???Disable Put_Image on type Sink declared in
862      --  Ada.Strings.Text_Output. Note that we can't call Is_RTU on
863      --  Ada_Strings_Text_Output, because it's not known yet (we might be
864      --  compiling it). But this is insufficient to allow support for tagged
865      --  predefined types.
866
867      declare
868         Parent_Scope : constant Entity_Id := Scope (Scope (Typ));
869      begin
870         if Present (Parent_Scope)
871           and then Is_RTU (Parent_Scope, Ada_Strings)
872           and then Chars (Scope (Typ)) = Name_Find ("text_output")
873         then
874            return False;
875         end if;
876      end;
877
878      --  Disable for CPP types, because the components are unavailable on the
879      --  Ada side.
880
881      if Is_Tagged_Type (Typ)
882        and then Convention (Typ) = Convention_CPP
883        and then Is_CPP_Class (Root_Type (Typ))
884      then
885         return False;
886      end if;
887
888      --  Disable for unchecked unions, because there is no way to know the
889      --  discriminant value, and therefore no way to know which components
890      --  should be printed.
891
892      if Is_Unchecked_Union (Typ) then
893         return False;
894      end if;
895
896      return True;
897   end Enable_Put_Image;
898
899   ---------------------------------
900   -- Make_Put_Image_Name --
901   ---------------------------------
902
903   function Make_Put_Image_Name
904     (Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id
905   is
906      Sname : Name_Id;
907   begin
908      --  For tagged types, we are dealing with a TSS associated with the
909      --  declaration, so we use the standard primitive function name. For
910      --  other types, generate a local TSS name since we are generating
911      --  the subprogram at the point of use.
912
913      if Is_Tagged_Type (Typ) then
914         Sname := Make_TSS_Name (Typ, TSS_Put_Image);
915      else
916         Sname := Make_TSS_Name_Local (Typ, TSS_Put_Image);
917      end if;
918
919      return Make_Defining_Identifier (Loc, Sname);
920   end Make_Put_Image_Name;
921
922   function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is
923   begin
924      if Ada_Version < Ada_2020 then
925         return False;
926      end if;
927
928      --  In Ada 2020, T'Image calls T'Put_Image if there is an explicit
929      --  aspect_specification for Put_Image, or if U_Type'Image is illegal
930      --  in pre-2020 versions of Ada.
931
932      declare
933         U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
934      begin
935         if Present (TSS (U_Type, TSS_Put_Image)) then
936            return True;
937         end if;
938
939         return not Is_Scalar_Type (U_Type);
940      end;
941   end Image_Should_Call_Put_Image;
942
943   function Build_Image_Call (N : Node_Id) return Node_Id is
944      --  For T'Image (X) Generate an Expression_With_Actions node:
945      --
946      --     do
947      --        S : Buffer := New_Buffer;
948      --        U_Type'Put_Image (S, X);
949      --        Result : constant String := Get (S);
950      --        Destroy (S);
951      --     in Result end
952      --
953      --  where U_Type is the underlying type, as needed to bypass privacy.
954
955      Loc : constant Source_Ptr := Sloc (N);
956      U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
957      Sink_Entity : constant Entity_Id :=
958        Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
959      Sink_Decl : constant Node_Id :=
960        Make_Object_Declaration (Loc,
961          Defining_Identifier => Sink_Entity,
962          Object_Definition =>
963            New_Occurrence_Of (RTE (RE_Buffer), Loc),
964          Expression =>
965            Make_Function_Call (Loc,
966              Name => New_Occurrence_Of (RTE (RE_New_Buffer), Loc),
967              Parameter_Associations => Empty_List));
968      Put_Im : constant Node_Id :=
969        Make_Attribute_Reference (Loc,
970          Prefix         => New_Occurrence_Of (U_Type, Loc),
971          Attribute_Name => Name_Put_Image,
972          Expressions    => New_List (
973            New_Occurrence_Of (Sink_Entity, Loc),
974            New_Copy_Tree (First (Expressions (N)))));
975      Result_Entity : constant Entity_Id :=
976        Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R'));
977      Result_Decl : constant Node_Id :=
978        Make_Object_Declaration (Loc,
979          Defining_Identifier => Result_Entity,
980          Object_Definition =>
981            New_Occurrence_Of (Stand.Standard_String, Loc),
982          Expression =>
983            Make_Function_Call (Loc,
984              Name => New_Occurrence_Of (RTE (RE_Get), Loc),
985              Parameter_Associations => New_List (
986                New_Occurrence_Of (Sink_Entity, Loc))));
987      Image : constant Node_Id :=
988        Make_Expression_With_Actions (Loc,
989          Actions => New_List (Sink_Decl, Put_Im, Result_Decl),
990          Expression => New_Occurrence_Of (Result_Entity, Loc));
991   begin
992      return Image;
993   end Build_Image_Call;
994
995   ------------------
996   -- Preload_Sink --
997   ------------------
998
999   procedure Preload_Sink (Compilation_Unit : Node_Id) is
1000   begin
1001      --  We can't call RTE (RE_Sink) for at least some predefined units,
1002      --  because it would introduce cyclic dependences. The package where Sink
1003      --  is declared, for example, and things it depends on.
1004      --
1005      --  It's only needed for tagged types, so don't do it unless Put_Image is
1006      --  enabled for tagged types, and we've seen a tagged type. Note that
1007      --  Tagged_Seen is set True by the parser if the "tagged" reserved word
1008      --  is seen; this flag tells us whether we have any tagged types.
1009      --  It's unfortunate to have this Tagged_Seen processing so scattered
1010      --  about, but we need to know if there are tagged types where this is
1011      --  called in Analyze_Compilation_Unit, before we have analyzed any type
1012      --  declarations. This mechanism also prevents doing RTE (RE_Sink) when
1013      --  compiling the compiler itself. Packages Ada.Strings.Text_Output and
1014      --  friends are not included in the compiler.
1015      --
1016      --  Don't do it if type Sink is unavailable in the runtime.
1017
1018      if not In_Predefined_Unit (Compilation_Unit)
1019        and then Tagged_Put_Image_Enabled
1020        and then Tagged_Seen
1021        and then not No_Run_Time_Mode
1022        and then RTE_Available (RE_Sink)
1023      then
1024         declare
1025            Ignore : constant Entity_Id := RTE (RE_Sink);
1026         begin
1027            null;
1028         end;
1029      end if;
1030   end Preload_Sink;
1031
1032   -------------------------
1033   -- Put_Image_Base_Type --
1034   -------------------------
1035
1036   function Put_Image_Base_Type (E : Entity_Id) return Entity_Id is
1037   begin
1038      if Is_Array_Type (E) and then Is_First_Subtype (E) then
1039         return E;
1040      else
1041         return Base_Type (E);
1042      end if;
1043   end Put_Image_Base_Type;
1044
1045end Exp_Put_Image;
1046