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