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-2015, 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; use 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 Stand; use Stand; 47with Stringt; use Stringt; 48with Table; use Table; 49with Uname; use Uname; 50with Urealp; use Urealp; 51 52with Ada.Unchecked_Conversion; 53 54package body Repinfo is 55 56 SSU : constant := 8; 57 -- Value for Storage_Unit, we do not want to get this from TTypes, since 58 -- this introduces problematic dependencies in ASIS, and in any case this 59 -- value is assumed to be 8 for the implementation of the DDA. 60 61 -- This is wrong for AAMP??? 62 63 --------------------------------------- 64 -- Representation of gcc Expressions -- 65 --------------------------------------- 66 67 -- This table is used only if Frontend_Layout_On_Target is False, so gigi 68 -- lays out dynamic size/offset fields using encoded gcc expressions. 69 70 -- A table internal to this unit is used to hold the values of back 71 -- annotated expressions. This table is written out by -gnatt and read 72 -- back in for ASIS processing. 73 74 -- Node values are stored as Uint values using the negative of the node 75 -- index in this table. Constants appear as non-negative Uint values. 76 77 type Exp_Node is record 78 Expr : TCode; 79 Op1 : Node_Ref_Or_Val; 80 Op2 : Node_Ref_Or_Val; 81 Op3 : Node_Ref_Or_Val; 82 end record; 83 84 -- The following representation clause ensures that the above record 85 -- has no holes. We do this so that when instances of this record are 86 -- written by Tree_Gen, we do not write uninitialized values to the file. 87 88 for Exp_Node use record 89 Expr at 0 range 0 .. 31; 90 Op1 at 4 range 0 .. 31; 91 Op2 at 8 range 0 .. 31; 92 Op3 at 12 range 0 .. 31; 93 end record; 94 95 for Exp_Node'Size use 16 * 8; 96 -- This ensures that we did not leave out any fields 97 98 package Rep_Table is new Table.Table ( 99 Table_Component_Type => Exp_Node, 100 Table_Index_Type => Nat, 101 Table_Low_Bound => 1, 102 Table_Initial => Alloc.Rep_Table_Initial, 103 Table_Increment => Alloc.Rep_Table_Increment, 104 Table_Name => "BE_Rep_Table"); 105 106 -------------------------------------------------------------- 107 -- Representation of Front-End Dynamic Size/Offset Entities -- 108 -------------------------------------------------------------- 109 110 package Dynamic_SO_Entity_Table is new Table.Table ( 111 Table_Component_Type => Entity_Id, 112 Table_Index_Type => Nat, 113 Table_Low_Bound => 1, 114 Table_Initial => Alloc.Rep_Table_Initial, 115 Table_Increment => Alloc.Rep_Table_Increment, 116 Table_Name => "FE_Rep_Table"); 117 118 Unit_Casing : Casing_Type; 119 -- Identifier casing for current unit. This is set by List_Rep_Info for 120 -- each unit, before calling subprograms which may read it. 121 122 Need_Blank_Line : Boolean; 123 -- Set True if a blank line is needed before outputting any information for 124 -- the current entity. Set True when a new entity is processed, and false 125 -- when the blank line is output. 126 127 ----------------------- 128 -- Local Subprograms -- 129 ----------------------- 130 131 function Back_End_Layout return Boolean; 132 -- Test for layout mode, True = back end, False = front end. This function 133 -- is used rather than checking the configuration parameter because we do 134 -- not want Repinfo to depend on Targparm (for ASIS) 135 136 procedure Blank_Line; 137 -- Called before outputting anything for an entity. Ensures that 138 -- a blank line precedes the output for a particular entity. 139 140 procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 141 -- This procedure lists the entities associated with the entity E, starting 142 -- with the First_Entity and using the Next_Entity link. If a nested 143 -- package is found, entities within the package are recursively processed. 144 145 procedure List_Name (Ent : Entity_Id); 146 -- List name of entity Ent in appropriate case. The name is listed with 147 -- full qualification up to but not including the compilation unit name. 148 149 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 150 -- List representation info for array type Ent 151 152 procedure List_Linker_Section (Ent : Entity_Id); 153 -- List linker section for Ent (caller has checked that Ent is an entity 154 -- for which the Linker_Section_Pragma field is defined). 155 156 procedure List_Mechanisms (Ent : Entity_Id); 157 -- List mechanism information for parameters of Ent, which is subprogram, 158 -- subprogram type, or an entry or entry family. 159 160 procedure List_Object_Info (Ent : Entity_Id); 161 -- List representation info for object Ent 162 163 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 164 -- List representation info for record type Ent 165 166 procedure List_Scalar_Storage_Order 167 (Ent : Entity_Id; 168 Bytes_Big_Endian : Boolean); 169 -- List scalar storage order information for record or array type Ent. 170 -- Also includes bit order information for record types, if necessary. 171 172 procedure List_Type_Info (Ent : Entity_Id); 173 -- List type info for type Ent 174 175 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean; 176 -- Returns True if Val represents a variable value, and False if it 177 -- represents a value that is fixed at compile time. 178 179 procedure Spaces (N : Natural); 180 -- Output given number of spaces 181 182 procedure Write_Info_Line (S : String); 183 -- Routine to write a line to Repinfo output file. This routine is passed 184 -- as a special output procedure to Output.Set_Special_Output. Note that 185 -- Write_Info_Line is called with an EOL character at the end of each line, 186 -- as per the Output spec, but the internal call to the appropriate routine 187 -- in Osint requires that the end of line sequence be stripped off. 188 189 procedure Write_Mechanism (M : Mechanism_Type); 190 -- Writes symbolic string for mechanism represented by M 191 192 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); 193 -- Given a representation value, write it out. No_Uint values or values 194 -- dependent on discriminants are written as two question marks. If the 195 -- flag Paren is set, then the output is surrounded in parentheses if it is 196 -- other than a simple value. 197 198 --------------------- 199 -- Back_End_Layout -- 200 --------------------- 201 202 function Back_End_Layout return Boolean is 203 begin 204 -- We have back end layout if the back end has made any entries in the 205 -- table of GCC expressions, otherwise we have front end layout. 206 207 return Rep_Table.Last > 0; 208 end Back_End_Layout; 209 210 ---------------- 211 -- Blank_Line -- 212 ---------------- 213 214 procedure Blank_Line is 215 begin 216 if Need_Blank_Line then 217 Write_Eol; 218 Need_Blank_Line := False; 219 end if; 220 end Blank_Line; 221 222 ------------------------ 223 -- Create_Discrim_Ref -- 224 ------------------------ 225 226 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is 227 begin 228 return Create_Node 229 (Expr => Discrim_Val, 230 Op1 => Discriminant_Number (Discr)); 231 end Create_Discrim_Ref; 232 233 --------------------------- 234 -- Create_Dynamic_SO_Ref -- 235 --------------------------- 236 237 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is 238 begin 239 Dynamic_SO_Entity_Table.Append (E); 240 return UI_From_Int (-Dynamic_SO_Entity_Table.Last); 241 end Create_Dynamic_SO_Ref; 242 243 ----------------- 244 -- Create_Node -- 245 ----------------- 246 247 function Create_Node 248 (Expr : TCode; 249 Op1 : Node_Ref_Or_Val; 250 Op2 : Node_Ref_Or_Val := No_Uint; 251 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref 252 is 253 begin 254 Rep_Table.Append ( 255 (Expr => Expr, 256 Op1 => Op1, 257 Op2 => Op2, 258 Op3 => Op3)); 259 return UI_From_Int (-Rep_Table.Last); 260 end Create_Node; 261 262 --------------------------- 263 -- Get_Dynamic_SO_Entity -- 264 --------------------------- 265 266 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is 267 begin 268 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U)); 269 end Get_Dynamic_SO_Entity; 270 271 ----------------------- 272 -- Is_Dynamic_SO_Ref -- 273 ----------------------- 274 275 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is 276 begin 277 return U < Uint_0; 278 end Is_Dynamic_SO_Ref; 279 280 ---------------------- 281 -- Is_Static_SO_Ref -- 282 ---------------------- 283 284 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is 285 begin 286 return U >= Uint_0; 287 end Is_Static_SO_Ref; 288 289 --------- 290 -- lgx -- 291 --------- 292 293 procedure lgx (U : Node_Ref_Or_Val) is 294 begin 295 List_GCC_Expression (U); 296 Write_Eol; 297 end lgx; 298 299 ---------------------- 300 -- List_Array_Info -- 301 ---------------------- 302 303 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 304 begin 305 List_Type_Info (Ent); 306 Write_Str ("for "); 307 List_Name (Ent); 308 Write_Str ("'Component_Size use "); 309 Write_Val (Component_Size (Ent)); 310 Write_Line (";"); 311 312 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 313 end List_Array_Info; 314 315 ------------------- 316 -- List_Entities -- 317 ------------------- 318 319 procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 320 Body_E : Entity_Id; 321 E : Entity_Id; 322 323 function Find_Declaration (E : Entity_Id) return Node_Id; 324 -- Utility to retrieve declaration node for entity in the 325 -- case of package bodies and subprograms. 326 327 ---------------------- 328 -- Find_Declaration -- 329 ---------------------- 330 331 function Find_Declaration (E : Entity_Id) return Node_Id is 332 Decl : Node_Id; 333 334 begin 335 Decl := Parent (E); 336 while Present (Decl) 337 and then Nkind (Decl) /= N_Package_Body 338 and then Nkind (Decl) /= N_Subprogram_Declaration 339 and then Nkind (Decl) /= N_Subprogram_Body 340 loop 341 Decl := Parent (Decl); 342 end loop; 343 344 return Decl; 345 end Find_Declaration; 346 347 -- Start of processing for List_Entities 348 349 begin 350 -- List entity if we have one, and it is not a renaming declaration. 351 -- For renamings, we don't get proper information, and really it makes 352 -- sense to restrict the output to the renamed entity. 353 354 if Present (Ent) 355 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration 356 then 357 -- If entity is a subprogram and we are listing mechanisms, 358 -- then we need to list mechanisms for this entity. 359 360 if List_Representation_Info_Mechanisms 361 and then (Is_Subprogram (Ent) 362 or else Ekind (Ent) = E_Entry 363 or else Ekind (Ent) = E_Entry_Family) 364 then 365 Need_Blank_Line := True; 366 List_Mechanisms (Ent); 367 end if; 368 369 E := First_Entity (Ent); 370 while Present (E) loop 371 Need_Blank_Line := True; 372 373 -- We list entities that come from source (excluding private or 374 -- incomplete types or deferred constants, where we will list the 375 -- info for the full view). If debug flag A is set, then all 376 -- entities are listed 377 378 if (Comes_From_Source (E) 379 and then not Is_Incomplete_Or_Private_Type (E) 380 and then not (Ekind (E) = E_Constant 381 and then Present (Full_View (E)))) 382 or else Debug_Flag_AA 383 then 384 if Is_Subprogram (E) then 385 List_Linker_Section (E); 386 387 if List_Representation_Info_Mechanisms then 388 List_Mechanisms (E); 389 end if; 390 391 elsif Ekind_In (E, E_Entry, 392 E_Entry_Family, 393 E_Subprogram_Type) 394 then 395 if List_Representation_Info_Mechanisms then 396 List_Mechanisms (E); 397 end if; 398 399 elsif Is_Record_Type (E) then 400 if List_Representation_Info >= 1 then 401 List_Record_Info (E, Bytes_Big_Endian); 402 end if; 403 404 List_Linker_Section (E); 405 406 elsif Is_Array_Type (E) then 407 if List_Representation_Info >= 1 then 408 List_Array_Info (E, Bytes_Big_Endian); 409 end if; 410 411 List_Linker_Section (E); 412 413 elsif Is_Type (E) then 414 if List_Representation_Info >= 2 then 415 List_Type_Info (E); 416 List_Linker_Section (E); 417 end if; 418 419 elsif Ekind_In (E, E_Variable, E_Constant) then 420 if List_Representation_Info >= 2 then 421 List_Object_Info (E); 422 List_Linker_Section (E); 423 end if; 424 425 elsif Ekind (E) = E_Loop_Parameter or else Is_Formal (E) then 426 if List_Representation_Info >= 2 then 427 List_Object_Info (E); 428 end if; 429 end if; 430 431 -- Recurse into nested package, but not if they are package 432 -- renamings (in particular renamings of the enclosing package, 433 -- as for some Java bindings and for generic instances). 434 435 if Ekind (E) = E_Package then 436 if No (Renamed_Object (E)) then 437 List_Entities (E, Bytes_Big_Endian); 438 end if; 439 440 -- Recurse into bodies 441 442 elsif Ekind_In (E, E_Protected_Type, 443 E_Task_Type, 444 E_Subprogram_Body, 445 E_Package_Body, 446 E_Task_Body, 447 E_Protected_Body) 448 then 449 List_Entities (E, Bytes_Big_Endian); 450 451 -- Recurse into blocks 452 453 elsif Ekind (E) = E_Block then 454 List_Entities (E, Bytes_Big_Endian); 455 end if; 456 end if; 457 458 E := Next_Entity (E); 459 end loop; 460 461 -- For a package body, the entities of the visible subprograms are 462 -- declared in the corresponding spec. Iterate over its entities in 463 -- order to handle properly the subprogram bodies. Skip bodies in 464 -- subunits, which are listed independently. 465 466 if Ekind (Ent) = E_Package_Body 467 and then Present (Corresponding_Spec (Find_Declaration (Ent))) 468 then 469 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent))); 470 while Present (E) loop 471 if Is_Subprogram (E) 472 and then 473 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration 474 then 475 Body_E := Corresponding_Body (Find_Declaration (E)); 476 477 if Present (Body_E) 478 and then 479 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit 480 then 481 List_Entities (Body_E, Bytes_Big_Endian); 482 end if; 483 end if; 484 485 Next_Entity (E); 486 end loop; 487 end if; 488 end if; 489 end List_Entities; 490 491 ------------------------- 492 -- List_GCC_Expression -- 493 ------------------------- 494 495 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is 496 497 procedure Print_Expr (Val : Node_Ref_Or_Val); 498 -- Internal recursive procedure to print expression 499 500 ---------------- 501 -- Print_Expr -- 502 ---------------- 503 504 procedure Print_Expr (Val : Node_Ref_Or_Val) is 505 begin 506 if Val >= 0 then 507 UI_Write (Val, Decimal); 508 509 else 510 declare 511 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 512 513 procedure Binop (S : String); 514 -- Output text for binary operator with S being operator name 515 516 ----------- 517 -- Binop -- 518 ----------- 519 520 procedure Binop (S : String) is 521 begin 522 Write_Char ('('); 523 Print_Expr (Node.Op1); 524 Write_Str (S); 525 Print_Expr (Node.Op2); 526 Write_Char (')'); 527 end Binop; 528 529 -- Start of processing for Print_Expr 530 531 begin 532 case Node.Expr is 533 when Cond_Expr => 534 Write_Str ("(if "); 535 Print_Expr (Node.Op1); 536 Write_Str (" then "); 537 Print_Expr (Node.Op2); 538 Write_Str (" else "); 539 Print_Expr (Node.Op3); 540 Write_Str (" end)"); 541 542 when Plus_Expr => 543 Binop (" + "); 544 545 when Minus_Expr => 546 Binop (" - "); 547 548 when Mult_Expr => 549 Binop (" * "); 550 551 when Trunc_Div_Expr => 552 Binop (" /t "); 553 554 when Ceil_Div_Expr => 555 Binop (" /c "); 556 557 when Floor_Div_Expr => 558 Binop (" /f "); 559 560 when Trunc_Mod_Expr => 561 Binop (" modt "); 562 563 when Floor_Mod_Expr => 564 Binop (" modf "); 565 566 when Ceil_Mod_Expr => 567 Binop (" modc "); 568 569 when Exact_Div_Expr => 570 Binop (" /e "); 571 572 when Negate_Expr => 573 Write_Char ('-'); 574 Print_Expr (Node.Op1); 575 576 when Min_Expr => 577 Binop (" min "); 578 579 when Max_Expr => 580 Binop (" max "); 581 582 when Abs_Expr => 583 Write_Str ("abs "); 584 Print_Expr (Node.Op1); 585 586 when Truth_Andif_Expr => 587 Binop (" and if "); 588 589 when Truth_Orif_Expr => 590 Binop (" or if "); 591 592 when Truth_And_Expr => 593 Binop (" and "); 594 595 when Truth_Or_Expr => 596 Binop (" or "); 597 598 when Truth_Xor_Expr => 599 Binop (" xor "); 600 601 when Truth_Not_Expr => 602 Write_Str ("not "); 603 Print_Expr (Node.Op1); 604 605 when Bit_And_Expr => 606 Binop (" & "); 607 608 when Lt_Expr => 609 Binop (" < "); 610 611 when Le_Expr => 612 Binop (" <= "); 613 614 when Gt_Expr => 615 Binop (" > "); 616 617 when Ge_Expr => 618 Binop (" >= "); 619 620 when Eq_Expr => 621 Binop (" == "); 622 623 when Ne_Expr => 624 Binop (" != "); 625 626 when Discrim_Val => 627 Write_Char ('#'); 628 UI_Write (Node.Op1); 629 630 end case; 631 end; 632 end if; 633 end Print_Expr; 634 635 -- Start of processing for List_GCC_Expression 636 637 begin 638 if U = No_Uint then 639 Write_Str ("??"); 640 else 641 Print_Expr (U); 642 end if; 643 end List_GCC_Expression; 644 645 ------------------------- 646 -- List_Linker_Section -- 647 ------------------------- 648 649 procedure List_Linker_Section (Ent : Entity_Id) is 650 Arg : Node_Id; 651 652 begin 653 if Present (Linker_Section_Pragma (Ent)) then 654 Write_Str ("pragma Linker_Section ("); 655 List_Name (Ent); 656 Write_Str (", """); 657 658 Arg := 659 Last (Pragma_Argument_Associations (Linker_Section_Pragma (Ent))); 660 661 if Nkind (Arg) = N_Pragma_Argument_Association then 662 Arg := Expression (Arg); 663 end if; 664 665 pragma Assert (Nkind (Arg) = N_String_Literal); 666 String_To_Name_Buffer (Strval (Arg)); 667 Write_Str (Name_Buffer (1 .. Name_Len)); 668 Write_Str (""");"); 669 Write_Eol; 670 end if; 671 end List_Linker_Section; 672 673 --------------------- 674 -- List_Mechanisms -- 675 --------------------- 676 677 procedure List_Mechanisms (Ent : Entity_Id) is 678 Plen : Natural; 679 Form : Entity_Id; 680 681 begin 682 Blank_Line; 683 684 case Ekind (Ent) is 685 when E_Function => 686 Write_Str ("function "); 687 688 when E_Operator => 689 Write_Str ("operator "); 690 691 when E_Procedure => 692 Write_Str ("procedure "); 693 694 when E_Subprogram_Type => 695 Write_Str ("type "); 696 697 when E_Entry | E_Entry_Family => 698 Write_Str ("entry "); 699 700 when others => 701 raise Program_Error; 702 end case; 703 704 Get_Unqualified_Decoded_Name_String (Chars (Ent)); 705 Write_Str (Name_Buffer (1 .. Name_Len)); 706 Write_Str (" declared at "); 707 Write_Location (Sloc (Ent)); 708 Write_Eol; 709 710 Write_Str (" convention : "); 711 712 case Convention (Ent) is 713 when Convention_Ada => 714 Write_Line ("Ada"); 715 when Convention_Ada_Pass_By_Copy => 716 Write_Line ("Ada_Pass_By_Copy"); 717 when Convention_Ada_Pass_By_Reference => 718 Write_Line ("Ada_Pass_By_Reference"); 719 when Convention_Intrinsic => 720 Write_Line ("Intrinsic"); 721 when Convention_Entry => 722 Write_Line ("Entry"); 723 when Convention_Protected => 724 Write_Line ("Protected"); 725 when Convention_Assembler => 726 Write_Line ("Assembler"); 727 when Convention_C => 728 Write_Line ("C"); 729 when Convention_COBOL => 730 Write_Line ("COBOL"); 731 when Convention_CPP => 732 Write_Line ("C++"); 733 when Convention_Fortran => 734 Write_Line ("Fortran"); 735 when Convention_Stdcall => 736 Write_Line ("Stdcall"); 737 when Convention_Stubbed => 738 Write_Line ("Stubbed"); 739 end case; 740 741 -- Find max length of formal name 742 743 Plen := 0; 744 Form := First_Formal (Ent); 745 while Present (Form) loop 746 Get_Unqualified_Decoded_Name_String (Chars (Form)); 747 748 if Name_Len > Plen then 749 Plen := Name_Len; 750 end if; 751 752 Next_Formal (Form); 753 end loop; 754 755 -- Output formals and mechanisms 756 757 Form := First_Formal (Ent); 758 while Present (Form) loop 759 Get_Unqualified_Decoded_Name_String (Chars (Form)); 760 while Name_Len <= Plen loop 761 Name_Len := Name_Len + 1; 762 Name_Buffer (Name_Len) := ' '; 763 end loop; 764 765 Write_Str (" "); 766 Write_Str (Name_Buffer (1 .. Plen + 1)); 767 Write_Str (": passed by "); 768 769 Write_Mechanism (Mechanism (Form)); 770 Write_Eol; 771 Next_Formal (Form); 772 end loop; 773 774 if Etype (Ent) /= Standard_Void_Type then 775 Write_Str (" returns by "); 776 Write_Mechanism (Mechanism (Ent)); 777 Write_Eol; 778 end if; 779 end List_Mechanisms; 780 781 --------------- 782 -- List_Name -- 783 --------------- 784 785 procedure List_Name (Ent : Entity_Id) is 786 begin 787 if not Is_Compilation_Unit (Scope (Ent)) then 788 List_Name (Scope (Ent)); 789 Write_Char ('.'); 790 end if; 791 792 Get_Unqualified_Decoded_Name_String (Chars (Ent)); 793 Set_Casing (Unit_Casing); 794 Write_Str (Name_Buffer (1 .. Name_Len)); 795 end List_Name; 796 797 --------------------- 798 -- List_Object_Info -- 799 --------------------- 800 801 procedure List_Object_Info (Ent : Entity_Id) is 802 begin 803 Blank_Line; 804 805 Write_Str ("for "); 806 List_Name (Ent); 807 Write_Str ("'Size use "); 808 Write_Val (Esize (Ent)); 809 Write_Line (";"); 810 811 Write_Str ("for "); 812 List_Name (Ent); 813 Write_Str ("'Alignment use "); 814 Write_Val (Alignment (Ent)); 815 Write_Line (";"); 816 end List_Object_Info; 817 818 ---------------------- 819 -- List_Record_Info -- 820 ---------------------- 821 822 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 823 Comp : Entity_Id; 824 Cfbit : Uint; 825 Sunit : Uint; 826 827 Max_Name_Length : Natural; 828 Max_Suni_Length : Natural; 829 830 begin 831 Blank_Line; 832 List_Type_Info (Ent); 833 834 Write_Str ("for "); 835 List_Name (Ent); 836 Write_Line (" use record"); 837 838 -- First loop finds out max line length and max starting position 839 -- length, for the purpose of lining things up nicely. 840 841 Max_Name_Length := 0; 842 Max_Suni_Length := 0; 843 844 Comp := First_Component_Or_Discriminant (Ent); 845 while Present (Comp) loop 846 847 -- Skip discriminant in unchecked union (since it is not there!) 848 849 if Ekind (Comp) = E_Discriminant 850 and then Is_Unchecked_Union (Ent) 851 then 852 null; 853 854 -- All other cases 855 856 else 857 Get_Decoded_Name_String (Chars (Comp)); 858 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); 859 860 Cfbit := Component_Bit_Offset (Comp); 861 862 if Rep_Not_Constant (Cfbit) then 863 UI_Image_Length := 2; 864 865 else 866 -- Complete annotation in case not done 867 868 Set_Normalized_Position (Comp, Cfbit / SSU); 869 Set_Normalized_First_Bit (Comp, Cfbit mod SSU); 870 871 Sunit := Cfbit / SSU; 872 UI_Image (Sunit); 873 end if; 874 875 -- If the record is not packed, then we know that all fields 876 -- whose position is not specified have a starting normalized 877 -- bit position of zero. 878 879 if Unknown_Normalized_First_Bit (Comp) 880 and then not Is_Packed (Ent) 881 then 882 Set_Normalized_First_Bit (Comp, Uint_0); 883 end if; 884 885 Max_Suni_Length := 886 Natural'Max (Max_Suni_Length, UI_Image_Length); 887 end if; 888 889 Next_Component_Or_Discriminant (Comp); 890 end loop; 891 892 -- Second loop does actual output based on those values 893 894 Comp := First_Component_Or_Discriminant (Ent); 895 while Present (Comp) loop 896 897 -- Skip discriminant in unchecked union (since it is not there!) 898 899 if Ekind (Comp) = E_Discriminant 900 and then Is_Unchecked_Union (Ent) 901 then 902 goto Continue; 903 end if; 904 905 -- All other cases 906 907 declare 908 Esiz : constant Uint := Esize (Comp); 909 Bofs : constant Uint := Component_Bit_Offset (Comp); 910 Npos : constant Uint := Normalized_Position (Comp); 911 Fbit : constant Uint := Normalized_First_Bit (Comp); 912 Lbit : Uint; 913 914 begin 915 Write_Str (" "); 916 Get_Decoded_Name_String (Chars (Comp)); 917 Set_Casing (Unit_Casing); 918 Write_Str (Name_Buffer (1 .. Name_Len)); 919 920 for J in 1 .. Max_Name_Length - Name_Len loop 921 Write_Char (' '); 922 end loop; 923 924 Write_Str (" at "); 925 926 if Known_Static_Normalized_Position (Comp) then 927 UI_Image (Npos); 928 Spaces (Max_Suni_Length - UI_Image_Length); 929 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length)); 930 931 elsif Known_Component_Bit_Offset (Comp) 932 and then List_Representation_Info = 3 933 then 934 Spaces (Max_Suni_Length - 2); 935 Write_Str ("bit offset"); 936 Write_Val (Bofs, Paren => True); 937 Write_Str (" size in bits = "); 938 Write_Val (Esiz, Paren => True); 939 Write_Eol; 940 goto Continue; 941 942 elsif Known_Normalized_Position (Comp) 943 and then List_Representation_Info = 3 944 then 945 Spaces (Max_Suni_Length - 2); 946 Write_Val (Npos); 947 948 else 949 -- For the packed case, we don't know the bit positions if we 950 -- don't know the starting position. 951 952 if Is_Packed (Ent) then 953 Write_Line ("?? range ? .. ??;"); 954 goto Continue; 955 956 -- Otherwise we can continue 957 958 else 959 Write_Str ("??"); 960 end if; 961 end if; 962 963 Write_Str (" range "); 964 UI_Write (Fbit); 965 Write_Str (" .. "); 966 967 -- Allowing Uint_0 here is an annoying special case. Really this 968 -- should be a fine Esize value but currently it means unknown, 969 -- except that we know after gigi has back annotated that a size 970 -- of zero is real, since otherwise gigi back annotates using 971 -- No_Uint as the value to indicate unknown). 972 973 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp)) 974 and then Known_Static_Normalized_First_Bit (Comp) 975 then 976 Lbit := Fbit + Esiz - 1; 977 978 if Lbit < 10 then 979 Write_Char (' '); 980 end if; 981 982 UI_Write (Lbit); 983 984 -- The test for Esize (Comp) not Uint_0 here is an annoying 985 -- special case. Officially a value of zero for Esize means 986 -- unknown, but here we use the fact that we know that gigi 987 -- annotates Esize with No_Uint, not Uint_0. Really everyone 988 -- should use No_Uint??? 989 990 elsif List_Representation_Info < 3 991 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp)) 992 then 993 Write_Str ("??"); 994 995 -- List_Representation >= 3 and Known_Esize (Comp) 996 997 else 998 Write_Val (Esiz, Paren => True); 999 1000 -- If in front end layout mode, then dynamic size is stored 1001 -- in storage units, so renormalize for output 1002 1003 if not Back_End_Layout then 1004 Write_Str (" * "); 1005 Write_Int (SSU); 1006 end if; 1007 1008 -- Add appropriate first bit offset 1009 1010 if Fbit = 0 then 1011 Write_Str (" - 1"); 1012 1013 elsif Fbit = 1 then 1014 null; 1015 1016 else 1017 Write_Str (" + "); 1018 Write_Int (UI_To_Int (Fbit) - 1); 1019 end if; 1020 end if; 1021 1022 Write_Line (";"); 1023 end; 1024 1025 <<Continue>> 1026 Next_Component_Or_Discriminant (Comp); 1027 end loop; 1028 1029 Write_Line ("end record;"); 1030 1031 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 1032 end List_Record_Info; 1033 1034 ------------------- 1035 -- List_Rep_Info -- 1036 ------------------- 1037 1038 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is 1039 Col : Nat; 1040 1041 begin 1042 if List_Representation_Info /= 0 1043 or else List_Representation_Info_Mechanisms 1044 then 1045 for U in Main_Unit .. Last_Unit loop 1046 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then 1047 Unit_Casing := Identifier_Casing (Source_Index (U)); 1048 1049 -- Normal case, list to standard output 1050 1051 if not List_Representation_Info_To_File then 1052 Write_Eol; 1053 Write_Str ("Representation information for unit "); 1054 Write_Unit_Name (Unit_Name (U)); 1055 Col := Column; 1056 Write_Eol; 1057 1058 for J in 1 .. Col - 1 loop 1059 Write_Char ('-'); 1060 end loop; 1061 1062 Write_Eol; 1063 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1064 1065 -- List representation information to file 1066 1067 else 1068 Create_Repinfo_File_Access.all 1069 (Get_Name_String (File_Name (Source_Index (U)))); 1070 Set_Special_Output (Write_Info_Line'Access); 1071 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1072 Set_Special_Output (null); 1073 Close_Repinfo_File_Access.all; 1074 end if; 1075 end if; 1076 end loop; 1077 end if; 1078 end List_Rep_Info; 1079 1080 ------------------------------- 1081 -- List_Scalar_Storage_Order -- 1082 ------------------------------- 1083 1084 procedure List_Scalar_Storage_Order 1085 (Ent : Entity_Id; 1086 Bytes_Big_Endian : Boolean) 1087 is 1088 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean); 1089 -- Show attribute definition clause for Attr_Name (an endianness 1090 -- attribute), depending on whether or not the endianness is reversed 1091 -- compared to native endianness. 1092 1093 --------------- 1094 -- List_Attr -- 1095 --------------- 1096 1097 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is 1098 begin 1099 Write_Str ("for "); 1100 List_Name (Ent); 1101 Write_Str ("'" & Attr_Name & " use System."); 1102 1103 if Bytes_Big_Endian xor Is_Reversed then 1104 Write_Str ("High"); 1105 else 1106 Write_Str ("Low"); 1107 end if; 1108 1109 Write_Line ("_Order_First;"); 1110 end List_Attr; 1111 1112 List_SSO : constant Boolean := 1113 Has_Rep_Item (Ent, Name_Scalar_Storage_Order) 1114 or else SSO_Set_Low_By_Default (Ent) 1115 or else SSO_Set_High_By_Default (Ent); 1116 -- Scalar_Storage_Order is displayed if specified explicitly 1117 -- or set by Default_Scalar_Storage_Order. 1118 1119 -- Start of processing for List_Scalar_Storage_Order 1120 1121 begin 1122 -- For record types, list Bit_Order if not default, or if SSO is shown 1123 1124 if Is_Record_Type (Ent) 1125 and then (List_SSO or else Reverse_Bit_Order (Ent)) 1126 then 1127 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent)); 1128 end if; 1129 1130 -- List SSO if required. If not, then storage is supposed to be in 1131 -- native order. 1132 1133 if List_SSO then 1134 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent)); 1135 else 1136 pragma Assert (not Reverse_Storage_Order (Ent)); 1137 null; 1138 end if; 1139 end List_Scalar_Storage_Order; 1140 1141 -------------------- 1142 -- List_Type_Info -- 1143 -------------------- 1144 1145 procedure List_Type_Info (Ent : Entity_Id) is 1146 begin 1147 Blank_Line; 1148 1149 -- Do not list size info for unconstrained arrays, not meaningful 1150 1151 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then 1152 null; 1153 1154 else 1155 -- If Esize and RM_Size are the same and known, list as Size. This 1156 -- is a common case, which we may as well list in simple form. 1157 1158 if Esize (Ent) = RM_Size (Ent) then 1159 Write_Str ("for "); 1160 List_Name (Ent); 1161 Write_Str ("'Size use "); 1162 Write_Val (Esize (Ent)); 1163 Write_Line (";"); 1164 1165 -- For now, temporary case, to be removed when gigi properly back 1166 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size. 1167 -- This avoids odd Object_Size output till we fix things??? 1168 1169 elsif Unknown_RM_Size (Ent) then 1170 Write_Str ("for "); 1171 List_Name (Ent); 1172 Write_Str ("'Size use "); 1173 Write_Val (Esize (Ent)); 1174 Write_Line (";"); 1175 1176 -- Otherwise list size values separately if they are set 1177 1178 else 1179 Write_Str ("for "); 1180 List_Name (Ent); 1181 Write_Str ("'Object_Size use "); 1182 Write_Val (Esize (Ent)); 1183 Write_Line (";"); 1184 1185 -- Note on following check: The RM_Size of a discrete type can 1186 -- legitimately be set to zero, so a special check is needed. 1187 1188 Write_Str ("for "); 1189 List_Name (Ent); 1190 Write_Str ("'Value_Size use "); 1191 Write_Val (RM_Size (Ent)); 1192 Write_Line (";"); 1193 end if; 1194 end if; 1195 1196 Write_Str ("for "); 1197 List_Name (Ent); 1198 Write_Str ("'Alignment use "); 1199 Write_Val (Alignment (Ent)); 1200 Write_Line (";"); 1201 1202 -- Special stuff for fixed-point 1203 1204 if Is_Fixed_Point_Type (Ent) then 1205 1206 -- Write small (always a static constant) 1207 1208 Write_Str ("for "); 1209 List_Name (Ent); 1210 Write_Str ("'Small use "); 1211 UR_Write (Small_Value (Ent)); 1212 Write_Line (";"); 1213 1214 -- Write range if static 1215 1216 declare 1217 R : constant Node_Id := Scalar_Range (Ent); 1218 1219 begin 1220 if Nkind (Low_Bound (R)) = N_Real_Literal 1221 and then 1222 Nkind (High_Bound (R)) = N_Real_Literal 1223 then 1224 Write_Str ("for "); 1225 List_Name (Ent); 1226 Write_Str ("'Range use "); 1227 UR_Write (Realval (Low_Bound (R))); 1228 Write_Str (" .. "); 1229 UR_Write (Realval (High_Bound (R))); 1230 Write_Line (";"); 1231 end if; 1232 end; 1233 end if; 1234 end List_Type_Info; 1235 1236 ---------------------- 1237 -- Rep_Not_Constant -- 1238 ---------------------- 1239 1240 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is 1241 begin 1242 if Val = No_Uint or else Val < 0 then 1243 return True; 1244 else 1245 return False; 1246 end if; 1247 end Rep_Not_Constant; 1248 1249 --------------- 1250 -- Rep_Value -- 1251 --------------- 1252 1253 function Rep_Value 1254 (Val : Node_Ref_Or_Val; 1255 D : Discrim_List) return Uint 1256 is 1257 function B (Val : Boolean) return Uint; 1258 -- Returns Uint_0 for False, Uint_1 for True 1259 1260 function T (Val : Node_Ref_Or_Val) return Boolean; 1261 -- Returns True for 0, False for any non-zero (i.e. True) 1262 1263 function V (Val : Node_Ref_Or_Val) return Uint; 1264 -- Internal recursive routine to evaluate tree 1265 1266 function W (Val : Uint) return Word; 1267 -- Convert Val to Word, assuming Val is always in the Int range. This 1268 -- is a helper function for the evaluation of bitwise expressions like 1269 -- Bit_And_Expr, for which there is no direct support in uintp. Uint 1270 -- values out of the Int range are expected to be seen in such 1271 -- expressions only with overflowing byte sizes around, introducing 1272 -- inherent unreliabilities in computations anyway. 1273 1274 ------- 1275 -- B -- 1276 ------- 1277 1278 function B (Val : Boolean) return Uint is 1279 begin 1280 if Val then 1281 return Uint_1; 1282 else 1283 return Uint_0; 1284 end if; 1285 end B; 1286 1287 ------- 1288 -- T -- 1289 ------- 1290 1291 function T (Val : Node_Ref_Or_Val) return Boolean is 1292 begin 1293 if V (Val) = 0 then 1294 return False; 1295 else 1296 return True; 1297 end if; 1298 end T; 1299 1300 ------- 1301 -- V -- 1302 ------- 1303 1304 function V (Val : Node_Ref_Or_Val) return Uint is 1305 L, R, Q : Uint; 1306 1307 begin 1308 if Val >= 0 then 1309 return Val; 1310 1311 else 1312 declare 1313 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 1314 1315 begin 1316 case Node.Expr is 1317 when Cond_Expr => 1318 if T (Node.Op1) then 1319 return V (Node.Op2); 1320 else 1321 return V (Node.Op3); 1322 end if; 1323 1324 when Plus_Expr => 1325 return V (Node.Op1) + V (Node.Op2); 1326 1327 when Minus_Expr => 1328 return V (Node.Op1) - V (Node.Op2); 1329 1330 when Mult_Expr => 1331 return V (Node.Op1) * V (Node.Op2); 1332 1333 when Trunc_Div_Expr => 1334 return V (Node.Op1) / V (Node.Op2); 1335 1336 when Ceil_Div_Expr => 1337 return 1338 UR_Ceiling 1339 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 1340 1341 when Floor_Div_Expr => 1342 return 1343 UR_Floor 1344 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 1345 1346 when Trunc_Mod_Expr => 1347 return V (Node.Op1) rem V (Node.Op2); 1348 1349 when Floor_Mod_Expr => 1350 return V (Node.Op1) mod V (Node.Op2); 1351 1352 when Ceil_Mod_Expr => 1353 L := V (Node.Op1); 1354 R := V (Node.Op2); 1355 Q := UR_Ceiling (L / UR_From_Uint (R)); 1356 return L - R * Q; 1357 1358 when Exact_Div_Expr => 1359 return V (Node.Op1) / V (Node.Op2); 1360 1361 when Negate_Expr => 1362 return -V (Node.Op1); 1363 1364 when Min_Expr => 1365 return UI_Min (V (Node.Op1), V (Node.Op2)); 1366 1367 when Max_Expr => 1368 return UI_Max (V (Node.Op1), V (Node.Op2)); 1369 1370 when Abs_Expr => 1371 return UI_Abs (V (Node.Op1)); 1372 1373 when Truth_Andif_Expr => 1374 return B (T (Node.Op1) and then T (Node.Op2)); 1375 1376 when Truth_Orif_Expr => 1377 return B (T (Node.Op1) or else T (Node.Op2)); 1378 1379 when Truth_And_Expr => 1380 return B (T (Node.Op1) and then T (Node.Op2)); 1381 1382 when Truth_Or_Expr => 1383 return B (T (Node.Op1) or else T (Node.Op2)); 1384 1385 when Truth_Xor_Expr => 1386 return B (T (Node.Op1) xor T (Node.Op2)); 1387 1388 when Truth_Not_Expr => 1389 return B (not T (Node.Op1)); 1390 1391 when Bit_And_Expr => 1392 L := V (Node.Op1); 1393 R := V (Node.Op2); 1394 return UI_From_Int (Int (W (L) and W (R))); 1395 1396 when Lt_Expr => 1397 return B (V (Node.Op1) < V (Node.Op2)); 1398 1399 when Le_Expr => 1400 return B (V (Node.Op1) <= V (Node.Op2)); 1401 1402 when Gt_Expr => 1403 return B (V (Node.Op1) > V (Node.Op2)); 1404 1405 when Ge_Expr => 1406 return B (V (Node.Op1) >= V (Node.Op2)); 1407 1408 when Eq_Expr => 1409 return B (V (Node.Op1) = V (Node.Op2)); 1410 1411 when Ne_Expr => 1412 return B (V (Node.Op1) /= V (Node.Op2)); 1413 1414 when Discrim_Val => 1415 declare 1416 Sub : constant Int := UI_To_Int (Node.Op1); 1417 begin 1418 pragma Assert (Sub in D'Range); 1419 return D (Sub); 1420 end; 1421 1422 end case; 1423 end; 1424 end if; 1425 end V; 1426 1427 ------- 1428 -- W -- 1429 ------- 1430 1431 -- We use an unchecked conversion to map Int values to their Word 1432 -- bitwise equivalent, which we could not achieve with a normal type 1433 -- conversion for negative Ints. We want bitwise equivalents because W 1434 -- is used as a helper for bit operators like Bit_And_Expr, and can be 1435 -- called for negative Ints in the context of aligning expressions like 1436 -- X+Align & -Align. 1437 1438 function W (Val : Uint) return Word is 1439 function To_Word is new Ada.Unchecked_Conversion (Int, Word); 1440 begin 1441 return To_Word (UI_To_Int (Val)); 1442 end W; 1443 1444 -- Start of processing for Rep_Value 1445 1446 begin 1447 if Val = No_Uint then 1448 return No_Uint; 1449 1450 else 1451 return V (Val); 1452 end if; 1453 end Rep_Value; 1454 1455 ------------ 1456 -- Spaces -- 1457 ------------ 1458 1459 procedure Spaces (N : Natural) is 1460 begin 1461 for J in 1 .. N loop 1462 Write_Char (' '); 1463 end loop; 1464 end Spaces; 1465 1466 --------------- 1467 -- Tree_Read -- 1468 --------------- 1469 1470 procedure Tree_Read is 1471 begin 1472 Rep_Table.Tree_Read; 1473 end Tree_Read; 1474 1475 ---------------- 1476 -- Tree_Write -- 1477 ---------------- 1478 1479 procedure Tree_Write is 1480 begin 1481 Rep_Table.Tree_Write; 1482 end Tree_Write; 1483 1484 --------------------- 1485 -- Write_Info_Line -- 1486 --------------------- 1487 1488 procedure Write_Info_Line (S : String) is 1489 begin 1490 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1)); 1491 end Write_Info_Line; 1492 1493 --------------------- 1494 -- Write_Mechanism -- 1495 --------------------- 1496 1497 procedure Write_Mechanism (M : Mechanism_Type) is 1498 begin 1499 case M is 1500 when 0 => 1501 Write_Str ("default"); 1502 1503 when -1 => 1504 Write_Str ("copy"); 1505 1506 when -2 => 1507 Write_Str ("reference"); 1508 1509 when others => 1510 raise Program_Error; 1511 end case; 1512 end Write_Mechanism; 1513 1514 --------------- 1515 -- Write_Val -- 1516 --------------- 1517 1518 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is 1519 begin 1520 if Rep_Not_Constant (Val) then 1521 if List_Representation_Info < 3 or else Val = No_Uint then 1522 Write_Str ("??"); 1523 1524 else 1525 if Back_End_Layout then 1526 Write_Char (' '); 1527 1528 if Paren then 1529 Write_Char ('('); 1530 List_GCC_Expression (Val); 1531 Write_Char (')'); 1532 else 1533 List_GCC_Expression (Val); 1534 end if; 1535 1536 Write_Char (' '); 1537 1538 else 1539 if Paren then 1540 Write_Char ('('); 1541 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); 1542 Write_Char (')'); 1543 else 1544 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); 1545 end if; 1546 end if; 1547 end if; 1548 1549 else 1550 UI_Write (Val); 1551 end if; 1552 end Write_Val; 1553 1554end Repinfo; 1555