gcc/ada/exp_put_image.adb

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