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