gcc/ada/repinfo.adb

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