1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- R E P I N F O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-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 Alloc; 27with Atree; use Atree; 28with Casing; use Casing; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Einfo.Entities; use Einfo.Entities; 32with Einfo.Utils; use Einfo.Utils; 33with Lib; use Lib; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Opt; use Opt; 37with Output; use Output; 38with Osint.C; use Osint.C; 39with Sem_Aux; use Sem_Aux; 40with Sem_Eval; use Sem_Eval; 41with Sem_Util; 42with Sinfo; use Sinfo; 43with Sinfo.Nodes; use Sinfo.Nodes; 44with Sinfo.Utils; use Sinfo.Utils; 45with Sinput; use Sinput; 46with Snames; use Snames; 47with Stringt; use Stringt; 48with Table; 49with Ttypes; 50with Uname; use Uname; 51with Urealp; use Urealp; 52 53with Ada.Unchecked_Conversion; 54 55with GNAT.HTable; 56 57package body Repinfo is 58 59 SSU : Pos renames Ttypes.System_Storage_Unit; 60 -- Value for Storage_Unit 61 62 --------------------------------------- 63 -- Representation of GCC Expressions -- 64 --------------------------------------- 65 66 -- A table internal to this unit is used to hold the values of back 67 -- annotated expressions. 68 69 -- Node values are stored as Uint values using the negative of the node 70 -- index in this table. Constants appear as non-negative Uint values. 71 72 type Exp_Node is record 73 Expr : TCode; 74 Op1 : Node_Ref_Or_Val; 75 Op2 : Node_Ref_Or_Val; 76 Op3 : Node_Ref_Or_Val; 77 end record; 78 79 -- The following representation clause ensures that the above record 80 -- has no holes. We do this so that when instances of this record are 81 -- written, we do not write uninitialized values to the file. 82 83 for Exp_Node use record 84 Expr at 0 range 0 .. 31; 85 Op1 at 4 range 0 .. 31; 86 Op2 at 8 range 0 .. 31; 87 Op3 at 12 range 0 .. 31; 88 end record; 89 90 for Exp_Node'Size use 16 * 8; 91 -- This ensures that we did not leave out any fields 92 93 package Rep_Table is new Table.Table ( 94 Table_Component_Type => Exp_Node, 95 Table_Index_Type => Nat, 96 Table_Low_Bound => 1, 97 Table_Initial => Alloc.Rep_Table_Initial, 98 Table_Increment => Alloc.Rep_Table_Increment, 99 Table_Name => "BE_Rep_Table"); 100 101 -------------------------------------------------------------- 102 -- Representation of Front-End Dynamic Size/Offset Entities -- 103 -------------------------------------------------------------- 104 105 package Dynamic_SO_Entity_Table is new Table.Table ( 106 Table_Component_Type => Entity_Id, 107 Table_Index_Type => Nat, 108 Table_Low_Bound => 1, 109 Table_Initial => Alloc.Rep_Table_Initial, 110 Table_Increment => Alloc.Rep_Table_Increment, 111 Table_Name => "FE_Rep_Table"); 112 113 Unit_Casing : Casing_Type; 114 -- Identifier casing for current unit. This is set by List_Rep_Info for 115 -- each unit, before calling subprograms which may read it. 116 117 Need_Separator : Boolean; 118 -- Set True if a separator is needed before outputting any information for 119 -- the current entity. 120 121 ------------------------------ 122 -- Set of Relevant Entities -- 123 ------------------------------ 124 125 Relevant_Entities_Size : constant := 4093; 126 -- Number of headers in hash table 127 128 subtype Entity_Header_Num is Integer range 0 .. Relevant_Entities_Size - 1; 129 -- Range of headers in hash table 130 131 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num; 132 -- Simple hash function for Entity_Ids 133 134 package Relevant_Entities is new GNAT.Htable.Simple_HTable 135 (Header_Num => Entity_Header_Num, 136 Element => Boolean, 137 No_Element => False, 138 Key => Entity_Id, 139 Hash => Entity_Hash, 140 Equal => "="); 141 -- Hash table to record which compiler-generated entities are relevant 142 143 ----------------------- 144 -- Local Subprograms -- 145 ----------------------- 146 147 procedure List_Entities 148 (Ent : Entity_Id; 149 Bytes_Big_Endian : Boolean; 150 In_Subprogram : Boolean := False); 151 -- This procedure lists the entities associated with the entity E, starting 152 -- with the First_Entity and using the Next_Entity link. If a nested 153 -- package is found, entities within the package are recursively processed. 154 -- When recursing within a subprogram body, Is_Subprogram suppresses 155 -- duplicate information about signature. 156 157 procedure List_Name (Ent : Entity_Id); 158 -- List name of entity Ent in appropriate case. The name is listed with 159 -- full qualification up to but not including the compilation unit name. 160 161 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 162 -- List representation info for array type Ent 163 164 procedure List_Common_Type_Info (Ent : Entity_Id); 165 -- List common type info (name, size, alignment) for type Ent 166 167 procedure List_Linker_Section (Ent : Entity_Id); 168 -- List linker section for Ent (caller has checked that Ent is an entity 169 -- for which the Linker_Section_Pragma field is defined). 170 171 procedure List_Location (Ent : Entity_Id); 172 -- List location information for Ent 173 174 procedure List_Object_Info (Ent : Entity_Id); 175 -- List representation info for object Ent 176 177 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 178 -- List representation info for record type Ent 179 180 procedure List_Scalar_Storage_Order 181 (Ent : Entity_Id; 182 Bytes_Big_Endian : Boolean); 183 -- List scalar storage order information for record or array type Ent. 184 -- Also includes bit order information for record types, if necessary. 185 186 procedure List_Subprogram_Info (Ent : Entity_Id); 187 -- List subprogram info for subprogram Ent 188 189 procedure List_Type_Info (Ent : Entity_Id); 190 -- List type info for type Ent 191 192 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean; 193 -- Returns True if Val represents a variable value, and False if it 194 -- represents a value that is fixed at compile time. 195 196 procedure Spaces (N : Natural); 197 -- Output given number of spaces 198 199 procedure Write_Info_Line (S : String); 200 -- Routine to write a line to Repinfo output file. This routine is passed 201 -- as a special output procedure to Output.Set_Special_Output. Note that 202 -- Write_Info_Line is called with an EOL character at the end of each line, 203 -- as per the Output spec, but the internal call to the appropriate routine 204 -- in Osint requires that the end of line sequence be stripped off. 205 206 procedure Write_Mechanism (M : Mechanism_Type); 207 -- Writes symbolic string for mechanism represented by M 208 209 procedure Write_Separator; 210 -- Called before outputting anything for an entity. Ensures that 211 -- a separator precedes the output for a particular entity. 212 213 procedure Write_Unknown_Val; 214 -- Writes symbolic string for an unknown or non-representable value 215 216 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); 217 -- Given a representation value, write it out. No_Uint values or values 218 -- dependent on discriminants are written as two question marks. If the 219 -- flag Paren is set, then the output is surrounded in parentheses if it is 220 -- other than a simple value. 221 222 ------------------------ 223 -- Create_Discrim_Ref -- 224 ------------------------ 225 226 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is 227 begin 228 return Create_Node 229 (Expr => Discrim_Val, 230 Op1 => Discriminant_Number (Discr)); 231 end Create_Discrim_Ref; 232 233 --------------------------- 234 -- Create_Dynamic_SO_Ref -- 235 --------------------------- 236 237 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is 238 begin 239 Dynamic_SO_Entity_Table.Append (E); 240 return UI_From_Int (-Dynamic_SO_Entity_Table.Last); 241 end Create_Dynamic_SO_Ref; 242 243 ----------------- 244 -- Create_Node -- 245 ----------------- 246 247 function Create_Node 248 (Expr : TCode; 249 Op1 : Node_Ref_Or_Val; 250 Op2 : Node_Ref_Or_Val := No_Uint; 251 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref 252 is 253 begin 254 Rep_Table.Append ( 255 (Expr => Expr, 256 Op1 => Op1, 257 Op2 => Op2, 258 Op3 => Op3)); 259 return UI_From_Int (-Rep_Table.Last); 260 end Create_Node; 261 262 ----------------- 263 -- Entity_Hash -- 264 ----------------- 265 266 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is 267 begin 268 return Entity_Header_Num (Id mod Relevant_Entities_Size); 269 end Entity_Hash; 270 271 --------------------------- 272 -- Get_Dynamic_SO_Entity -- 273 --------------------------- 274 275 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is 276 begin 277 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U)); 278 end Get_Dynamic_SO_Entity; 279 280 ----------------------- 281 -- Is_Dynamic_SO_Ref -- 282 ----------------------- 283 284 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is 285 begin 286 return U < Uint_0; 287 end Is_Dynamic_SO_Ref; 288 289 ---------------------- 290 -- Is_Static_SO_Ref -- 291 ---------------------- 292 293 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is 294 begin 295 return U >= Uint_0; 296 end Is_Static_SO_Ref; 297 298 --------- 299 -- lgx -- 300 --------- 301 302 procedure lgx (U : Node_Ref_Or_Val) is 303 begin 304 List_GCC_Expression (U); 305 Write_Eol; 306 end lgx; 307 308 ---------------------- 309 -- List_Array_Info -- 310 ---------------------- 311 312 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 313 begin 314 Write_Separator; 315 316 if List_Representation_Info_To_JSON then 317 Write_Line ("{"); 318 end if; 319 320 List_Common_Type_Info (Ent); 321 322 if List_Representation_Info_To_JSON then 323 Write_Line (","); 324 Write_Str (" ""Component_Size"": "); 325 Write_Val (Component_Size (Ent)); 326 else 327 Write_Str ("for "); 328 List_Name (Ent); 329 Write_Str ("'Component_Size use "); 330 Write_Val (Component_Size (Ent)); 331 Write_Line (";"); 332 end if; 333 334 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 335 336 List_Linker_Section (Ent); 337 338 if List_Representation_Info_To_JSON then 339 Write_Eol; 340 Write_Line ("}"); 341 end if; 342 343 -- The component type is relevant for an array 344 345 if List_Representation_Info = 4 346 and then Is_Itype (Component_Type (Base_Type (Ent))) 347 then 348 Relevant_Entities.Set (Component_Type (Base_Type (Ent)), True); 349 end if; 350 end List_Array_Info; 351 352 --------------------------- 353 -- List_Common_Type_Info -- 354 --------------------------- 355 356 procedure List_Common_Type_Info (Ent : Entity_Id) is 357 begin 358 if List_Representation_Info_To_JSON then 359 Write_Str (" ""name"": """); 360 List_Name (Ent); 361 Write_Line (""","); 362 List_Location (Ent); 363 end if; 364 365 -- Do not list size info for unconstrained arrays, not meaningful 366 367 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then 368 null; 369 370 else 371 if Known_Esize (Ent) and then Known_RM_Size (Ent) then 372 -- If Esize and RM_Size are the same, list as Size. This is a 373 -- common case, which we may as well list in simple form. 374 375 if Esize (Ent) = RM_Size (Ent) then 376 if List_Representation_Info_To_JSON then 377 Write_Str (" ""Size"": "); 378 Write_Val (Esize (Ent)); 379 Write_Line (","); 380 else 381 Write_Str ("for "); 382 List_Name (Ent); 383 Write_Str ("'Size use "); 384 Write_Val (Esize (Ent)); 385 Write_Line (";"); 386 end if; 387 388 -- Otherwise list size values separately 389 390 else 391 if List_Representation_Info_To_JSON then 392 Write_Str (" ""Object_Size"": "); 393 Write_Val (Esize (Ent)); 394 Write_Line (","); 395 396 Write_Str (" ""Value_Size"": "); 397 Write_Val (RM_Size (Ent)); 398 Write_Line (","); 399 400 else 401 Write_Str ("for "); 402 List_Name (Ent); 403 Write_Str ("'Object_Size use "); 404 Write_Val (Esize (Ent)); 405 Write_Line (";"); 406 407 Write_Str ("for "); 408 List_Name (Ent); 409 Write_Str ("'Value_Size use "); 410 Write_Val (RM_Size (Ent)); 411 Write_Line (";"); 412 end if; 413 end if; 414 end if; 415 end if; 416 417 if Known_Alignment (Ent) then 418 if List_Representation_Info_To_JSON then 419 Write_Str (" ""Alignment"": "); 420 Write_Val (Alignment (Ent)); 421 else 422 Write_Str ("for "); 423 List_Name (Ent); 424 Write_Str ("'Alignment use "); 425 Write_Val (Alignment (Ent)); 426 Write_Line (";"); 427 end if; 428 429 -- Alignment is not always set for task, protected, and class-wide 430 -- types. Representation aspects are not computed for types in a 431 -- generic unit. 432 433 else 434 pragma Assert 435 (Is_Concurrent_Type (Ent) or else 436 Is_Class_Wide_Type (Ent) or else 437 Sem_Util.In_Generic_Scope (Ent)); 438 end if; 439 end List_Common_Type_Info; 440 441 ------------------- 442 -- List_Entities -- 443 ------------------- 444 445 procedure List_Entities 446 (Ent : Entity_Id; 447 Bytes_Big_Endian : Boolean; 448 In_Subprogram : Boolean := False) 449 is 450 Body_E : Entity_Id; 451 E : Entity_Id; 452 453 function Find_Declaration (E : Entity_Id) return Node_Id; 454 -- Utility to retrieve declaration node for entity in the 455 -- case of package bodies and subprograms. 456 457 ---------------------- 458 -- Find_Declaration -- 459 ---------------------- 460 461 function Find_Declaration (E : Entity_Id) return Node_Id is 462 Decl : Node_Id; 463 464 begin 465 Decl := Parent (E); 466 while Present (Decl) 467 and then Nkind (Decl) /= N_Package_Body 468 and then Nkind (Decl) /= N_Subprogram_Declaration 469 and then Nkind (Decl) /= N_Subprogram_Body 470 loop 471 Decl := Parent (Decl); 472 end loop; 473 474 return Decl; 475 end Find_Declaration; 476 477 -- Start of processing for List_Entities 478 479 begin 480 -- List entity if we have one, and it is not a renaming declaration. 481 -- For renamings, we don't get proper information, and really it makes 482 -- sense to restrict the output to the renamed entity. 483 484 if Present (Ent) 485 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration 486 and then not Is_Ignored_Ghost_Entity (Ent) 487 then 488 -- If entity is a subprogram and we are listing mechanisms, 489 -- then we need to list mechanisms for this entity. We skip this 490 -- if it is a nested subprogram, as the information has already 491 -- been produced when listing the enclosing scope. 492 493 if List_Representation_Info_Mechanisms 494 and then Is_Subprogram_Or_Entry (Ent) 495 and then not In_Subprogram 496 then 497 List_Subprogram_Info (Ent); 498 end if; 499 500 E := First_Entity (Ent); 501 while Present (E) loop 502 -- We list entities that come from source (excluding private or 503 -- incomplete types or deferred constants, for which we will list 504 -- the information for the full view). If requested, we also list 505 -- relevant entities that have been generated when processing the 506 -- original entities coming from source. But if debug flag A is 507 -- set, then all entities are listed. 508 509 if ((Comes_From_Source (E) 510 or else (Ekind (E) = E_Block 511 and then 512 Nkind (Parent (E)) = N_Implicit_Label_Declaration 513 and then 514 Comes_From_Source (Label_Construct (Parent (E))))) 515 and then not Is_Incomplete_Or_Private_Type (E) 516 and then not (Ekind (E) = E_Constant 517 and then Present (Full_View (E)))) 518 or else (List_Representation_Info = 4 519 and then Relevant_Entities.Get (E)) 520 or else Debug_Flag_AA 521 then 522 if Is_Subprogram (E) then 523 if List_Representation_Info_Mechanisms then 524 List_Subprogram_Info (E); 525 end if; 526 527 -- Recurse into entities local to subprogram 528 529 List_Entities (E, Bytes_Big_Endian, True); 530 531 elsif Ekind (E) in E_Entry 532 | E_Entry_Family 533 | E_Subprogram_Type 534 then 535 if List_Representation_Info_Mechanisms then 536 List_Subprogram_Info (E); 537 end if; 538 539 elsif Is_Record_Type (E) then 540 if List_Representation_Info >= 1 then 541 List_Record_Info (E, Bytes_Big_Endian); 542 543 -- Recurse into entities local to a record type 544 545 if List_Representation_Info = 4 then 546 List_Entities (E, Bytes_Big_Endian, False); 547 end if; 548 end if; 549 550 elsif Is_Array_Type (E) then 551 if List_Representation_Info >= 1 then 552 List_Array_Info (E, Bytes_Big_Endian); 553 end if; 554 555 elsif Is_Type (E) then 556 if List_Representation_Info >= 2 then 557 List_Type_Info (E); 558 end if; 559 560 -- Note that formals are not annotated so we skip them here 561 562 elsif Ekind (E) in E_Constant 563 | E_Loop_Parameter 564 | E_Variable 565 then 566 if List_Representation_Info >= 2 then 567 List_Object_Info (E); 568 end if; 569 end if; 570 571 -- Recurse into nested package, but not if they are package 572 -- renamings (in particular renamings of the enclosing package, 573 -- as for some Java bindings and for generic instances). 574 575 if Ekind (E) = E_Package then 576 if No (Renamed_Entity (E)) then 577 List_Entities (E, Bytes_Big_Endian); 578 end if; 579 580 -- Recurse into bodies 581 582 elsif Ekind (E) in E_Package_Body 583 | E_Protected_Body 584 | E_Protected_Type 585 | E_Subprogram_Body 586 | E_Task_Body 587 | E_Task_Type 588 then 589 List_Entities (E, Bytes_Big_Endian); 590 591 -- Recurse into blocks 592 593 elsif Ekind (E) = E_Block then 594 List_Entities (E, Bytes_Big_Endian); 595 end if; 596 end if; 597 598 Next_Entity (E); 599 end loop; 600 601 -- For a package body, the entities of the visible subprograms are 602 -- declared in the corresponding spec. Iterate over its entities in 603 -- order to handle properly the subprogram bodies. Skip bodies in 604 -- subunits, which are listed independently. 605 606 if Ekind (Ent) = E_Package_Body 607 and then Present (Corresponding_Spec (Find_Declaration (Ent))) 608 then 609 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent))); 610 while Present (E) loop 611 if Is_Subprogram (E) 612 and then 613 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration 614 then 615 Body_E := Corresponding_Body (Find_Declaration (E)); 616 617 if Present (Body_E) 618 and then 619 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit 620 then 621 List_Entities (Body_E, Bytes_Big_Endian); 622 end if; 623 end if; 624 625 Next_Entity (E); 626 end loop; 627 end if; 628 end if; 629 end List_Entities; 630 631 ------------------------- 632 -- List_GCC_Expression -- 633 ------------------------- 634 635 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is 636 637 procedure Print_Expr (Val : Node_Ref_Or_Val); 638 -- Internal recursive procedure to print expression 639 640 ---------------- 641 -- Print_Expr -- 642 ---------------- 643 644 procedure Print_Expr (Val : Node_Ref_Or_Val) is 645 begin 646 if Val >= 0 then 647 UI_Write (Val, Decimal); 648 649 else 650 declare 651 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 652 653 procedure Unop (S : String); 654 -- Output text for unary operator with S being operator name 655 656 procedure Binop (S : String); 657 -- Output text for binary operator with S being operator name 658 659 ---------- 660 -- Unop -- 661 ---------- 662 663 procedure Unop (S : String) is 664 begin 665 if List_Representation_Info_To_JSON then 666 Write_Str ("{ ""code"": """); 667 if S (S'Last) = ' ' then 668 Write_Str (S (S'First .. S'Last - 1)); 669 else 670 Write_Str (S); 671 end if; 672 Write_Str (""", ""operands"": [ "); 673 Print_Expr (Node.Op1); 674 Write_Str (" ] }"); 675 else 676 Write_Str (S); 677 Print_Expr (Node.Op1); 678 end if; 679 end Unop; 680 681 ----------- 682 -- Binop -- 683 ----------- 684 685 procedure Binop (S : String) is 686 begin 687 if List_Representation_Info_To_JSON then 688 Write_Str ("{ ""code"": """); 689 Write_Str (S (S'First + 1 .. S'Last - 1)); 690 Write_Str (""", ""operands"": [ "); 691 Print_Expr (Node.Op1); 692 Write_Str (", "); 693 Print_Expr (Node.Op2); 694 Write_Str (" ] }"); 695 else 696 Write_Char ('('); 697 Print_Expr (Node.Op1); 698 Write_Str (S); 699 Print_Expr (Node.Op2); 700 Write_Char (')'); 701 end if; 702 end Binop; 703 704 -- Start of processing for Print_Expr 705 706 begin 707 case Node.Expr is 708 when Cond_Expr => 709 if List_Representation_Info_To_JSON then 710 Write_Str ("{ ""code"": ""?<>"""); 711 Write_Str (", ""operands"": [ "); 712 Print_Expr (Node.Op1); 713 Write_Str (", "); 714 Print_Expr (Node.Op2); 715 Write_Str (", "); 716 Print_Expr (Node.Op3); 717 Write_Str (" ] }"); 718 else 719 Write_Str ("(if "); 720 Print_Expr (Node.Op1); 721 Write_Str (" then "); 722 Print_Expr (Node.Op2); 723 Write_Str (" else "); 724 Print_Expr (Node.Op3); 725 Write_Str (" end)"); 726 end if; 727 728 when Plus_Expr => 729 Binop (" + "); 730 731 when Minus_Expr => 732 Binop (" - "); 733 734 when Mult_Expr => 735 Binop (" * "); 736 737 when Trunc_Div_Expr => 738 Binop (" /t "); 739 740 when Ceil_Div_Expr => 741 Binop (" /c "); 742 743 when Floor_Div_Expr => 744 Binop (" /f "); 745 746 when Trunc_Mod_Expr => 747 Binop (" modt "); 748 749 when Ceil_Mod_Expr => 750 Binop (" modc "); 751 752 when Floor_Mod_Expr => 753 Binop (" modf "); 754 755 when Exact_Div_Expr => 756 Binop (" /e "); 757 758 when Negate_Expr => 759 Unop ("-"); 760 761 when Min_Expr => 762 Binop (" min "); 763 764 when Max_Expr => 765 Binop (" max "); 766 767 when Abs_Expr => 768 Unop ("abs "); 769 770 when Truth_And_Expr => 771 Binop (" and "); 772 773 when Truth_Or_Expr => 774 Binop (" or "); 775 776 when Truth_Xor_Expr => 777 Binop (" xor "); 778 779 when Truth_Not_Expr => 780 Unop ("not "); 781 782 when Lt_Expr => 783 Binop (" < "); 784 785 when Le_Expr => 786 Binop (" <= "); 787 788 when Gt_Expr => 789 Binop (" > "); 790 791 when Ge_Expr => 792 Binop (" >= "); 793 794 when Eq_Expr => 795 Binop (" == "); 796 797 when Ne_Expr => 798 Binop (" != "); 799 800 when Bit_And_Expr => 801 Binop (" & "); 802 803 when Discrim_Val => 804 Unop ("#"); 805 806 when Dynamic_Val => 807 Unop ("var"); 808 end case; 809 end; 810 end if; 811 end Print_Expr; 812 813 -- Start of processing for List_GCC_Expression 814 815 begin 816 if No (U) then 817 Write_Unknown_Val; 818 else 819 Print_Expr (U); 820 end if; 821 end List_GCC_Expression; 822 823 ------------------------- 824 -- List_Linker_Section -- 825 ------------------------- 826 827 procedure List_Linker_Section (Ent : Entity_Id) is 828 Args : List_Id; 829 Sect : Node_Id; 830 831 begin 832 if Present (Linker_Section_Pragma (Ent)) then 833 Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent)); 834 Sect := Expr_Value_S (Get_Pragma_Arg (Last (Args))); 835 836 if List_Representation_Info_To_JSON then 837 Write_Line (","); 838 Write_Str (" ""Linker_Section"": """); 839 else 840 Write_Str ("pragma Linker_Section ("); 841 List_Name (Ent); 842 Write_Str (", """); 843 end if; 844 845 pragma Assert (Nkind (Sect) = N_String_Literal); 846 String_To_Name_Buffer (Strval (Sect)); 847 Write_Str (Name_Buffer (1 .. Name_Len)); 848 Write_Str (""""); 849 if not List_Representation_Info_To_JSON then 850 Write_Line (");"); 851 end if; 852 end if; 853 end List_Linker_Section; 854 855 ------------------- 856 -- List_Location -- 857 ------------------- 858 859 procedure List_Location (Ent : Entity_Id) is 860 begin 861 pragma Assert (List_Representation_Info_To_JSON); 862 Write_Str (" ""location"": """); 863 Write_Location (Sloc (Ent)); 864 Write_Line (""","); 865 end List_Location; 866 867 --------------- 868 -- List_Name -- 869 --------------- 870 871 procedure List_Name (Ent : Entity_Id) is 872 C : Character; 873 874 begin 875 -- List the qualified name recursively, except 876 -- at compilation unit level in default mode. 877 878 if Is_Compilation_Unit (Ent) then 879 null; 880 elsif not Is_Compilation_Unit (Scope (Ent)) 881 or else List_Representation_Info_To_JSON 882 then 883 List_Name (Scope (Ent)); 884 Write_Char ('.'); 885 end if; 886 887 Get_Unqualified_Decoded_Name_String (Chars (Ent)); 888 Set_Casing (Unit_Casing); 889 890 -- The name of operators needs to be properly escaped for JSON 891 892 for J in 1 .. Name_Len loop 893 C := Name_Buffer (J); 894 if C = '"' and then List_Representation_Info_To_JSON then 895 Write_Char ('\'); 896 end if; 897 Write_Char (C); 898 end loop; 899 end List_Name; 900 901 --------------------- 902 -- List_Object_Info -- 903 --------------------- 904 905 procedure List_Object_Info (Ent : Entity_Id) is 906 begin 907 -- The information has not been computed in a generic unit, so don't try 908 -- to print it. 909 910 if Sem_Util.In_Generic_Scope (Ent) then 911 return; 912 end if; 913 914 Write_Separator; 915 916 if List_Representation_Info_To_JSON then 917 Write_Line ("{"); 918 919 Write_Str (" ""name"": """); 920 List_Name (Ent); 921 Write_Line (""","); 922 List_Location (Ent); 923 924 Write_Str (" ""Size"": "); 925 Write_Val (Esize (Ent)); 926 Write_Line (","); 927 928 Write_Str (" ""Alignment"": "); 929 Write_Val (Alignment (Ent)); 930 931 List_Linker_Section (Ent); 932 933 Write_Eol; 934 Write_Line ("}"); 935 else 936 Write_Str ("for "); 937 List_Name (Ent); 938 Write_Str ("'Size use "); 939 Write_Val (Esize (Ent)); 940 Write_Line (";"); 941 942 Write_Str ("for "); 943 List_Name (Ent); 944 Write_Str ("'Alignment use "); 945 Write_Val (Alignment (Ent)); 946 Write_Line (";"); 947 948 List_Linker_Section (Ent); 949 end if; 950 951 -- The type is relevant for an object 952 953 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then 954 Relevant_Entities.Set (Etype (Ent), True); 955 end if; 956 end List_Object_Info; 957 958 ---------------------- 959 -- List_Record_Info -- 960 ---------------------- 961 962 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 963 procedure Compute_Max_Length 964 (Ent : Entity_Id; 965 Starting_Position : Uint := Uint_0; 966 Starting_First_Bit : Uint := Uint_0; 967 Prefix_Length : Natural := 0); 968 -- Internal recursive procedure to compute the max length 969 970 procedure List_Component_Layout 971 (Ent : Entity_Id; 972 Starting_Position : Uint := Uint_0; 973 Starting_First_Bit : Uint := Uint_0; 974 Prefix : String := ""; 975 Indent : Natural := 0); 976 -- Procedure to display the layout of a single component 977 978 procedure List_Record_Layout 979 (Ent : Entity_Id; 980 Starting_Position : Uint := Uint_0; 981 Starting_First_Bit : Uint := Uint_0; 982 Prefix : String := ""); 983 -- Internal recursive procedure to display the layout 984 985 procedure List_Structural_Record_Layout 986 (Ent : Entity_Id; 987 Ext_Ent : Entity_Id; 988 Ext_Level : Nat := 0; 989 Variant : Node_Id := Empty; 990 Indent : Natural := 0); 991 -- Internal recursive procedure to display the structural layout. 992 -- If Ext_Ent is not equal to Ent, it is an extension of Ent and 993 -- Ext_Level is the number of successive extensions between them. 994 -- If Variant is present, it's for a variant in the variant part 995 -- instead of the common part of Ent. Indent is the indentation. 996 997 Incomplete_Layout : exception; 998 -- Exception raised if the layout is incomplete in -gnatc mode 999 1000 Not_In_Extended_Main : exception; 1001 -- Exception raised when an ancestor is not declared in the main unit 1002 1003 Max_Name_Length : Natural := 0; 1004 Max_Spos_Length : Natural := 0; 1005 1006 ------------------------ 1007 -- Compute_Max_Length -- 1008 ------------------------ 1009 1010 procedure Compute_Max_Length 1011 (Ent : Entity_Id; 1012 Starting_Position : Uint := Uint_0; 1013 Starting_First_Bit : Uint := Uint_0; 1014 Prefix_Length : Natural := 0) 1015 is 1016 Comp : Entity_Id; 1017 1018 begin 1019 Comp := First_Component_Or_Discriminant (Ent); 1020 while Present (Comp) loop 1021 1022 -- Skip a completely hidden discriminant or a discriminant in an 1023 -- unchecked union (since it is not there). 1024 1025 if Ekind (Comp) = E_Discriminant 1026 and then (Is_Completely_Hidden (Comp) 1027 or else Is_Unchecked_Union (Ent)) 1028 then 1029 goto Continue; 1030 end if; 1031 1032 -- Skip _Parent component in extension (to avoid overlap) 1033 1034 if Chars (Comp) = Name_uParent then 1035 goto Continue; 1036 end if; 1037 1038 -- All other cases 1039 1040 declare 1041 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp)); 1042 Bofs : constant Uint := Component_Bit_Offset (Comp); 1043 Npos : Uint; 1044 Fbit : Uint; 1045 Spos : Uint; 1046 Sbit : Uint; 1047 1048 Name_Length : Natural; 1049 1050 begin 1051 Get_Decoded_Name_String (Chars (Comp)); 1052 Name_Length := Prefix_Length + Name_Len; 1053 1054 if Rep_Not_Constant (Bofs) then 1055 1056 -- If the record is not packed, then we know that all fields 1057 -- whose position is not specified have starting normalized 1058 -- bit position of zero. 1059 1060 if not Known_Normalized_First_Bit (Comp) 1061 and then not Is_Packed (Ent) 1062 then 1063 Set_Normalized_First_Bit (Comp, Uint_0); 1064 end if; 1065 1066 UI_Image_Length := 2; -- For "??" marker 1067 else 1068 Npos := Bofs / SSU; 1069 Fbit := Bofs mod SSU; 1070 1071 -- Complete annotation in case not done 1072 1073 if not Known_Normalized_First_Bit (Comp) then 1074 Set_Normalized_Position (Comp, Npos); 1075 Set_Normalized_First_Bit (Comp, Fbit); 1076 end if; 1077 1078 Spos := Starting_Position + Npos; 1079 Sbit := Starting_First_Bit + Fbit; 1080 1081 if Sbit >= SSU then 1082 Spos := Spos + 1; 1083 Sbit := Sbit - SSU; 1084 end if; 1085 1086 -- If extended information is requested, recurse fully into 1087 -- record components, i.e. skip the outer level. 1088 1089 if List_Representation_Info_Extended 1090 and then Is_Record_Type (Ctyp) 1091 then 1092 Compute_Max_Length (Ctyp, Spos, Sbit, Name_Length + 1); 1093 goto Continue; 1094 end if; 1095 1096 UI_Image (Spos); 1097 end if; 1098 1099 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Length); 1100 Max_Spos_Length := 1101 Natural'Max (Max_Spos_Length, UI_Image_Length); 1102 end; 1103 1104 <<Continue>> 1105 Next_Component_Or_Discriminant (Comp); 1106 end loop; 1107 end Compute_Max_Length; 1108 1109 --------------------------- 1110 -- List_Component_Layout -- 1111 --------------------------- 1112 1113 procedure List_Component_Layout 1114 (Ent : Entity_Id; 1115 Starting_Position : Uint := Uint_0; 1116 Starting_First_Bit : Uint := Uint_0; 1117 Prefix : String := ""; 1118 Indent : Natural := 0) 1119 is 1120 Esiz : constant Uint := Esize (Ent); 1121 Npos : constant Uint := Normalized_Position (Ent); 1122 Fbit : constant Uint := Normalized_First_Bit (Ent); 1123 Spos : Uint; 1124 Sbit : Uint := No_Uint; 1125 Lbit : Uint; 1126 1127 begin 1128 if List_Representation_Info_To_JSON then 1129 Spaces (Indent); 1130 Write_Line (" {"); 1131 Spaces (Indent); 1132 Write_Str (" ""name"": """); 1133 Write_Str (Prefix); 1134 Write_Str (Name_Buffer (1 .. Name_Len)); 1135 Write_Line (""","); 1136 if Ekind (Ent) = E_Discriminant then 1137 Spaces (Indent); 1138 Write_Str (" ""discriminant"": "); 1139 UI_Write (Discriminant_Number (Ent), Decimal); 1140 Write_Line (","); 1141 end if; 1142 Spaces (Indent); 1143 Write_Str (" ""Position"": "); 1144 else 1145 Write_Str (" "); 1146 Write_Str (Prefix); 1147 Write_Str (Name_Buffer (1 .. Name_Len)); 1148 Spaces (Max_Name_Length - Prefix'Length - Name_Len); 1149 Write_Str (" at "); 1150 end if; 1151 1152 if Known_Static_Normalized_Position (Ent) then 1153 Spos := Starting_Position + Npos; 1154 Sbit := Starting_First_Bit + Fbit; 1155 1156 if Sbit >= SSU then 1157 Spos := Spos + 1; 1158 end if; 1159 1160 UI_Image (Spos); 1161 Spaces (Max_Spos_Length - UI_Image_Length); 1162 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length)); 1163 1164 elsif Known_Normalized_Position (Ent) 1165 and then List_Representation_Info >= 3 1166 then 1167 Spaces (Max_Spos_Length - 2); 1168 1169 if Starting_Position /= Uint_0 then 1170 UI_Write (Starting_Position, Decimal); 1171 Write_Str (" + "); 1172 end if; 1173 1174 Write_Val (Npos); 1175 1176 else 1177 Write_Unknown_Val; 1178 end if; 1179 1180 if List_Representation_Info_To_JSON then 1181 Write_Line (","); 1182 Spaces (Indent); 1183 Write_Str (" ""First_Bit"": "); 1184 else 1185 Write_Str (" range "); 1186 end if; 1187 1188 if Known_Static_Normalized_First_Bit (Ent) then 1189 Sbit := Starting_First_Bit + Fbit; 1190 1191 if Sbit >= SSU then 1192 Sbit := Sbit - SSU; 1193 end if; 1194 1195 UI_Write (Sbit, Decimal); 1196 else 1197 Write_Unknown_Val; 1198 end if; 1199 1200 if List_Representation_Info_To_JSON then 1201 Write_Line (", "); 1202 Spaces (Indent); 1203 Write_Str (" ""Size"": "); 1204 else 1205 Write_Str (" .. "); 1206 end if; 1207 1208 if Known_Static_Esize (Ent) 1209 and then Known_Static_Normalized_First_Bit (Ent) 1210 then 1211 Lbit := Sbit + Esiz - 1; 1212 1213 if List_Representation_Info_To_JSON then 1214 UI_Write (Esiz, Decimal); 1215 else 1216 if Lbit >= 0 and then Lbit < 10 then 1217 Write_Char (' '); 1218 end if; 1219 1220 UI_Write (Lbit, Decimal); 1221 end if; 1222 1223 elsif List_Representation_Info < 3 or else not Known_Esize (Ent) then 1224 Write_Unknown_Val; 1225 1226 -- List_Representation >= 3 and Known_Esize (Ent) 1227 1228 else 1229 Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON); 1230 1231 -- Add appropriate first bit offset 1232 1233 if not List_Representation_Info_To_JSON then 1234 if Sbit = 0 then 1235 Write_Str (" - 1"); 1236 1237 elsif Sbit = 1 then 1238 null; 1239 1240 else 1241 Write_Str (" + "); 1242 Write_Int (UI_To_Int (Sbit) - 1); 1243 end if; 1244 end if; 1245 end if; 1246 1247 if List_Representation_Info_To_JSON then 1248 Write_Eol; 1249 Spaces (Indent); 1250 Write_Str (" }"); 1251 else 1252 Write_Line (";"); 1253 end if; 1254 1255 -- The type is relevant for a component 1256 1257 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then 1258 Relevant_Entities.Set (Etype (Ent), True); 1259 end if; 1260 end List_Component_Layout; 1261 1262 ------------------------ 1263 -- List_Record_Layout -- 1264 ------------------------ 1265 1266 procedure List_Record_Layout 1267 (Ent : Entity_Id; 1268 Starting_Position : Uint := Uint_0; 1269 Starting_First_Bit : Uint := Uint_0; 1270 Prefix : String := "") 1271 is 1272 Comp : Entity_Id; 1273 First : Boolean := True; 1274 1275 begin 1276 Comp := First_Component_Or_Discriminant (Ent); 1277 while Present (Comp) loop 1278 1279 -- Skip a completely hidden discriminant or a discriminant in an 1280 -- unchecked union (since it is not there). 1281 1282 if Ekind (Comp) = E_Discriminant 1283 and then (Is_Completely_Hidden (Comp) 1284 or else Is_Unchecked_Union (Ent)) 1285 then 1286 goto Continue; 1287 end if; 1288 1289 -- Skip _Parent component in extension (to avoid overlap) 1290 1291 if Chars (Comp) = Name_uParent then 1292 goto Continue; 1293 end if; 1294 1295 -- All other cases 1296 1297 declare 1298 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp)); 1299 Npos : constant Uint := Normalized_Position (Comp); 1300 Fbit : constant Uint := Normalized_First_Bit (Comp); 1301 Spos : Uint; 1302 Sbit : Uint; 1303 1304 begin 1305 Get_Decoded_Name_String (Chars (Comp)); 1306 Set_Casing (Unit_Casing); 1307 1308 -- If extended information is requested, recurse fully into 1309 -- record components, i.e. skip the outer level. 1310 1311 if List_Representation_Info_Extended 1312 and then Is_Record_Type (Ctyp) 1313 and then Known_Static_Normalized_Position (Comp) 1314 and then Known_Static_Normalized_First_Bit (Comp) 1315 then 1316 Spos := Starting_Position + Npos; 1317 Sbit := Starting_First_Bit + Fbit; 1318 1319 if Sbit >= SSU then 1320 Spos := Spos + 1; 1321 Sbit := Sbit - SSU; 1322 end if; 1323 1324 List_Record_Layout (Ctyp, 1325 Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & "."); 1326 1327 goto Continue; 1328 end if; 1329 1330 if List_Representation_Info_To_JSON then 1331 if First then 1332 Write_Eol; 1333 First := False; 1334 else 1335 Write_Line (","); 1336 end if; 1337 end if; 1338 1339 -- The Parent_Subtype in an extension is not back-annotated 1340 1341 List_Component_Layout ( 1342 (if Known_Normalized_Position (Comp) 1343 then Comp 1344 else Original_Record_Component (Comp)), 1345 Starting_Position, Starting_First_Bit, Prefix); 1346 end; 1347 1348 <<Continue>> 1349 Next_Component_Or_Discriminant (Comp); 1350 end loop; 1351 end List_Record_Layout; 1352 1353 ----------------------------------- 1354 -- List_Structural_Record_Layout -- 1355 ----------------------------------- 1356 1357 procedure List_Structural_Record_Layout 1358 (Ent : Entity_Id; 1359 Ext_Ent : Entity_Id; 1360 Ext_Level : Nat := 0; 1361 Variant : Node_Id := Empty; 1362 Indent : Natural := 0) 1363 is 1364 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id; 1365 -- This function assumes that Ext_Ent is an extension of Ent. 1366 -- Disc is a discriminant of Ent that does not itself constrain a 1367 -- discriminant of the parent type of Ent. Return the discriminant 1368 -- of Ext_Ent that ultimately constrains Disc, if any. 1369 1370 ---------------------------- 1371 -- Derived_Discriminant -- 1372 ---------------------------- 1373 1374 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is 1375 Corr_Disc : Entity_Id; 1376 Derived_Disc : Entity_Id; 1377 1378 begin 1379 Derived_Disc := First_Discriminant (Ext_Ent); 1380 1381 -- Loop over the discriminants of the extension 1382 1383 while Present (Derived_Disc) loop 1384 1385 -- Check if this discriminant constrains another discriminant. 1386 -- If so, find the ultimately constrained discriminant and 1387 -- compare with the original components in the base type. 1388 1389 if Present (Corresponding_Discriminant (Derived_Disc)) then 1390 Corr_Disc := Corresponding_Discriminant (Derived_Disc); 1391 1392 while Present (Corresponding_Discriminant (Corr_Disc)) loop 1393 Corr_Disc := Corresponding_Discriminant (Corr_Disc); 1394 end loop; 1395 1396 if Original_Record_Component (Corr_Disc) = 1397 Original_Record_Component (Disc) 1398 then 1399 return Derived_Disc; 1400 end if; 1401 end if; 1402 1403 Next_Discriminant (Derived_Disc); 1404 end loop; 1405 1406 -- Disc is not constrained by a discriminant of Ext_Ent 1407 1408 return Empty; 1409 end Derived_Discriminant; 1410 1411 -- Local declarations 1412 1413 Comp : Node_Id; 1414 Comp_List : Node_Id; 1415 First : Boolean := True; 1416 Var : Node_Id; 1417 1418 -- Start of processing for List_Structural_Record_Layout 1419 1420 begin 1421 -- If we are dealing with a variant, just process the components 1422 1423 if Present (Variant) then 1424 Comp_List := Component_List (Variant); 1425 1426 -- Otherwise, we are dealing with the full record and need to get 1427 -- to its definition in order to retrieve its structural layout. 1428 1429 else 1430 declare 1431 Definition : Node_Id := 1432 Type_Definition (Declaration_Node (Ent)); 1433 1434 Is_Extension : constant Boolean := 1435 Is_Tagged_Type (Ent) 1436 and then Nkind (Definition) = 1437 N_Derived_Type_Definition; 1438 1439 Disc : Entity_Id; 1440 Listed_Disc : Entity_Id; 1441 Parent_Type : Entity_Id; 1442 1443 begin 1444 -- If this is an extension, first list the layout of the parent 1445 -- and then proceed to the extension part, if any. 1446 1447 if Is_Extension then 1448 Parent_Type := Parent_Subtype (Ent); 1449 if No (Parent_Type) then 1450 raise Incomplete_Layout; 1451 end if; 1452 1453 if Is_Private_Type (Parent_Type) then 1454 Parent_Type := Full_View (Parent_Type); 1455 pragma Assert (Present (Parent_Type)); 1456 end if; 1457 1458 -- Do not list variants if one of them has been selected 1459 1460 if Has_Static_Discriminants (Parent_Type) then 1461 List_Record_Layout (Parent_Type); 1462 1463 else 1464 Parent_Type := Base_Type (Parent_Type); 1465 if not In_Extended_Main_Source_Unit (Parent_Type) then 1466 raise Not_In_Extended_Main; 1467 end if; 1468 1469 List_Structural_Record_Layout 1470 (Parent_Type, Ext_Ent, Ext_Level + 1); 1471 end if; 1472 1473 First := False; 1474 1475 if Present (Record_Extension_Part (Definition)) then 1476 Definition := Record_Extension_Part (Definition); 1477 end if; 1478 end if; 1479 1480 -- If the record has discriminants and is not an unchecked 1481 -- union, then display them now. Note that, even if this is 1482 -- a structural layout, we list the visible discriminants. 1483 1484 if Has_Discriminants (Ent) 1485 and then not Is_Unchecked_Union (Ent) 1486 then 1487 Disc := First_Discriminant (Ent); 1488 while Present (Disc) loop 1489 1490 -- If this is a record extension and the discriminant is 1491 -- the renaming of another discriminant, skip it. 1492 1493 if Is_Extension 1494 and then Present (Corresponding_Discriminant (Disc)) 1495 then 1496 goto Continue_Disc; 1497 end if; 1498 1499 -- If this is the parent type of an extension, retrieve 1500 -- the derived discriminant from the extension, if any. 1501 1502 if Ent /= Ext_Ent then 1503 Listed_Disc := Derived_Discriminant (Disc); 1504 1505 if No (Listed_Disc) then 1506 goto Continue_Disc; 1507 end if; 1508 else 1509 Listed_Disc := Disc; 1510 end if; 1511 1512 Get_Decoded_Name_String (Chars (Listed_Disc)); 1513 Set_Casing (Unit_Casing); 1514 1515 if First then 1516 Write_Eol; 1517 First := False; 1518 else 1519 Write_Line (","); 1520 end if; 1521 1522 List_Component_Layout (Listed_Disc, Indent => Indent); 1523 1524 <<Continue_Disc>> 1525 Next_Discriminant (Disc); 1526 end loop; 1527 end if; 1528 1529 Comp_List := Component_List (Definition); 1530 end; 1531 end if; 1532 1533 -- Bail out for the null record 1534 1535 if No (Comp_List) then 1536 return; 1537 end if; 1538 1539 -- Now deal with the regular components, if any 1540 1541 if Present (Component_Items (Comp_List)) then 1542 Comp := First_Non_Pragma (Component_Items (Comp_List)); 1543 while Present (Comp) loop 1544 1545 -- Skip _Parent component in extension (to avoid overlap) 1546 1547 if Chars (Defining_Identifier (Comp)) = Name_uParent then 1548 goto Continue_Comp; 1549 end if; 1550 1551 Get_Decoded_Name_String (Chars (Defining_Identifier (Comp))); 1552 Set_Casing (Unit_Casing); 1553 1554 if First then 1555 Write_Eol; 1556 First := False; 1557 else 1558 Write_Line (","); 1559 end if; 1560 1561 List_Component_Layout 1562 (Defining_Identifier (Comp), Indent => Indent); 1563 1564 <<Continue_Comp>> 1565 Next_Non_Pragma (Comp); 1566 end loop; 1567 end if; 1568 1569 -- We are done if there is no variant part 1570 1571 if No (Variant_Part (Comp_List)) then 1572 return; 1573 end if; 1574 1575 Write_Eol; 1576 Spaces (Indent); 1577 Write_Line (" ],"); 1578 Spaces (Indent); 1579 Write_Str (" """); 1580 for J in 1 .. Ext_Level loop 1581 Write_Str ("parent_"); 1582 end loop; 1583 Write_Str ("variant"" : ["); 1584 1585 -- Otherwise we recurse on each variant 1586 1587 Var := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 1588 First := True; 1589 while Present (Var) loop 1590 if First then 1591 Write_Eol; 1592 First := False; 1593 else 1594 Write_Line (","); 1595 end if; 1596 1597 Spaces (Indent); 1598 Write_Line (" {"); 1599 Spaces (Indent); 1600 Write_Str (" ""present"": "); 1601 Write_Val (Present_Expr (Var)); 1602 Write_Line (","); 1603 Spaces (Indent); 1604 Write_Str (" ""record"": ["); 1605 1606 List_Structural_Record_Layout 1607 (Ent, Ext_Ent, Ext_Level, Var, Indent + 4); 1608 1609 Write_Eol; 1610 Spaces (Indent); 1611 Write_Line (" ]"); 1612 Spaces (Indent); 1613 Write_Str (" }"); 1614 Next_Non_Pragma (Var); 1615 end loop; 1616 end List_Structural_Record_Layout; 1617 1618 -- Start of processing for List_Record_Info 1619 1620 begin 1621 Write_Separator; 1622 1623 if List_Representation_Info_To_JSON then 1624 Write_Line ("{"); 1625 end if; 1626 1627 List_Common_Type_Info (Ent); 1628 1629 -- First find out max line length and max starting position 1630 -- length, for the purpose of lining things up nicely. 1631 1632 Compute_Max_Length (Ent); 1633 1634 -- Then do actual output based on those values 1635 1636 if List_Representation_Info_To_JSON then 1637 Write_Line (","); 1638 Write_Str (" ""record"": ["); 1639 1640 -- ??? We can output structural layout only for base types fully 1641 -- declared in the extended main source unit for the time being, 1642 -- because otherwise declarations might not be processed at all. 1643 1644 if Is_Base_Type (Ent) then 1645 begin 1646 List_Structural_Record_Layout (Ent, Ent); 1647 1648 exception 1649 when Incomplete_Layout 1650 | Not_In_Extended_Main 1651 => 1652 List_Record_Layout (Ent); 1653 1654 when others => 1655 raise Program_Error; 1656 end; 1657 else 1658 List_Record_Layout (Ent); 1659 end if; 1660 1661 Write_Eol; 1662 Write_Str (" ]"); 1663 else 1664 Write_Str ("for "); 1665 List_Name (Ent); 1666 Write_Line (" use record"); 1667 1668 List_Record_Layout (Ent); 1669 1670 Write_Line ("end record;"); 1671 end if; 1672 1673 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 1674 1675 List_Linker_Section (Ent); 1676 1677 if List_Representation_Info_To_JSON then 1678 Write_Eol; 1679 Write_Line ("}"); 1680 end if; 1681 1682 -- The type is relevant for a record subtype 1683 1684 if List_Representation_Info = 4 1685 and then not Is_Base_Type (Ent) 1686 and then Is_Itype (Etype (Ent)) 1687 then 1688 Relevant_Entities.Set (Etype (Ent), True); 1689 end if; 1690 end List_Record_Info; 1691 1692 ------------------- 1693 -- List_Rep_Info -- 1694 ------------------- 1695 1696 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is 1697 Col : Nat; 1698 1699 begin 1700 if List_Representation_Info /= 0 1701 or else List_Representation_Info_Mechanisms 1702 then 1703 -- For the normal case, we output a single JSON stream 1704 1705 if not List_Representation_Info_To_File 1706 and then List_Representation_Info_To_JSON 1707 then 1708 Write_Line ("["); 1709 Need_Separator := False; 1710 end if; 1711 1712 for U in Main_Unit .. Last_Unit loop 1713 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then 1714 Unit_Casing := Identifier_Casing (Source_Index (U)); 1715 1716 if List_Representation_Info = 4 then 1717 Relevant_Entities.Reset; 1718 end if; 1719 1720 -- Normal case, list to standard output 1721 1722 if not List_Representation_Info_To_File then 1723 if not List_Representation_Info_To_JSON then 1724 Write_Eol; 1725 Write_Str ("Representation information for unit "); 1726 Write_Unit_Name (Unit_Name (U)); 1727 Col := Column; 1728 Write_Eol; 1729 1730 for J in 1 .. Col - 1 loop 1731 Write_Char ('-'); 1732 end loop; 1733 1734 Write_Eol; 1735 Need_Separator := True; 1736 end if; 1737 1738 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1739 1740 -- List representation information to file 1741 1742 else 1743 Create_Repinfo_File 1744 (Get_Name_String (File_Name (Source_Index (U)))); 1745 Set_Special_Output (Write_Info_Line'Access); 1746 if List_Representation_Info_To_JSON then 1747 Write_Line ("["); 1748 end if; 1749 Need_Separator := False; 1750 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1751 if List_Representation_Info_To_JSON then 1752 Write_Line ("]"); 1753 end if; 1754 Cancel_Special_Output; 1755 Close_Repinfo_File; 1756 end if; 1757 end if; 1758 end loop; 1759 1760 if not List_Representation_Info_To_File 1761 and then List_Representation_Info_To_JSON 1762 then 1763 Write_Line ("]"); 1764 end if; 1765 end if; 1766 end List_Rep_Info; 1767 1768 ------------------------------- 1769 -- List_Scalar_Storage_Order -- 1770 ------------------------------- 1771 1772 procedure List_Scalar_Storage_Order 1773 (Ent : Entity_Id; 1774 Bytes_Big_Endian : Boolean) 1775 is 1776 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean); 1777 -- Show attribute definition clause for Attr_Name (an endianness 1778 -- attribute), depending on whether or not the endianness is reversed 1779 -- compared to native endianness. 1780 1781 --------------- 1782 -- List_Attr -- 1783 --------------- 1784 1785 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is 1786 begin 1787 if List_Representation_Info_To_JSON then 1788 Write_Line (","); 1789 Write_Str (" """); 1790 Write_Str (Attr_Name); 1791 Write_Str (""": ""System."); 1792 else 1793 Write_Str ("for "); 1794 List_Name (Ent); 1795 Write_Char ('''); 1796 Write_Str (Attr_Name); 1797 Write_Str (" use System."); 1798 end if; 1799 1800 if Bytes_Big_Endian xor Is_Reversed then 1801 Write_Str ("High"); 1802 else 1803 Write_Str ("Low"); 1804 end if; 1805 1806 Write_Str ("_Order_First"); 1807 if List_Representation_Info_To_JSON then 1808 Write_Str (""""); 1809 else 1810 Write_Line (";"); 1811 end if; 1812 end List_Attr; 1813 1814 List_SSO : constant Boolean := 1815 Has_Rep_Item (Ent, Name_Scalar_Storage_Order) 1816 or else SSO_Set_Low_By_Default (Ent) 1817 or else SSO_Set_High_By_Default (Ent); 1818 -- Scalar_Storage_Order is displayed if specified explicitly or set by 1819 -- Default_Scalar_Storage_Order. 1820 1821 -- Start of processing for List_Scalar_Storage_Order 1822 1823 begin 1824 -- For record types, list Bit_Order if not default, or if SSO is shown 1825 1826 -- Also, when -gnatR4 is in effect always list bit order and scalar 1827 -- storage order explicitly, so that you don't need to know the native 1828 -- endianness of the target for which the output was produced in order 1829 -- to interpret it. 1830 1831 if Is_Record_Type (Ent) 1832 and then (List_SSO 1833 or else Reverse_Bit_Order (Ent) 1834 or else List_Representation_Info = 4) 1835 then 1836 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent)); 1837 end if; 1838 1839 -- List SSO if required. If not, then storage is supposed to be in 1840 -- native order. 1841 1842 if List_SSO or else List_Representation_Info = 4 then 1843 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent)); 1844 else 1845 pragma Assert (not Reverse_Storage_Order (Ent)); 1846 null; 1847 end if; 1848 end List_Scalar_Storage_Order; 1849 1850 -------------------------- 1851 -- List_Subprogram_Info -- 1852 -------------------------- 1853 1854 procedure List_Subprogram_Info (Ent : Entity_Id) is 1855 First : Boolean := True; 1856 Plen : Natural; 1857 Form : Entity_Id; 1858 1859 begin 1860 Write_Separator; 1861 1862 if List_Representation_Info_To_JSON then 1863 Write_Line ("{"); 1864 Write_Str (" ""name"": """); 1865 List_Name (Ent); 1866 Write_Line (""","); 1867 List_Location (Ent); 1868 1869 Write_Str (" ""Convention"": """); 1870 else 1871 case Ekind (Ent) is 1872 when E_Function => 1873 Write_Str ("function "); 1874 1875 when E_Operator => 1876 Write_Str ("operator "); 1877 1878 when E_Procedure => 1879 Write_Str ("procedure "); 1880 1881 when E_Subprogram_Type => 1882 Write_Str ("type "); 1883 1884 when E_Entry 1885 | E_Entry_Family 1886 => 1887 Write_Str ("entry "); 1888 1889 when others => 1890 raise Program_Error; 1891 end case; 1892 1893 List_Name (Ent); 1894 Write_Str (" declared at "); 1895 Write_Location (Sloc (Ent)); 1896 Write_Eol; 1897 1898 Write_Str ("convention : "); 1899 end if; 1900 1901 case Convention (Ent) is 1902 when Convention_Ada => 1903 Write_Str ("Ada"); 1904 1905 when Convention_Ada_Pass_By_Copy => 1906 Write_Str ("Ada_Pass_By_Copy"); 1907 1908 when Convention_Ada_Pass_By_Reference => 1909 Write_Str ("Ada_Pass_By_Reference"); 1910 1911 when Convention_Intrinsic => 1912 Write_Str ("Intrinsic"); 1913 1914 when Convention_Entry => 1915 Write_Str ("Entry"); 1916 1917 when Convention_Protected => 1918 Write_Str ("Protected"); 1919 1920 when Convention_Assembler => 1921 Write_Str ("Assembler"); 1922 1923 when Convention_C => 1924 Write_Str ("C"); 1925 1926 when Convention_C_Variadic => 1927 declare 1928 N : Nat := 1929 Convention_Id'Pos (Convention (Ent)) - 1930 Convention_Id'Pos (Convention_C_Variadic_0); 1931 begin 1932 Write_Str ("C_Variadic_"); 1933 if N >= 10 then 1934 Write_Char ('1'); 1935 N := N - 10; 1936 end if; 1937 pragma Assert (N < 10); 1938 Write_Char (Character'Val (Character'Pos ('0') + N)); 1939 end; 1940 1941 when Convention_COBOL => 1942 Write_Str ("COBOL"); 1943 1944 when Convention_CPP => 1945 Write_Str ("C++"); 1946 1947 when Convention_Fortran => 1948 Write_Str ("Fortran"); 1949 1950 when Convention_Stdcall => 1951 Write_Str ("Stdcall"); 1952 1953 when Convention_Stubbed => 1954 Write_Str ("Stubbed"); 1955 end case; 1956 1957 if List_Representation_Info_To_JSON then 1958 Write_Line (""","); 1959 Write_Str (" ""formal"": ["); 1960 else 1961 Write_Eol; 1962 end if; 1963 1964 -- Find max length of formal name 1965 1966 Plen := 0; 1967 Form := First_Formal (Ent); 1968 while Present (Form) loop 1969 Get_Unqualified_Decoded_Name_String (Chars (Form)); 1970 1971 if Name_Len > Plen then 1972 Plen := Name_Len; 1973 end if; 1974 1975 Next_Formal (Form); 1976 end loop; 1977 1978 -- Output formals and mechanisms 1979 1980 Form := First_Formal (Ent); 1981 while Present (Form) loop 1982 Get_Unqualified_Decoded_Name_String (Chars (Form)); 1983 Set_Casing (Unit_Casing); 1984 1985 if List_Representation_Info_To_JSON then 1986 if First then 1987 Write_Eol; 1988 First := False; 1989 else 1990 Write_Line (","); 1991 end if; 1992 1993 Write_Line (" {"); 1994 Write_Str (" ""name"": """); 1995 Write_Str (Name_Buffer (1 .. Name_Len)); 1996 Write_Line (""","); 1997 1998 Write_Str (" ""mechanism"": """); 1999 Write_Mechanism (Mechanism (Form)); 2000 Write_Line (""""); 2001 Write_Str (" }"); 2002 else 2003 while Name_Len <= Plen loop 2004 Name_Len := Name_Len + 1; 2005 Name_Buffer (Name_Len) := ' '; 2006 end loop; 2007 2008 Write_Str (" "); 2009 Write_Str (Name_Buffer (1 .. Plen + 1)); 2010 Write_Str (": passed by "); 2011 2012 Write_Mechanism (Mechanism (Form)); 2013 Write_Eol; 2014 end if; 2015 2016 Next_Formal (Form); 2017 end loop; 2018 2019 if List_Representation_Info_To_JSON then 2020 Write_Eol; 2021 Write_Str (" ]"); 2022 end if; 2023 2024 if Ekind (Ent) = E_Function then 2025 if List_Representation_Info_To_JSON then 2026 Write_Line (","); 2027 Write_Str (" ""mechanism"": """); 2028 Write_Mechanism (Mechanism (Ent)); 2029 Write_Str (""""); 2030 else 2031 Write_Str ("returns by "); 2032 Write_Mechanism (Mechanism (Ent)); 2033 Write_Eol; 2034 end if; 2035 end if; 2036 2037 if not Is_Entry (Ent) then 2038 List_Linker_Section (Ent); 2039 end if; 2040 2041 if List_Representation_Info_To_JSON then 2042 Write_Eol; 2043 Write_Line ("}"); 2044 end if; 2045 end List_Subprogram_Info; 2046 2047 -------------------- 2048 -- List_Type_Info -- 2049 -------------------- 2050 2051 procedure List_Type_Info (Ent : Entity_Id) is 2052 begin 2053 Write_Separator; 2054 2055 if List_Representation_Info_To_JSON then 2056 Write_Line ("{"); 2057 end if; 2058 2059 List_Common_Type_Info (Ent); 2060 2061 -- Special stuff for fixed-point 2062 2063 if Is_Fixed_Point_Type (Ent) then 2064 2065 -- Write small (always a static constant) 2066 2067 if List_Representation_Info_To_JSON then 2068 Write_Line (","); 2069 Write_Str (" ""Small"": "); 2070 UR_Write_To_JSON (Small_Value (Ent)); 2071 else 2072 Write_Str ("for "); 2073 List_Name (Ent); 2074 Write_Str ("'Small use "); 2075 UR_Write (Small_Value (Ent)); 2076 Write_Line (";"); 2077 end if; 2078 2079 -- Write range if static 2080 2081 declare 2082 R : constant Node_Id := Scalar_Range (Ent); 2083 2084 begin 2085 if Nkind (Low_Bound (R)) = N_Real_Literal 2086 and then 2087 Nkind (High_Bound (R)) = N_Real_Literal 2088 then 2089 if List_Representation_Info_To_JSON then 2090 Write_Line (","); 2091 Write_Str (" ""Range"": [ "); 2092 UR_Write_To_JSON (Realval (Low_Bound (R))); 2093 Write_Str (", "); 2094 UR_Write_To_JSON (Realval (High_Bound (R))); 2095 Write_Str (" ]"); 2096 else 2097 Write_Str ("for "); 2098 List_Name (Ent); 2099 Write_Str ("'Range use "); 2100 UR_Write (Realval (Low_Bound (R))); 2101 Write_Str (" .. "); 2102 UR_Write (Realval (High_Bound (R))); 2103 Write_Line (";"); 2104 end if; 2105 end if; 2106 end; 2107 end if; 2108 2109 List_Linker_Section (Ent); 2110 2111 if List_Representation_Info_To_JSON then 2112 Write_Eol; 2113 Write_Line ("}"); 2114 end if; 2115 end List_Type_Info; 2116 2117 ---------------------- 2118 -- Rep_Not_Constant -- 2119 ---------------------- 2120 2121 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is 2122 begin 2123 if No (Val) or else Val < 0 then 2124 return True; 2125 else 2126 return False; 2127 end if; 2128 end Rep_Not_Constant; 2129 2130 --------------- 2131 -- Rep_Value -- 2132 --------------- 2133 2134 function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is 2135 2136 function B (Val : Boolean) return Ubool; 2137 -- Returns Uint_0 for False, Uint_1 for True 2138 2139 function T (Val : Node_Ref_Or_Val) return Boolean; 2140 -- Returns True for 0, False for any non-zero (i.e. True) 2141 2142 function V (Val : Node_Ref_Or_Val) return Uint; 2143 -- Internal recursive routine to evaluate tree 2144 2145 function W (Val : Uint) return Word; 2146 -- Convert Val to Word, assuming Val is always in the Int range. This 2147 -- is a helper function for the evaluation of bitwise expressions like 2148 -- Bit_And_Expr, for which there is no direct support in uintp. Uint 2149 -- values out of the Int range are expected to be seen in such 2150 -- expressions only with overflowing byte sizes around, introducing 2151 -- inherent unreliabilities in computations anyway. 2152 2153 ------- 2154 -- B -- 2155 ------- 2156 2157 function B (Val : Boolean) return Ubool is 2158 begin 2159 if Val then 2160 return Uint_1; 2161 else 2162 return Uint_0; 2163 end if; 2164 end B; 2165 2166 ------- 2167 -- T -- 2168 ------- 2169 2170 function T (Val : Node_Ref_Or_Val) return Boolean is 2171 begin 2172 if V (Val) = 0 then 2173 return False; 2174 else 2175 return True; 2176 end if; 2177 end T; 2178 2179 ------- 2180 -- V -- 2181 ------- 2182 2183 function V (Val : Node_Ref_Or_Val) return Uint is 2184 L, R, Q : Uint; 2185 2186 begin 2187 if Val >= 0 then 2188 return Val; 2189 2190 else 2191 declare 2192 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 2193 2194 begin 2195 case Node.Expr is 2196 when Cond_Expr => 2197 if T (Node.Op1) then 2198 return V (Node.Op2); 2199 else 2200 return V (Node.Op3); 2201 end if; 2202 2203 when Plus_Expr => 2204 return V (Node.Op1) + V (Node.Op2); 2205 2206 when Minus_Expr => 2207 return V (Node.Op1) - V (Node.Op2); 2208 2209 when Mult_Expr => 2210 return V (Node.Op1) * V (Node.Op2); 2211 2212 when Trunc_Div_Expr => 2213 return V (Node.Op1) / V (Node.Op2); 2214 2215 when Ceil_Div_Expr => 2216 return 2217 UR_Ceiling 2218 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 2219 2220 when Floor_Div_Expr => 2221 return 2222 UR_Floor 2223 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 2224 2225 when Trunc_Mod_Expr => 2226 return V (Node.Op1) rem V (Node.Op2); 2227 2228 when Floor_Mod_Expr => 2229 return V (Node.Op1) mod V (Node.Op2); 2230 2231 when Ceil_Mod_Expr => 2232 L := V (Node.Op1); 2233 R := V (Node.Op2); 2234 Q := UR_Ceiling (L / UR_From_Uint (R)); 2235 return L - R * Q; 2236 2237 when Exact_Div_Expr => 2238 return V (Node.Op1) / V (Node.Op2); 2239 2240 when Negate_Expr => 2241 return -V (Node.Op1); 2242 2243 when Min_Expr => 2244 return UI_Min (V (Node.Op1), V (Node.Op2)); 2245 2246 when Max_Expr => 2247 return UI_Max (V (Node.Op1), V (Node.Op2)); 2248 2249 when Abs_Expr => 2250 return UI_Abs (V (Node.Op1)); 2251 2252 when Truth_And_Expr => 2253 return B (T (Node.Op1) and then T (Node.Op2)); 2254 2255 when Truth_Or_Expr => 2256 return B (T (Node.Op1) or else T (Node.Op2)); 2257 2258 when Truth_Xor_Expr => 2259 return B (T (Node.Op1) xor T (Node.Op2)); 2260 2261 when Truth_Not_Expr => 2262 return B (not T (Node.Op1)); 2263 2264 when Bit_And_Expr => 2265 L := V (Node.Op1); 2266 R := V (Node.Op2); 2267 return UI_From_Int (Int (W (L) and W (R))); 2268 2269 when Lt_Expr => 2270 return B (V (Node.Op1) < V (Node.Op2)); 2271 2272 when Le_Expr => 2273 return B (V (Node.Op1) <= V (Node.Op2)); 2274 2275 when Gt_Expr => 2276 return B (V (Node.Op1) > V (Node.Op2)); 2277 2278 when Ge_Expr => 2279 return B (V (Node.Op1) >= V (Node.Op2)); 2280 2281 when Eq_Expr => 2282 return B (V (Node.Op1) = V (Node.Op2)); 2283 2284 when Ne_Expr => 2285 return B (V (Node.Op1) /= V (Node.Op2)); 2286 2287 when Discrim_Val => 2288 declare 2289 Sub : constant Int := UI_To_Int (Node.Op1); 2290 begin 2291 pragma Assert (Sub in D'Range); 2292 return D (Sub); 2293 end; 2294 2295 when Dynamic_Val => 2296 return No_Uint; 2297 end case; 2298 end; 2299 end if; 2300 end V; 2301 2302 ------- 2303 -- W -- 2304 ------- 2305 2306 -- We use an unchecked conversion to map Int values to their Word 2307 -- bitwise equivalent, which we could not achieve with a normal type 2308 -- conversion for negative Ints. We want bitwise equivalents because W 2309 -- is used as a helper for bit operators like Bit_And_Expr, and can be 2310 -- called for negative Ints in the context of aligning expressions like 2311 -- X+Align & -Align. 2312 2313 function W (Val : Uint) return Word is 2314 function To_Word is new Ada.Unchecked_Conversion (Int, Word); 2315 begin 2316 return To_Word (UI_To_Int (Val)); 2317 end W; 2318 2319 -- Start of processing for Rep_Value 2320 2321 begin 2322 if No (Val) then 2323 return No_Uint; 2324 2325 else 2326 return V (Val); 2327 end if; 2328 end Rep_Value; 2329 2330 ------------ 2331 -- Spaces -- 2332 ------------ 2333 2334 procedure Spaces (N : Natural) is 2335 begin 2336 for J in 1 .. N loop 2337 Write_Char (' '); 2338 end loop; 2339 end Spaces; 2340 2341 --------------------- 2342 -- Write_Info_Line -- 2343 --------------------- 2344 2345 procedure Write_Info_Line (S : String) is 2346 begin 2347 Write_Repinfo_Line (S (S'First .. S'Last - 1)); 2348 end Write_Info_Line; 2349 2350 --------------------- 2351 -- Write_Mechanism -- 2352 --------------------- 2353 2354 procedure Write_Mechanism (M : Mechanism_Type) is 2355 begin 2356 case M is 2357 when 0 => 2358 Write_Str ("default"); 2359 2360 when -1 => 2361 Write_Str ("copy"); 2362 2363 when -2 => 2364 Write_Str ("reference"); 2365 2366 when others => 2367 raise Program_Error; 2368 end case; 2369 end Write_Mechanism; 2370 2371 --------------------- 2372 -- Write_Separator -- 2373 --------------------- 2374 2375 procedure Write_Separator is 2376 begin 2377 if Need_Separator then 2378 if List_Representation_Info_To_JSON then 2379 Write_Line (","); 2380 else 2381 Write_Eol; 2382 end if; 2383 else 2384 Need_Separator := True; 2385 end if; 2386 end Write_Separator; 2387 2388 ----------------------- 2389 -- Write_Unknown_Val -- 2390 ----------------------- 2391 2392 procedure Write_Unknown_Val is 2393 begin 2394 if List_Representation_Info_To_JSON then 2395 Write_Str ("""??"""); 2396 else 2397 Write_Str ("??"); 2398 end if; 2399 end Write_Unknown_Val; 2400 2401 --------------- 2402 -- Write_Val -- 2403 --------------- 2404 2405 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is 2406 begin 2407 if Rep_Not_Constant (Val) then 2408 if List_Representation_Info < 3 or else No (Val) then 2409 Write_Unknown_Val; 2410 2411 else 2412 if Paren then 2413 Write_Char ('('); 2414 end if; 2415 2416 List_GCC_Expression (Val); 2417 2418 if Paren then 2419 Write_Char (')'); 2420 end if; 2421 end if; 2422 2423 else 2424 UI_Write (Val, Decimal); 2425 end if; 2426 end Write_Val; 2427 2428end Repinfo; 2429