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