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 --                                                                          --
  10 --          Copyright (C) 1999-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Alloc;    use Alloc;
  36 with Atree;    use Atree;
  37 with Casing;   use Casing;
  38 with Debug;    use Debug;
  39 with Einfo;    use Einfo;
  40 with Lib;      use Lib;
  41 with Namet;    use Namet;
  42 with Opt;      use Opt;
  43 with Output;   use Output;
  44 with Sinfo;    use Sinfo;
  45 with Sinput;   use Sinput;
  46 with Table;    use Table;
  47 with Uname;    use Uname;
  48 with Urealp;   use Urealp;
  49
  50 package body Repinfo is
  51
  52    SSU : constant := 8;
  53    --  Value for Storage_Unit, we do not want to get this from TTypes, since
  54    --  this introduces problematic dependencies in ASIS, and in any case this
  55    --  value is assumed to be 8 for the implementation of the DDA.
  56    --  This is wrong for AAMP???
  57
  58    ---------------------------------------
  59    -- Representation of gcc Expressions --
  60    ---------------------------------------
  61
  62    --    This table is used only if Frontend_Layout_On_Target is False,
  63    --    so that gigi lays out dynamic size/offset fields using encoded
  64    --    gcc expressions.
  65
  66    --    A table internal to this unit is used to hold the values of
  67    --    back annotated expressions. This table is written out by -gnatt
  68    --    and read back in for ASIS processing.
  69
  70    --    Node values are stored as Uint values which are the negative of
  71    --    the node index in this table. Constants appear as non-negative
  72    --    Uint values.
  73
  74    type Exp_Node is record
  75       Expr : TCode;
  76       Op1  : Node_Ref_Or_Val;
  77       Op2  : Node_Ref_Or_Val;
  78       Op3  : Node_Ref_Or_Val;
  79    end record;
  80
  81    package Rep_Table is new Table.Table (
  82       Table_Component_Type => Exp_Node,
  83       Table_Index_Type     => Nat,
  84       Table_Low_Bound      => 1,
  85       Table_Initial        => Alloc.Rep_Table_Initial,
  86       Table_Increment      => Alloc.Rep_Table_Increment,
  87       Table_Name           => "BE_Rep_Table");
  88
  89    --------------------------------------------------------------
  90    -- Representation of Front-End Dynamic Size/Offset Entities --
  91    --------------------------------------------------------------
  92
  93    package Dynamic_SO_Entity_Table is new Table.Table (
  94       Table_Component_Type => Entity_Id,
  95       Table_Index_Type     => Nat,
  96       Table_Low_Bound      => 1,
  97       Table_Initial        => Alloc.Rep_Table_Initial,
  98       Table_Increment      => Alloc.Rep_Table_Increment,
  99       Table_Name           => "FE_Rep_Table");
 100
 101    -----------------------
 102    -- Local Subprograms --
 103    -----------------------
 104
 105    Unit_Casing : Casing_Type;
 106    --  Identifier casing for current unit
 107
 108    procedure Spaces (N : Natural);
 109    --  Output given number of spaces
 110
 111    function Back_End_Layout return Boolean;
 112    --  Test for layout mode, True = back end, False = front end. This
 113    --  function is used rather than checking the configuration parameter
 114    --  because we do not want Repinfo to depend on Targparm (for ASIS)
 115
 116    procedure List_Entities (Ent : Entity_Id);
 117    --  This procedure lists the entities associated with the entity E,
 118    --  starting with the First_Entity and using the Next_Entity link.
 119    --  If a nested package is found, entities within the package are
 120    --  recursively processed.
 121
 122    procedure List_Name (Ent : Entity_Id);
 123    --  List name of entity Ent in appropriate case. The name is listed with
 124    --  full qualification up to but not including the compilation unit name.
 125
 126    procedure List_Array_Info (Ent : Entity_Id);
 127    --  List representation info for array type Ent
 128
 129    procedure List_Object_Info (Ent : Entity_Id);
 130    --  List representation info for object Ent
 131
 132    procedure List_Record_Info (Ent : Entity_Id);
 133    --  List representation info for record type Ent
 134
 135    procedure List_Type_Info (Ent : Entity_Id);
 136    --  List type info for type Ent
 137
 138    function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
 139    --  Returns True if Val represents a variable value, and False if it
 140    --  represents a value that is fixed at compile time.
 141
 142    procedure Write_Info_Line (S : String);
 143    --  Routine to write a line to Repinfo output file. This routine is
 144    --  passed as a special output procedure to Output.Set_Special_Output.
 145    --  Note that Write_Info_Line is called with an EOL character at the
 146    --  end of each line, as per the Output spec, but the internal call
 147    --  to the appropriate routine in Osint requires that the end of line
 148    --  sequence be stripped off.
 149
 150    procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
 151    --  Given a representation value, write it out. No_Uint values or values
 152    --  dependent on discriminants are written as two question marks. If the
 153    --  flag Paren is set, then the output is surrounded in parentheses if
 154    --  it is other than a simple value.
 155
 156    ---------------------
 157    -- Back_End_Layout --
 158    ---------------------
 159
 160    function Back_End_Layout return Boolean is
 161    begin
 162       --  We have back end layout if the back end has made any entries in
 163       --  the table of GCC expressions, otherwise we have front end layout.
 164
 165       return Rep_Table.Last > 0;
 166    end Back_End_Layout;
 167
 168    ------------------------
 169    -- Create_Discrim_Ref --
 170    ------------------------
 171
 172    function Create_Discrim_Ref
 173      (Discr : Entity_Id)
 174       return  Node_Ref
 175    is
 176       N : constant Uint := Discriminant_Number (Discr);
 177       T : Nat;
 178
 179    begin
 180       Rep_Table.Increment_Last;
 181       T := Rep_Table.Last;
 182       Rep_Table.Table (T).Expr := Discrim_Val;
 183       Rep_Table.Table (T).Op1  := N;
 184       Rep_Table.Table (T).Op2  := No_Uint;
 185       Rep_Table.Table (T).Op3  := No_Uint;
 186       return UI_From_Int (-T);
 187    end Create_Discrim_Ref;
 188
 189    ---------------------------
 190    -- Create_Dynamic_SO_Ref --
 191    ---------------------------
 192
 193    function Create_Dynamic_SO_Ref
 194      (E    : Entity_Id)
 195       return Dynamic_SO_Ref
 196    is
 197       T : Nat;
 198
 199    begin
 200       Dynamic_SO_Entity_Table.Increment_Last;
 201       T := Dynamic_SO_Entity_Table.Last;
 202       Dynamic_SO_Entity_Table.Table (T) := E;
 203       return UI_From_Int (-T);
 204    end Create_Dynamic_SO_Ref;
 205
 206    -----------------
 207    -- Create_Node --
 208    -----------------
 209
 210    function Create_Node
 211      (Expr : TCode;
 212       Op1  : Node_Ref_Or_Val;
 213       Op2  : Node_Ref_Or_Val := No_Uint;
 214       Op3  : Node_Ref_Or_Val := No_Uint)
 215       return  Node_Ref
 216    is
 217       T : Nat;
 218
 219    begin
 220       Rep_Table.Increment_Last;
 221       T := Rep_Table.Last;
 222       Rep_Table.Table (T).Expr := Expr;
 223       Rep_Table.Table (T).Op1  := Op1;
 224       Rep_Table.Table (T).Op2  := Op2;
 225       Rep_Table.Table (T).Op3  := Op3;
 226
 227       return UI_From_Int (-T);
 228    end Create_Node;
 229
 230    ---------------------------
 231    -- Get_Dynamic_SO_Entity --
 232    ---------------------------
 233
 234    function Get_Dynamic_SO_Entity
 235      (U    : Dynamic_SO_Ref)
 236       return Entity_Id
 237    is
 238    begin
 239       return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
 240    end Get_Dynamic_SO_Entity;
 241
 242    -----------------------
 243    -- Is_Dynamic_SO_Ref --
 244    -----------------------
 245
 246    function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
 247    begin
 248       return U < Uint_0;
 249    end Is_Dynamic_SO_Ref;
 250
 251    ----------------------
 252    -- Is_Static_SO_Ref --
 253    ----------------------
 254
 255    function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
 256    begin
 257       return U >= Uint_0;
 258    end Is_Static_SO_Ref;
 259
 260    ---------
 261    -- lgx --
 262    ---------
 263
 264    procedure lgx (U : Node_Ref_Or_Val) is
 265    begin
 266       List_GCC_Expression (U);
 267       Write_Eol;
 268    end lgx;
 269
 270    ----------------------
 271    -- List_Array_Info --
 272    ----------------------
 273
 274    procedure List_Array_Info (Ent : Entity_Id) is
 275    begin
 276       List_Type_Info (Ent);
 277
 278       Write_Str ("for ");
 279       List_Name (Ent);
 280       Write_Str ("'Component_Size use ");
 281       Write_Val (Component_Size (Ent));
 282       Write_Line (";");
 283    end List_Array_Info;
 284
 285    -------------------
 286    -- List_Entities --
 287    -------------------
 288
 289    procedure List_Entities (Ent : Entity_Id) is
 290       E : Entity_Id;
 291
 292    begin
 293       if Present (Ent) then
 294          E := First_Entity (Ent);
 295          while Present (E) loop
 296
 297             --  We list entities that come from source (excluding private
 298             --  types, where we will list the info for the full view). If
 299             --  debug flag A is set, all entities are listed
 300
 301             if (Comes_From_Source (E) and then not Is_Private_Type (E))
 302               or else Debug_Flag_AA
 303             then
 304                if Is_Record_Type (E) then
 305                   List_Record_Info (E);
 306
 307                elsif Is_Array_Type (E) then
 308                   List_Array_Info (E);
 309
 310                elsif List_Representation_Info >= 2 then
 311                   if Is_Type (E) then
 312                      List_Type_Info (E);
 313
 314                   elsif Ekind (E) = E_Variable
 315                           or else
 316                         Ekind (E) = E_Constant
 317                           or else
 318                         Ekind (E) = E_Loop_Parameter
 319                           or else
 320                         Is_Formal (E)
 321                   then
 322                      List_Object_Info (E);
 323                   end if;
 324                end if;
 325
 326                --  Recurse into nested package, but not if they are
 327                --  package renamings (in particular renamings of the
 328                --  enclosing package, as for some Java bindings and
 329                --  for generic instances).
 330
 331                if Ekind (E) = E_Package then
 332                   if No (Renamed_Object (E)) then
 333                      List_Entities (E);
 334                   end if;
 335
 336                --  Recurse into bodies
 337
 338                elsif Ekind (E) = E_Protected_Type
 339                        or else
 340                      Ekind (E) = E_Task_Type
 341                        or else
 342                      Ekind (E) = E_Subprogram_Body
 343                        or else
 344                      Ekind (E) = E_Package_Body
 345                        or else
 346                      Ekind (E) = E_Task_Body
 347                        or else
 348                      Ekind (E) = E_Protected_Body
 349                then
 350                   List_Entities (E);
 351
 352                --  Recurse into blocks
 353
 354                elsif Ekind (E) = E_Block then
 355                   List_Entities (E);
 356                end if;
 357             end if;
 358
 359             E := Next_Entity (E);
 360          end loop;
 361       end if;
 362    end List_Entities;
 363
 364    -------------------------
 365    -- List_GCC_Expression --
 366    -------------------------
 367
 368    procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
 369
 370       procedure P (Val : Node_Ref_Or_Val);
 371       --  Internal recursive procedure to print expression
 372
 373       procedure P (Val : Node_Ref_Or_Val) is
 374       begin
 375          if Val >= 0 then
 376             UI_Write (Val, Decimal);
 377
 378          else
 379             declare
 380                Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
 381
 382                procedure Binop (S : String);
 383                --  Output text for binary operator with S being operator name
 384
 385                procedure Binop (S : String) is
 386                begin
 387                   Write_Char ('(');
 388                   P (Node.Op1);
 389                   Write_Str (S);
 390                   P (Node.Op2);
 391                   Write_Char (')');
 392                end Binop;
 393
 394             --  Start of processing for P
 395
 396             begin
 397                case Node.Expr is
 398                   when Cond_Expr =>
 399                      Write_Str ("(if ");
 400                      P (Node.Op1);
 401                      Write_Str (" then ");
 402                      P (Node.Op2);
 403                      Write_Str (" else ");
 404                      P (Node.Op3);
 405                      Write_Str (" end)");
 406
 407                   when Plus_Expr =>
 408                      Binop (" + ");
 409
 410                   when Minus_Expr =>
 411                      Binop (" - ");
 412
 413                   when Mult_Expr =>
 414                      Binop (" * ");
 415
 416                   when Trunc_Div_Expr =>
 417                      Binop (" /t ");
 418
 419                   when Ceil_Div_Expr =>
 420                      Binop (" /c ");
 421
 422                   when Floor_Div_Expr =>
 423                      Binop (" /f ");
 424
 425                   when Trunc_Mod_Expr =>
 426                      Binop (" modt ");
 427
 428                   when Floor_Mod_Expr =>
 429                      Binop (" modf ");
 430
 431                   when Ceil_Mod_Expr =>
 432                      Binop (" modc ");
 433
 434                   when Exact_Div_Expr =>
 435                      Binop (" /e ");
 436
 437                   when Negate_Expr =>
 438                      Write_Char ('-');
 439                      P (Node.Op1);
 440
 441                   when Min_Expr =>
 442                      Binop (" min ");
 443
 444                   when Max_Expr =>
 445                      Binop (" max ");
 446
 447                   when Abs_Expr =>
 448                      Write_Str ("abs ");
 449                      P (Node.Op1);
 450
 451                   when Truth_Andif_Expr =>
 452                      Binop (" and if ");
 453
 454                   when Truth_Orif_Expr =>
 455                      Binop (" or if ");
 456
 457                   when Truth_And_Expr =>
 458                      Binop (" and ");
 459
 460                   when Truth_Or_Expr =>
 461                      Binop (" or ");
 462
 463                   when Truth_Xor_Expr =>
 464                      Binop (" xor ");
 465
 466                   when Truth_Not_Expr =>
 467                      Write_Str ("not ");
 468                      P (Node.Op1);
 469
 470                   when Lt_Expr =>
 471                      Binop (" < ");
 472
 473                   when Le_Expr =>
 474                      Binop (" <= ");
 475
 476                   when Gt_Expr =>
 477                      Binop (" > ");
 478
 479                   when Ge_Expr =>
 480                      Binop (" >= ");
 481
 482                   when Eq_Expr =>
 483                      Binop (" == ");
 484
 485                   when Ne_Expr =>
 486                      Binop (" != ");
 487
 488                   when Discrim_Val =>
 489                      Write_Char ('#');
 490                      UI_Write (Node.Op1);
 491
 492                end case;
 493             end;
 494          end if;
 495       end P;
 496
 497    --  Start of processing for List_GCC_Expression
 498
 499    begin
 500       if U = No_Uint then
 501          Write_Str ("??");
 502       else
 503          P (U);
 504       end if;
 505    end List_GCC_Expression;
 506
 507    ---------------
 508    -- List_Name --
 509    ---------------
 510
 511    procedure List_Name (Ent : Entity_Id) is
 512    begin
 513       if not Is_Compilation_Unit (Scope (Ent)) then
 514          List_Name (Scope (Ent));
 515          Write_Char ('.');
 516       end if;
 517
 518       Get_Unqualified_Decoded_Name_String (Chars (Ent));
 519       Set_Casing (Unit_Casing);
 520       Write_Str (Name_Buffer (1 .. Name_Len));
 521    end List_Name;
 522
 523    ---------------------
 524    -- List_Object_Info --
 525    ---------------------
 526
 527    procedure List_Object_Info (Ent : Entity_Id) is
 528    begin
 529       Write_Eol;
 530
 531       Write_Str ("for ");
 532       List_Name (Ent);
 533       Write_Str ("'Size use ");
 534       Write_Val (Esize (Ent));
 535       Write_Line (";");
 536
 537       Write_Str ("for ");
 538       List_Name (Ent);
 539       Write_Str ("'Alignment use ");
 540       Write_Val (Alignment (Ent));
 541       Write_Line (";");
 542    end List_Object_Info;
 543
 544    ----------------------
 545    -- List_Record_Info --
 546    ----------------------
 547
 548    procedure List_Record_Info (Ent : Entity_Id) is
 549       Comp  : Entity_Id;
 550       Esiz  : Uint;
 551       Cfbit : Uint;
 552       Sunit : Uint;
 553
 554       Max_Name_Length : Natural;
 555       Max_Suni_Length : Natural;
 556
 557    begin
 558       List_Type_Info (Ent);
 559
 560       Write_Str ("for ");
 561       List_Name (Ent);
 562       Write_Line (" use record");
 563
 564       --  First loop finds out max line length and max starting position
 565       --  length, for the purpose of lining things up nicely.
 566
 567       Max_Name_Length := 0;
 568       Max_Suni_Length   := 0;
 569
 570       Comp := First_Entity (Ent);
 571       while Present (Comp) loop
 572          if Ekind (Comp) = E_Component
 573            or else Ekind (Comp) = E_Discriminant
 574          then
 575             Get_Decoded_Name_String (Chars (Comp));
 576             Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
 577
 578             Cfbit := Component_Bit_Offset (Comp);
 579
 580             if Rep_Not_Constant (Cfbit) then
 581                UI_Image_Length := 2;
 582
 583             else
 584                --  Complete annotation in case not done
 585
 586                Set_Normalized_Position (Comp, Cfbit / SSU);
 587                Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
 588
 589                Esiz  := Esize (Comp);
 590                Sunit := Cfbit / SSU;
 591                UI_Image (Sunit);
 592             end if;
 593
 594             --  If the record is not packed, then we know that all
 595             --  fields whose position is not specified have a starting
 596             --  normalized bit position of zero
 597
 598             if Unknown_Normalized_First_Bit (Comp)
 599               and then not Is_Packed (Ent)
 600             then
 601                Set_Normalized_First_Bit (Comp, Uint_0);
 602             end if;
 603
 604             Max_Suni_Length :=
 605               Natural'Max (Max_Suni_Length, UI_Image_Length);
 606          end if;
 607
 608          Comp := Next_Entity (Comp);
 609       end loop;
 610
 611       --  Second loop does actual output based on those values
 612
 613       Comp := First_Entity (Ent);
 614       while Present (Comp) loop
 615          if Ekind (Comp) = E_Component
 616            or else Ekind (Comp) = E_Discriminant
 617          then
 618             declare
 619                Esiz : constant Uint := Esize (Comp);
 620                Bofs : constant Uint := Component_Bit_Offset (Comp);
 621                Npos : constant Uint := Normalized_Position (Comp);
 622                Fbit : constant Uint := Normalized_First_Bit (Comp);
 623                Lbit : Uint;
 624
 625             begin
 626                Write_Str ("   ");
 627                Get_Decoded_Name_String (Chars (Comp));
 628                Set_Casing (Unit_Casing);
 629                Write_Str (Name_Buffer (1 .. Name_Len));
 630
 631                for J in 1 .. Max_Name_Length - Name_Len loop
 632                   Write_Char (' ');
 633                end loop;
 634
 635                Write_Str (" at ");
 636
 637                if Known_Static_Normalized_Position (Comp) then
 638                   UI_Image (Npos);
 639                   Spaces (Max_Suni_Length - UI_Image_Length);
 640                   Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
 641
 642                elsif Known_Component_Bit_Offset (Comp)
 643                  and then List_Representation_Info = 3
 644                then
 645                   Spaces (Max_Suni_Length - 2);
 646                   Write_Str ("bit offset");
 647                   Write_Val (Bofs, Paren => True);
 648                   Write_Str (" size in bits = ");
 649                   Write_Val (Esiz, Paren => True);
 650                   Write_Eol;
 651                   goto Continue;
 652
 653                elsif Known_Normalized_Position (Comp)
 654                  and then List_Representation_Info = 3
 655                then
 656                   Spaces (Max_Suni_Length - 2);
 657                   Write_Val (Npos);
 658
 659                else
 660                   --  For the packed case, we don't know the bit positions
 661                   --  if we don't know the starting position!
 662
 663                   if Is_Packed (Ent) then
 664                      Write_Line ("?? range  ? .. ??;");
 665                      goto Continue;
 666
 667                   --  Otherwise we can continue
 668
 669                   else
 670                      Write_Str ("??");
 671                   end if;
 672                end if;
 673
 674                Write_Str (" range  ");
 675                UI_Write (Fbit);
 676                Write_Str (" .. ");
 677
 678                --  Allowing Uint_0 here is a kludge, really this should be
 679                --  a fine Esize value but currently it means unknown, except
 680                --  that we know after gigi has back annotated that a size of
 681                --  zero is real, since otherwise gigi back annotates using
 682                --  No_Uint as the value to indicate unknown).
 683
 684                if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
 685                  and then Known_Static_Normalized_First_Bit (Comp)
 686                then
 687                   Lbit := Fbit + Esiz - 1;
 688
 689                   if Lbit < 10 then
 690                      Write_Char (' ');
 691                   end if;
 692
 693                   UI_Write (Lbit);
 694
 695                --  The test for Esize (Comp) not being Uint_0 here is a kludge.
 696                --  Officially a value of zero for Esize means unknown, but here
 697                --  we use the fact that we know that gigi annotates Esize with
 698                --  No_Uint, not Uint_0. Really everyone should use No_Uint???
 699
 700                elsif List_Representation_Info < 3
 701                  or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
 702                then
 703                   Write_Str ("??");
 704
 705                else -- List_Representation >= 3 and Known_Esize (Comp)
 706
 707                   Write_Val (Esiz, Paren => True);
 708
 709                   --  If in front end layout mode, then dynamic size is
 710                   --  stored in storage units, so renormalize for output
 711
 712                   if not Back_End_Layout then
 713                      Write_Str (" * ");
 714                      Write_Int (SSU);
 715                   end if;
 716
 717                   --  Add appropriate first bit offset
 718
 719                   if Fbit = 0 then
 720                      Write_Str (" - 1");
 721
 722                   elsif Fbit = 1 then
 723                      null;
 724
 725                   else
 726                      Write_Str (" + ");
 727                      Write_Int (UI_To_Int (Fbit) - 1);
 728                   end if;
 729                end if;
 730
 731                Write_Line (";");
 732             end;
 733          end if;
 734
 735       <<Continue>>
 736          Comp := Next_Entity (Comp);
 737       end loop;
 738
 739       Write_Line ("end record;");
 740    end List_Record_Info;
 741
 742    -------------------
 743    -- List_Rep_Info --
 744    -------------------
 745
 746    procedure List_Rep_Info is
 747       Col : Nat;
 748
 749    begin
 750       for U in Main_Unit .. Last_Unit loop
 751          if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
 752
 753             --  Normal case, list to standard output
 754
 755             if not List_Representation_Info_To_File then
 756                Unit_Casing := Identifier_Casing (Source_Index (U));
 757                Write_Eol;
 758                Write_Str ("Representation information for unit ");
 759                Write_Unit_Name (Unit_Name (U));
 760                Col := Column;
 761                Write_Eol;
 762
 763                for J in 1 .. Col - 1 loop
 764                   Write_Char ('-');
 765                end loop;
 766
 767                Write_Eol;
 768                List_Entities (Cunit_Entity (U));
 769
 770             --  List representation information to file
 771
 772             else
 773                Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
 774                Set_Special_Output (Write_Info_Line'Access);
 775                List_Entities (Cunit_Entity (U));
 776                Set_Special_Output (null);
 777                Close_Repinfo_File_Access.all;
 778             end if;
 779          end if;
 780       end loop;
 781    end List_Rep_Info;
 782
 783    ---------------------
 784    -- Write_Info_Line --
 785    ---------------------
 786
 787    procedure Write_Info_Line (S : String) is
 788    begin
 789       Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
 790    end Write_Info_Line;
 791
 792    --------------------
 793    -- List_Type_Info --
 794    --------------------
 795
 796    procedure List_Type_Info (Ent : Entity_Id) is
 797    begin
 798       Write_Eol;
 799
 800       --  Do not list size info for unconstrained arrays, not meaningful
 801
 802       if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
 803          null;
 804
 805       else
 806          --  If Esize and RM_Size are the same and known, list as Size. This
 807          --  is a common case, which we may as well list in simple form.
 808
 809          if Esize (Ent) = RM_Size (Ent) then
 810             Write_Str ("for ");
 811             List_Name (Ent);
 812             Write_Str ("'Size use ");
 813             Write_Val (Esize (Ent));
 814             Write_Line (";");
 815
 816          --  For now, temporary case, to be removed when gigi properly back
 817          --  annotates RM_Size, if RM_Size is not set, then list Esize as
 818          --  Size. This avoids odd Object_Size output till we fix things???
 819
 820          elsif Unknown_RM_Size (Ent) then
 821             Write_Str ("for ");
 822             List_Name (Ent);
 823             Write_Str ("'Size use ");
 824             Write_Val (Esize (Ent));
 825             Write_Line (";");
 826
 827          --  Otherwise list size values separately if they are set
 828
 829          else
 830             Write_Str ("for ");
 831             List_Name (Ent);
 832             Write_Str ("'Object_Size use ");
 833             Write_Val (Esize (Ent));
 834             Write_Line (";");
 835
 836             --  Note on following check: The RM_Size of a discrete type can
 837             --  legitimately be set to zero, so a special check is needed.
 838
 839             Write_Str ("for ");
 840             List_Name (Ent);
 841             Write_Str ("'Value_Size use ");
 842             Write_Val (RM_Size (Ent));
 843             Write_Line (";");
 844          end if;
 845       end if;
 846
 847       Write_Str ("for ");
 848       List_Name (Ent);
 849       Write_Str ("'Alignment use ");
 850       Write_Val (Alignment (Ent));
 851       Write_Line (";");
 852    end List_Type_Info;
 853
 854    ----------------------
 855    -- Rep_Not_Constant --
 856    ----------------------
 857
 858    function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
 859    begin
 860       if Val = No_Uint or else Val < 0 then
 861          return True;
 862       else
 863          return False;
 864       end if;
 865    end Rep_Not_Constant;
 866
 867    ---------------
 868    -- Rep_Value --
 869    ---------------
 870
 871    function Rep_Value
 872      (Val  : Node_Ref_Or_Val;
 873       D    : Discrim_List)
 874       return Uint
 875    is
 876       function B (Val : Boolean) return Uint;
 877       --  Returns Uint_0 for False, Uint_1 for True
 878
 879       function T (Val : Node_Ref_Or_Val) return Boolean;
 880       --  Returns True for 0, False for any non-zero (i.e. True)
 881
 882       function V (Val : Node_Ref_Or_Val) return Uint;
 883       --  Internal recursive routine to evaluate tree
 884
 885       -------
 886       -- B --
 887       -------
 888
 889       function B (Val : Boolean) return Uint is
 890       begin
 891          if Val then
 892             return Uint_1;
 893          else
 894             return Uint_0;
 895          end if;
 896       end B;
 897
 898       -------
 899       -- T --
 900       -------
 901
 902       function T (Val : Node_Ref_Or_Val) return Boolean is
 903       begin
 904          if V (Val) = 0 then
 905             return False;
 906          else
 907             return True;
 908          end if;
 909       end T;
 910
 911       -------
 912       -- V --
 913       -------
 914
 915       function V (Val : Node_Ref_Or_Val) return Uint is
 916          L, R, Q : Uint;
 917
 918       begin
 919          if Val >= 0 then
 920             return Val;
 921
 922          else
 923             declare
 924                Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
 925
 926             begin
 927                case Node.Expr is
 928                   when Cond_Expr =>
 929                      if T (Node.Op1) then
 930                         return V (Node.Op2);
 931                      else
 932                         return V (Node.Op3);
 933                      end if;
 934
 935                   when Plus_Expr =>
 936                      return V (Node.Op1) + V (Node.Op2);
 937
 938                   when Minus_Expr =>
 939                      return V (Node.Op1) - V (Node.Op2);
 940
 941                   when Mult_Expr =>
 942                      return V (Node.Op1) * V (Node.Op2);
 943
 944                   when Trunc_Div_Expr =>
 945                      return V (Node.Op1) / V (Node.Op2);
 946
 947                   when Ceil_Div_Expr =>
 948                      return
 949                        UR_Ceiling
 950                          (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
 951
 952                   when Floor_Div_Expr =>
 953                      return
 954                        UR_Floor
 955                          (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
 956
 957                   when Trunc_Mod_Expr =>
 958                      return V (Node.Op1) rem V (Node.Op2);
 959
 960                   when Floor_Mod_Expr =>
 961                      return V (Node.Op1) mod V (Node.Op2);
 962
 963                   when Ceil_Mod_Expr =>
 964                      L := V (Node.Op1);
 965                      R := V (Node.Op2);
 966                      Q := UR_Ceiling (L / UR_From_Uint (R));
 967                      return L - R * Q;
 968
 969                   when Exact_Div_Expr =>
 970                      return V (Node.Op1) / V (Node.Op2);
 971
 972                   when Negate_Expr =>
 973                      return -V (Node.Op1);
 974
 975                   when Min_Expr =>
 976                      return UI_Min (V (Node.Op1), V (Node.Op2));
 977
 978                   when Max_Expr =>
 979                      return UI_Max (V (Node.Op1), V (Node.Op2));
 980
 981                   when Abs_Expr =>
 982                      return UI_Abs (V (Node.Op1));
 983
 984                   when Truth_Andif_Expr =>
 985                      return B (T (Node.Op1) and then T (Node.Op2));
 986
 987                   when Truth_Orif_Expr =>
 988                      return B (T (Node.Op1) or else T (Node.Op2));
 989
 990                   when Truth_And_Expr =>
 991                      return B (T (Node.Op1) and T (Node.Op2));
 992
 993                   when Truth_Or_Expr =>
 994                      return B (T (Node.Op1) or T (Node.Op2));
 995
 996                   when Truth_Xor_Expr =>
 997                      return B (T (Node.Op1) xor T (Node.Op2));
 998
 999                   when Truth_Not_Expr =>
1000                      return B (not T (Node.Op1));
1001
1002                   when Lt_Expr =>
1003                      return B (V (Node.Op1) < V (Node.Op2));
1004
1005                   when Le_Expr =>
1006                      return B (V (Node.Op1) <= V (Node.Op2));
1007
1008                   when Gt_Expr =>
1009                      return B (V (Node.Op1) > V (Node.Op2));
1010
1011                   when Ge_Expr =>
1012                      return B (V (Node.Op1) >= V (Node.Op2));
1013
1014                   when Eq_Expr =>
1015                      return B (V (Node.Op1) = V (Node.Op2));
1016
1017                   when Ne_Expr =>
1018                      return B (V (Node.Op1) /= V (Node.Op2));
1019
1020                   when Discrim_Val =>
1021                      declare
1022                         Sub : constant Int := UI_To_Int (Node.Op1);
1023
1024                      begin
1025                         pragma Assert (Sub in D'Range);
1026                         return D (Sub);
1027                      end;
1028
1029                end case;
1030             end;
1031          end if;
1032       end V;
1033
1034    --  Start of processing for Rep_Value
1035
1036    begin
1037       if Val = No_Uint then
1038          return No_Uint;
1039
1040       else
1041          return V (Val);
1042       end if;
1043    end Rep_Value;
1044
1045    ------------
1046    -- Spaces --
1047    ------------
1048
1049    procedure Spaces (N : Natural) is
1050    begin
1051       for J in 1 .. N loop
1052          Write_Char (' ');
1053       end loop;
1054    end Spaces;
1055
1056    ---------------
1057    -- Tree_Read --
1058    ---------------
1059
1060    procedure Tree_Read is
1061    begin
1062       Rep_Table.Tree_Read;
1063    end Tree_Read;
1064
1065    ----------------
1066    -- Tree_Write --
1067    ----------------
1068
1069    procedure Tree_Write is
1070    begin
1071       Rep_Table.Tree_Write;
1072    end Tree_Write;
1073
1074    ---------------
1075    -- Write_Val --
1076    ---------------
1077
1078    procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
1079    begin
1080       if Rep_Not_Constant (Val) then
1081          if List_Representation_Info < 3 or else Val = No_Uint then
1082             Write_Str ("??");
1083
1084          else
1085             if Back_End_Layout then
1086                Write_Char (' ');
1087
1088                if Paren then
1089                   Write_Char ('(');
1090                   List_GCC_Expression (Val);
1091                   Write_Char (')');
1092                else
1093                   List_GCC_Expression (Val);
1094                end if;
1095
1096                Write_Char (' ');
1097
1098             else
1099                if Paren then
1100                   Write_Char ('(');
1101                   Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1102                   Write_Char (')');
1103                else
1104                   Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1105                end if;
1106             end if;
1107          end if;
1108
1109       else
1110          UI_Write (Val);
1111       end if;
1112    end Write_Val;
1113
1114 end Repinfo;