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