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