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