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