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-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
  32 with Alloc;  use Alloc;
  33 with Atree;  use Atree;
  34 with Casing; use Casing;
  35 with Debug;  use Debug;
  36 with Einfo;  use Einfo;
  37 with Lib;    use Lib;
  38 with Namet;  use Namet;
  39 with Opt;    use Opt;
  40 with Output; use Output;
  41 with Sinfo;  use Sinfo;
  42 with Sinput; use Sinput;
  43 with Snames; use Snames;
  44 with Stand;  use Stand;
  45 with Table;  use Table;
  46 with Uname;  use Uname;
  47 with Urealp; use Urealp;
  48
  49 with Ada.Unchecked_Conversion;
  50
  51 package 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
1452 end Repinfo;