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