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