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