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