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