gcc/ada/treepr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               T R E E P R                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2012, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Csets;    use Csets;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Lib;      use Lib;
  33 with Namet;    use Namet;
  34 with Nlists;   use Nlists;
  35 with Output;   use Output;
  36 with Sem_Mech; use Sem_Mech;
  37 with Sinfo;    use Sinfo;
  38 with Snames;   use Snames;
  39 with Sinput;   use Sinput;
  40 with Stand;    use Stand;
  41 with Stringt;  use Stringt;
  42 with SCIL_LL;  use SCIL_LL;
  43 with Treeprs;  use Treeprs;
  44 with Uintp;    use Uintp;
  45 with Urealp;   use Urealp;
  46 with Uname;    use Uname;
  47 with Unchecked_Deallocation;
  48
  49 package body Treepr is
  50
  51    use Atree.Unchecked_Access;
  52    --  This module uses the unchecked access functions in package Atree
  53    --  since it does an untyped traversal of the tree (we do not want to
  54    --  count on the structure of the tree being correct in this routine!)
  55
  56    ----------------------------------
  57    -- Approach Used for Tree Print --
  58    ----------------------------------
  59
  60    --  When a complete subtree is being printed, a trace phase first marks
  61    --  the nodes and lists to be printed. This trace phase allocates logical
  62    --  numbers corresponding to the order in which the nodes and lists will
  63    --  be printed. The Node_Id, List_Id and Elist_Id values are mapped to
  64    --  logical node numbers using a hash table. Output is done using a set
  65    --  of Print_xxx routines, which are similar to the Write_xxx routines
  66    --  with the same name, except that they do not generate any output in
  67    --  the marking phase. This allows identical logic to be used in the
  68    --  two phases.
  69
  70    --  Note that the hash table not only holds the serial numbers, but also
  71    --  acts as a record of which nodes have already been visited. In the
  72    --  marking phase, a node has been visited if it is already in the hash
  73    --  table, and in the printing phase, we can tell whether a node has
  74    --  already been printed by looking at the value of the serial number.
  75
  76    ----------------------
  77    -- Global Variables --
  78    ----------------------
  79
  80    type Hash_Record is record
  81       Serial : Nat;
  82       --  Serial number for hash table entry. A value of zero means that
  83       --  the entry is currently unused.
  84
  85       Id : Int;
  86       --  If serial number field is non-zero, contains corresponding Id value
  87    end record;
  88
  89    type Hash_Table_Type is array (Nat range <>) of Hash_Record;
  90    type Access_Hash_Table_Type is access Hash_Table_Type;
  91    Hash_Table : Access_Hash_Table_Type;
  92    --  The hash table itself, see Serial_Number function for details of use
  93
  94    Hash_Table_Len : Nat;
  95    --  Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing
  96    --  by Hash_Table_Len gives a remainder that is in Hash_Table'Range.
  97
  98    Next_Serial_Number : Nat;
  99    --  Number of last visited node or list. Used during the marking phase to
 100    --  set proper node numbers in the hash table, and during the printing
 101    --  phase to make sure that a given node is not printed more than once.
 102    --  (nodes are printed in order during the printing phase, that's the
 103    --  point of numbering them in the first place!)
 104
 105    Printing_Descendants : Boolean;
 106    --  True if descendants are being printed, False if not. In the false case,
 107    --  only node Id's are printed. In the true case, node numbers as well as
 108    --  node Id's are printed, as described above.
 109
 110    type Phase_Type is (Marking, Printing);
 111    --  Type for Phase variable
 112
 113    Phase : Phase_Type;
 114    --  When an entire tree is being printed, the traversal operates in two
 115    --  phases. The first phase marks the nodes in use by installing node
 116    --  numbers in the node number table. The second phase prints the nodes.
 117    --  This variable indicates the current phase.
 118
 119    ----------------------
 120    -- Local Procedures --
 121    ----------------------
 122
 123    procedure Print_End_Span (N : Node_Id);
 124    --  Special routine to print contents of End_Span field of node N.
 125    --  The format includes the implicit source location as well as the
 126    --  value of the field.
 127
 128    procedure Print_Init;
 129    --  Initialize for printing of tree with descendents
 130
 131    procedure Print_Term;
 132    --  Clean up after printing of tree with descendents
 133
 134    procedure Print_Char (C : Character);
 135    --  Print character C if currently in print phase, noop if in marking phase
 136
 137    procedure Print_Name (N : Name_Id);
 138    --  Print name from names table if currently in print phase, noop if in
 139    --  marking phase. Note that the name is output in mixed case mode.
 140
 141    procedure Print_Node_Header (N : Node_Id);
 142    --  Print header line used by Print_Node and Print_Node_Briefly
 143
 144    procedure Print_Node_Kind (N : Node_Id);
 145    --  Print node kind name in mixed case if in print phase, noop if in
 146    --  marking phase.
 147
 148    procedure Print_Str (S : String);
 149    --  Print string S if currently in print phase, noop if in marking phase
 150
 151    procedure Print_Str_Mixed_Case (S : String);
 152    --  Like Print_Str, except that the string is printed in mixed case mode
 153
 154    procedure Print_Int (I : Int);
 155    --  Print integer I if currently in print phase, noop if in marking phase
 156
 157    procedure Print_Eol;
 158    --  Print end of line if currently in print phase, noop if in marking phase
 159
 160    procedure Print_Node_Ref (N : Node_Id);
 161    --  Print "<empty>", "<error>" or "Node #nnn" with additional information
 162    --  in the latter case, including the Id and the Nkind of the node.
 163
 164    procedure Print_List_Ref (L : List_Id);
 165    --  Print "<no list>", or "<empty node list>" or "Node list #nnn"
 166
 167    procedure Print_Elist_Ref (E : Elist_Id);
 168    --  Print "<no elist>", or "<empty element list>" or "Element list #nnn"
 169
 170    procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
 171    --  Called if the node being printed is an entity. Prints fields from the
 172    --  extension, using routines in Einfo to get the field names and flags.
 173
 174    procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
 175    --  Print representation of Field value (name, tree, string, uint, charcode)
 176    --  The format parameter controls the format of printing in the case of an
 177    --  integer value (see UI_Write for details).
 178
 179    procedure Print_Flag (F : Boolean);
 180    --  Print True or False
 181
 182    procedure Print_Node
 183      (N           : Node_Id;
 184       Prefix_Str  : String;
 185       Prefix_Char : Character);
 186    --  This is the internal routine used to print a single node. Each line of
 187    --  output is preceded by Prefix_Str (which is used to set the indentation
 188    --  level and the bars used to link list elements). In addition, for lines
 189    --  other than the first, an additional character Prefix_Char is output.
 190
 191    function Serial_Number (Id : Int) return Nat;
 192    --  Given a Node_Id, List_Id or Elist_Id, returns the previously assigned
 193    --  serial number, or zero if no serial number has yet been assigned.
 194
 195    procedure Set_Serial_Number;
 196    --  Can be called only immediately following a call to Serial_Number that
 197    --  returned a value of zero. Causes the value of Next_Serial_Number to be
 198    --  placed in the hash table (corresponding to the Id argument used in the
 199    --  Serial_Number call), and increments Next_Serial_Number.
 200
 201    procedure Visit_Node
 202      (N           : Node_Id;
 203       Prefix_Str  : String;
 204       Prefix_Char : Character);
 205    --  Called to process a single node in the case where descendents are to
 206    --  be printed before every line, and Prefix_Char added to all lines
 207    --  except the header line for the node.
 208
 209    procedure Visit_List (L : List_Id; Prefix_Str : String);
 210    --  Visit_List is called to process a list in the case where descendents
 211    --  are to be printed. Prefix_Str is to be added to all printed lines.
 212
 213    procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
 214    --  Visit_Elist is called to process an element list in the case where
 215    --  descendents are to be printed. Prefix_Str is to be added to all
 216    --  printed lines.
 217
 218    --------
 219    -- pe --
 220    --------
 221
 222    procedure pe (E : Elist_Id) is
 223    begin
 224       Print_Tree_Elist (E);
 225    end pe;
 226
 227    --------
 228    -- pl --
 229    --------
 230
 231    procedure pl (L : Int) is
 232       Lid : Int;
 233
 234    begin
 235       if L < 0 then
 236          Lid := L;
 237
 238       --  This is the case where we transform e.g. +36 to -99999936
 239
 240       else
 241          if L <= 9 then
 242             Lid := -(99999990 + L);
 243          elsif L <= 99 then
 244             Lid := -(99999900 + L);
 245          elsif L <= 999 then
 246             Lid := -(99999000 + L);
 247          elsif L <= 9999 then
 248             Lid := -(99990000 + L);
 249          elsif L <= 99999 then
 250             Lid := -(99900000 + L);
 251          elsif L <= 999999 then
 252             Lid := -(99000000 + L);
 253          elsif L <= 9999999 then
 254             Lid := -(90000000 + L);
 255          else
 256             Lid := -L;
 257          end if;
 258       end if;
 259
 260       --  Now output the list
 261
 262       Print_Tree_List (List_Id (Lid));
 263    end pl;
 264
 265    --------
 266    -- pn --
 267    --------
 268
 269    procedure pn (N : Union_Id) is
 270    begin
 271       case N is
 272          when List_Low_Bound .. List_High_Bound - 1 =>
 273             pl (Int (N));
 274          when Node_Range =>
 275             Print_Tree_Node (Node_Id (N));
 276          when Elist_Range =>
 277             Print_Tree_Elist (Elist_Id (N));
 278          when Elmt_Range =>
 279             declare
 280                Id : constant Elmt_Id := Elmt_Id (N);
 281             begin
 282                if No (Id) then
 283                   Write_Str ("No_Elmt");
 284                   Write_Eol;
 285                else
 286                   Write_Str ("Elmt_Id --> ");
 287                   Print_Tree_Node (Node (Id));
 288                end if;
 289             end;
 290          when Names_Range =>
 291             Namet.wn (Name_Id (N));
 292          when Strings_Range =>
 293             Write_String_Table_Entry (String_Id (N));
 294          when Uint_Range =>
 295             Uintp.pid (From_Union (N));
 296          when Ureal_Range =>
 297             Urealp.pr (From_Union (N));
 298          when others =>
 299             Write_Str ("Invalid Union_Id: ");
 300             Write_Int (Int (N));
 301             Write_Eol;
 302       end case;
 303    end pn;
 304
 305    --------
 306    -- pp --
 307    --------
 308
 309    procedure pp (N : Union_Id) is
 310    begin
 311       pn (N);
 312    end pp;
 313
 314    ----------------
 315    -- Print_Char --
 316    ----------------
 317
 318    procedure Print_Char (C : Character) is
 319    begin
 320       if Phase = Printing then
 321          Write_Char (C);
 322       end if;
 323    end Print_Char;
 324
 325    ---------------------
 326    -- Print_Elist_Ref --
 327    ---------------------
 328
 329    procedure Print_Elist_Ref (E : Elist_Id) is
 330    begin
 331       if Phase /= Printing then
 332          return;
 333       end if;
 334
 335       if E = No_Elist then
 336          Write_Str ("<no elist>");
 337
 338       elsif Is_Empty_Elmt_List (E) then
 339          Write_Str ("Empty elist, (Elist_Id=");
 340          Write_Int (Int (E));
 341          Write_Char (')');
 342
 343       else
 344          Write_Str ("(Elist_Id=");
 345          Write_Int (Int (E));
 346          Write_Char (')');
 347
 348          if Printing_Descendants then
 349             Write_Str (" #");
 350             Write_Int (Serial_Number (Int (E)));
 351          end if;
 352       end if;
 353    end Print_Elist_Ref;
 354
 355    -------------------------
 356    -- Print_Elist_Subtree --
 357    -------------------------
 358
 359    procedure Print_Elist_Subtree (E : Elist_Id) is
 360    begin
 361       Print_Init;
 362
 363       Next_Serial_Number := 1;
 364       Phase := Marking;
 365       Visit_Elist (E, "");
 366
 367       Next_Serial_Number := 1;
 368       Phase := Printing;
 369       Visit_Elist (E, "");
 370
 371       Print_Term;
 372    end Print_Elist_Subtree;
 373
 374    --------------------
 375    -- Print_End_Span --
 376    --------------------
 377
 378    procedure Print_End_Span (N : Node_Id) is
 379       Val : constant Uint := End_Span (N);
 380
 381    begin
 382       UI_Write (Val);
 383       Write_Str (" (Uint = ");
 384       Write_Int (Int (Field5 (N)));
 385       Write_Str (")  ");
 386
 387       if Val /= No_Uint then
 388          Write_Location (End_Location (N));
 389       end if;
 390    end Print_End_Span;
 391
 392    -----------------------
 393    -- Print_Entity_Info --
 394    -----------------------
 395
 396    procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
 397       function Field_Present (U : Union_Id) return Boolean;
 398       --  Returns False unless the value U represents a missing value
 399       --  (Empty, No_Uint, No_Ureal or No_String)
 400
 401       function Field_Present (U : Union_Id) return Boolean is
 402       begin
 403          return
 404             U /= Union_Id (Empty)    and then
 405             U /= To_Union (No_Uint)  and then
 406             U /= To_Union (No_Ureal) and then
 407             U /= Union_Id (No_String);
 408       end Field_Present;
 409
 410    --  Start of processing for Print_Entity_Info
 411
 412    begin
 413       Print_Str (Prefix);
 414       Print_Str ("Ekind = ");
 415       Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
 416       Print_Eol;
 417
 418       Print_Str (Prefix);
 419       Print_Str ("Etype = ");
 420       Print_Node_Ref (Etype (Ent));
 421       Print_Eol;
 422
 423       if Convention (Ent) /= Convention_Ada then
 424          Print_Str (Prefix);
 425          Print_Str ("Convention = ");
 426
 427          --  Print convention name skipping the Convention_ at the start
 428
 429          declare
 430             S : constant String := Convention_Id'Image (Convention (Ent));
 431
 432          begin
 433             Print_Str_Mixed_Case (S (12 .. S'Last));
 434             Print_Eol;
 435          end;
 436       end if;
 437
 438       if Field_Present (Field6 (Ent)) then
 439          Print_Str (Prefix);
 440          Write_Field6_Name (Ent);
 441          Write_Str (" = ");
 442          Print_Field (Field6 (Ent));
 443          Print_Eol;
 444       end if;
 445
 446       if Field_Present (Field7 (Ent)) then
 447          Print_Str (Prefix);
 448          Write_Field7_Name (Ent);
 449          Write_Str (" = ");
 450          Print_Field (Field7 (Ent));
 451          Print_Eol;
 452       end if;
 453
 454       if Field_Present (Field8 (Ent)) then
 455          Print_Str (Prefix);
 456          Write_Field8_Name (Ent);
 457          Write_Str (" = ");
 458          Print_Field (Field8 (Ent));
 459          Print_Eol;
 460       end if;
 461
 462       if Field_Present (Field9 (Ent)) then
 463          Print_Str (Prefix);
 464          Write_Field9_Name (Ent);
 465          Write_Str (" = ");
 466          Print_Field (Field9 (Ent));
 467          Print_Eol;
 468       end if;
 469
 470       if Field_Present (Field10 (Ent)) then
 471          Print_Str (Prefix);
 472          Write_Field10_Name (Ent);
 473          Write_Str (" = ");
 474          Print_Field (Field10 (Ent));
 475          Print_Eol;
 476       end if;
 477
 478       if Field_Present (Field11 (Ent)) then
 479          Print_Str (Prefix);
 480          Write_Field11_Name (Ent);
 481          Write_Str (" = ");
 482          Print_Field (Field11 (Ent));
 483          Print_Eol;
 484       end if;
 485
 486       if Field_Present (Field12 (Ent)) then
 487          Print_Str (Prefix);
 488          Write_Field12_Name (Ent);
 489          Write_Str (" = ");
 490          Print_Field (Field12 (Ent));
 491          Print_Eol;
 492       end if;
 493
 494       if Field_Present (Field13 (Ent)) then
 495          Print_Str (Prefix);
 496          Write_Field13_Name (Ent);
 497          Write_Str (" = ");
 498          Print_Field (Field13 (Ent));
 499          Print_Eol;
 500       end if;
 501
 502       if Field_Present (Field14 (Ent)) then
 503          Print_Str (Prefix);
 504          Write_Field14_Name (Ent);
 505          Write_Str (" = ");
 506          Print_Field (Field14 (Ent));
 507          Print_Eol;
 508       end if;
 509
 510       if Field_Present (Field15 (Ent)) then
 511          Print_Str (Prefix);
 512          Write_Field15_Name (Ent);
 513          Write_Str (" = ");
 514          Print_Field (Field15 (Ent));
 515          Print_Eol;
 516       end if;
 517
 518       if Field_Present (Field16 (Ent)) then
 519          Print_Str (Prefix);
 520          Write_Field16_Name (Ent);
 521          Write_Str (" = ");
 522          Print_Field (Field16 (Ent));
 523          Print_Eol;
 524       end if;
 525
 526       if Field_Present (Field17 (Ent)) then
 527          Print_Str (Prefix);
 528          Write_Field17_Name (Ent);
 529          Write_Str (" = ");
 530          Print_Field (Field17 (Ent));
 531          Print_Eol;
 532       end if;
 533
 534       if Field_Present (Field18 (Ent)) then
 535          Print_Str (Prefix);
 536          Write_Field18_Name (Ent);
 537          Write_Str (" = ");
 538          Print_Field (Field18 (Ent));
 539          Print_Eol;
 540       end if;
 541
 542       if Field_Present (Field19 (Ent)) then
 543          Print_Str (Prefix);
 544          Write_Field19_Name (Ent);
 545          Write_Str (" = ");
 546          Print_Field (Field19 (Ent));
 547          Print_Eol;
 548       end if;
 549
 550       if Field_Present (Field20 (Ent)) then
 551          Print_Str (Prefix);
 552          Write_Field20_Name (Ent);
 553          Write_Str (" = ");
 554          Print_Field (Field20 (Ent));
 555          Print_Eol;
 556       end if;
 557
 558       if Field_Present (Field21 (Ent)) then
 559          Print_Str (Prefix);
 560          Write_Field21_Name (Ent);
 561          Write_Str (" = ");
 562          Print_Field (Field21 (Ent));
 563          Print_Eol;
 564       end if;
 565
 566       if Field_Present (Field22 (Ent)) then
 567          Print_Str (Prefix);
 568          Write_Field22_Name (Ent);
 569          Write_Str (" = ");
 570
 571          --  Mechanism case has to be handled specially
 572
 573          if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
 574             declare
 575                M : constant Mechanism_Type := Mechanism (Ent);
 576
 577             begin
 578                case M is
 579                   when Default_Mechanism
 580                                     => Write_Str ("Default");
 581                   when By_Copy
 582                                     => Write_Str ("By_Copy");
 583                   when By_Reference
 584                                     => Write_Str ("By_Reference");
 585                   when By_Descriptor
 586                                     => Write_Str ("By_Descriptor");
 587                   when By_Descriptor_UBS
 588                                     => Write_Str ("By_Descriptor_UBS");
 589                   when By_Descriptor_UBSB
 590                                     => Write_Str ("By_Descriptor_UBSB");
 591                   when By_Descriptor_UBA
 592                                     => Write_Str ("By_Descriptor_UBA");
 593                   when By_Descriptor_S
 594                                     => Write_Str ("By_Descriptor_S");
 595                   when By_Descriptor_SB
 596                                     => Write_Str ("By_Descriptor_SB");
 597                   when By_Descriptor_A
 598                                     => Write_Str ("By_Descriptor_A");
 599                   when By_Descriptor_NCA
 600                                     => Write_Str ("By_Descriptor_NCA");
 601                   when By_Short_Descriptor
 602                                     => Write_Str ("By_Short_Descriptor");
 603                   when By_Short_Descriptor_UBS
 604                                     => Write_Str ("By_Short_Descriptor_UBS");
 605                   when By_Short_Descriptor_UBSB
 606                                     => Write_Str ("By_Short_Descriptor_UBSB");
 607                   when By_Short_Descriptor_UBA
 608                                     => Write_Str ("By_Short_Descriptor_UBA");
 609                   when By_Short_Descriptor_S
 610                                     => Write_Str ("By_Short_Descriptor_S");
 611                   when By_Short_Descriptor_SB
 612                                     => Write_Str ("By_Short_Descriptor_SB");
 613                   when By_Short_Descriptor_A
 614                                     => Write_Str ("By_Short_Descriptor_A");
 615                   when By_Short_Descriptor_NCA
 616                                     => Write_Str ("By_Short_Descriptor_NCA");
 617
 618                   when 1 .. Mechanism_Type'Last =>
 619                      Write_Str ("By_Copy if size <= ");
 620                      Write_Int (Int (M));
 621
 622                end case;
 623             end;
 624
 625          --  Normal case (not Mechanism)
 626
 627          else
 628             Print_Field (Field22 (Ent));
 629          end if;
 630
 631          Print_Eol;
 632       end if;
 633
 634       if Field_Present (Field23 (Ent)) then
 635          Print_Str (Prefix);
 636          Write_Field23_Name (Ent);
 637          Write_Str (" = ");
 638          Print_Field (Field23 (Ent));
 639          Print_Eol;
 640       end if;
 641
 642       if Field_Present (Field24 (Ent)) then
 643          Print_Str (Prefix);
 644          Write_Field24_Name (Ent);
 645          Write_Str (" = ");
 646          Print_Field (Field24 (Ent));
 647          Print_Eol;
 648       end if;
 649
 650       if Field_Present (Field25 (Ent)) then
 651          Print_Str (Prefix);
 652          Write_Field25_Name (Ent);
 653          Write_Str (" = ");
 654          Print_Field (Field25 (Ent));
 655          Print_Eol;
 656       end if;
 657
 658       if Field_Present (Field26 (Ent)) then
 659          Print_Str (Prefix);
 660          Write_Field26_Name (Ent);
 661          Write_Str (" = ");
 662          Print_Field (Field26 (Ent));
 663          Print_Eol;
 664       end if;
 665
 666       if Field_Present (Field27 (Ent)) then
 667          Print_Str (Prefix);
 668          Write_Field27_Name (Ent);
 669          Write_Str (" = ");
 670          Print_Field (Field27 (Ent));
 671          Print_Eol;
 672       end if;
 673
 674       if Field_Present (Field28 (Ent)) then
 675          Print_Str (Prefix);
 676          Write_Field28_Name (Ent);
 677          Write_Str (" = ");
 678          Print_Field (Field28 (Ent));
 679          Print_Eol;
 680       end if;
 681
 682       if Field_Present (Field29 (Ent)) then
 683          Print_Str (Prefix);
 684          Write_Field29_Name (Ent);
 685          Write_Str (" = ");
 686          Print_Field (Field29 (Ent));
 687          Print_Eol;
 688       end if;
 689
 690       if Field_Present (Field30 (Ent)) then
 691          Print_Str (Prefix);
 692          Write_Field30_Name (Ent);
 693          Write_Str (" = ");
 694          Print_Field (Field30 (Ent));
 695          Print_Eol;
 696       end if;
 697
 698       if Field_Present (Field31 (Ent)) then
 699          Print_Str (Prefix);
 700          Write_Field31_Name (Ent);
 701          Write_Str (" = ");
 702          Print_Field (Field31 (Ent));
 703          Print_Eol;
 704       end if;
 705
 706       if Field_Present (Field32 (Ent)) then
 707          Print_Str (Prefix);
 708          Write_Field32_Name (Ent);
 709          Write_Str (" = ");
 710          Print_Field (Field32 (Ent));
 711          Print_Eol;
 712       end if;
 713
 714       if Field_Present (Field33 (Ent)) then
 715          Print_Str (Prefix);
 716          Write_Field33_Name (Ent);
 717          Write_Str (" = ");
 718          Print_Field (Field33 (Ent));
 719          Print_Eol;
 720       end if;
 721
 722       if Field_Present (Field34 (Ent)) then
 723          Print_Str (Prefix);
 724          Write_Field34_Name (Ent);
 725          Write_Str (" = ");
 726          Print_Field (Field34 (Ent));
 727          Print_Eol;
 728       end if;
 729
 730       if Field_Present (Field35 (Ent)) then
 731          Print_Str (Prefix);
 732          Write_Field35_Name (Ent);
 733          Write_Str (" = ");
 734          Print_Field (Field35 (Ent));
 735          Print_Eol;
 736       end if;
 737
 738       Write_Entity_Flags (Ent, Prefix);
 739    end Print_Entity_Info;
 740
 741    ---------------
 742    -- Print_Eol --
 743    ---------------
 744
 745    procedure Print_Eol is
 746    begin
 747       if Phase = Printing then
 748          Write_Eol;
 749       end if;
 750    end Print_Eol;
 751
 752    -----------------
 753    -- Print_Field --
 754    -----------------
 755
 756    procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
 757    begin
 758       if Phase /= Printing then
 759          return;
 760       end if;
 761
 762       if Val in Node_Range then
 763          Print_Node_Ref (Node_Id (Val));
 764
 765       elsif Val in List_Range then
 766          Print_List_Ref (List_Id (Val));
 767
 768       elsif Val in Elist_Range then
 769          Print_Elist_Ref (Elist_Id (Val));
 770
 771       elsif Val in Names_Range then
 772          Print_Name (Name_Id (Val));
 773          Write_Str (" (Name_Id=");
 774          Write_Int (Int (Val));
 775          Write_Char (')');
 776
 777       elsif Val in Strings_Range then
 778          Write_String_Table_Entry (String_Id (Val));
 779          Write_Str (" (String_Id=");
 780          Write_Int (Int (Val));
 781          Write_Char (')');
 782
 783       elsif Val in Uint_Range then
 784          UI_Write (From_Union (Val), Format);
 785          Write_Str (" (Uint = ");
 786          Write_Int (Int (Val));
 787          Write_Char (')');
 788
 789       elsif Val in Ureal_Range then
 790          UR_Write (From_Union (Val));
 791          Write_Str (" (Ureal = ");
 792          Write_Int (Int (Val));
 793          Write_Char (')');
 794
 795       else
 796          Print_Str ("****** Incorrect value = ");
 797          Print_Int (Int (Val));
 798       end if;
 799    end Print_Field;
 800
 801    ----------------
 802    -- Print_Flag --
 803    ----------------
 804
 805    procedure Print_Flag (F : Boolean) is
 806    begin
 807       if F then
 808          Print_Str ("True");
 809       else
 810          Print_Str ("False");
 811       end if;
 812    end Print_Flag;
 813
 814    ----------------
 815    -- Print_Init --
 816    ----------------
 817
 818    procedure Print_Init is
 819    begin
 820       Printing_Descendants := True;
 821       Write_Eol;
 822
 823       --  Allocate and clear serial number hash table. The size is 150% of
 824       --  the maximum possible number of entries, so that the hash table
 825       --  cannot get significantly overloaded.
 826
 827       Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
 828       Hash_Table := new Hash_Table_Type  (0 .. Hash_Table_Len - 1);
 829
 830       for J in Hash_Table'Range loop
 831          Hash_Table (J).Serial := 0;
 832       end loop;
 833
 834    end Print_Init;
 835
 836    ---------------
 837    -- Print_Int --
 838    ---------------
 839
 840    procedure Print_Int (I : Int) is
 841    begin
 842       if Phase = Printing then
 843          Write_Int (I);
 844       end if;
 845    end Print_Int;
 846
 847    --------------------
 848    -- Print_List_Ref --
 849    --------------------
 850
 851    procedure Print_List_Ref (L : List_Id) is
 852    begin
 853       if Phase /= Printing then
 854          return;
 855       end if;
 856
 857       if No (L) then
 858          Write_Str ("<no list>");
 859
 860       elsif Is_Empty_List (L) then
 861          Write_Str ("<empty list> (List_Id=");
 862          Write_Int (Int (L));
 863          Write_Char (')');
 864
 865       else
 866          Write_Str ("List");
 867
 868          if Printing_Descendants then
 869             Write_Str (" #");
 870             Write_Int (Serial_Number (Int (L)));
 871          end if;
 872
 873          Write_Str (" (List_Id=");
 874          Write_Int (Int (L));
 875          Write_Char (')');
 876       end if;
 877    end Print_List_Ref;
 878
 879    ------------------------
 880    -- Print_List_Subtree --
 881    ------------------------
 882
 883    procedure Print_List_Subtree (L : List_Id) is
 884    begin
 885       Print_Init;
 886
 887       Next_Serial_Number := 1;
 888       Phase := Marking;
 889       Visit_List (L, "");
 890
 891       Next_Serial_Number := 1;
 892       Phase := Printing;
 893       Visit_List (L, "");
 894
 895       Print_Term;
 896    end Print_List_Subtree;
 897
 898    ----------------
 899    -- Print_Name --
 900    ----------------
 901
 902    procedure Print_Name (N : Name_Id) is
 903    begin
 904       if Phase = Printing then
 905          if N = No_Name then
 906             Print_Str ("<No_Name>");
 907
 908          elsif N = Error_Name then
 909             Print_Str ("<Error_Name>");
 910
 911          elsif Is_Valid_Name (N) then
 912             Get_Name_String (N);
 913             Print_Char ('"');
 914             Write_Name (N);
 915             Print_Char ('"');
 916
 917          else
 918             Print_Str ("<invalid name ???>");
 919          end if;
 920       end if;
 921    end Print_Name;
 922
 923    ----------------
 924    -- Print_Node --
 925    ----------------
 926
 927    procedure Print_Node
 928      (N           : Node_Id;
 929       Prefix_Str  : String;
 930       Prefix_Char : Character)
 931    is
 932       F : Fchar;
 933       P : Natural := Pchar_Pos (Nkind (N));
 934
 935       Field_To_Be_Printed : Boolean;
 936       Prefix_Str_Char     : String (Prefix_Str'First .. Prefix_Str'Last + 1);
 937
 938       Sfile : Source_File_Index;
 939       Fmt   : UI_Format;
 940
 941    begin
 942       if Phase /= Printing then
 943          return;
 944       end if;
 945
 946       if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
 947          Fmt := Hex;
 948       else
 949          Fmt := Auto;
 950       end if;
 951
 952       Prefix_Str_Char (Prefix_Str'Range)    := Prefix_Str;
 953       Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
 954
 955       --  Print header line
 956
 957       Print_Str (Prefix_Str);
 958       Print_Node_Header (N);
 959
 960       if Is_Rewrite_Substitution (N) then
 961          Print_Str (Prefix_Str);
 962          Print_Str (" Rewritten: original node = ");
 963          Print_Node_Ref (Original_Node (N));
 964          Print_Eol;
 965       end if;
 966
 967       if N = Empty then
 968          return;
 969       end if;
 970
 971       if not Is_List_Member (N) then
 972          Print_Str (Prefix_Str);
 973          Print_Str (" Parent = ");
 974          Print_Node_Ref (Parent (N));
 975          Print_Eol;
 976       end if;
 977
 978       --  Print Sloc field if it is set
 979
 980       if Sloc (N) /= No_Location then
 981          Print_Str (Prefix_Str_Char);
 982          Print_Str ("Sloc = ");
 983
 984          if Sloc (N) = Standard_Location then
 985             Print_Str ("Standard_Location");
 986
 987          elsif Sloc (N) = Standard_ASCII_Location then
 988             Print_Str ("Standard_ASCII_Location");
 989
 990          else
 991             Sfile := Get_Source_File_Index (Sloc (N));
 992             Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
 993             Write_Str ("  ");
 994             Write_Location (Sloc (N));
 995          end if;
 996
 997          Print_Eol;
 998       end if;
 999
1000       --  Print Chars field if present
1001
1002       if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
1003          Print_Str (Prefix_Str_Char);
1004          Print_Str ("Chars = ");
1005          Print_Name (Chars (N));
1006          Write_Str (" (Name_Id=");
1007          Write_Int (Int (Chars (N)));
1008          Write_Char (')');
1009          Print_Eol;
1010       end if;
1011
1012       --  Special field print operations for non-entity nodes
1013
1014       if Nkind (N) not in N_Entity then
1015
1016          --  Deal with Left_Opnd and Right_Opnd fields
1017
1018          if Nkind (N) in N_Op
1019            or else Nkind (N) in N_Short_Circuit
1020            or else Nkind (N) in N_Membership_Test
1021          then
1022             --  Print Left_Opnd if present
1023
1024             if Nkind (N) not in N_Unary_Op then
1025                Print_Str (Prefix_Str_Char);
1026                Print_Str ("Left_Opnd = ");
1027                Print_Node_Ref (Left_Opnd (N));
1028                Print_Eol;
1029             end if;
1030
1031             --  Print Right_Opnd
1032
1033             Print_Str (Prefix_Str_Char);
1034             Print_Str ("Right_Opnd = ");
1035             Print_Node_Ref (Right_Opnd (N));
1036             Print_Eol;
1037          end if;
1038
1039          --  Print Entity field if operator (other cases of Entity
1040          --  are in the table, so are handled in the normal circuit)
1041
1042          if Nkind (N) in N_Op and then Present (Entity (N)) then
1043             Print_Str (Prefix_Str_Char);
1044             Print_Str ("Entity = ");
1045             Print_Node_Ref (Entity (N));
1046             Print_Eol;
1047          end if;
1048
1049          --  Print special fields if we have a subexpression
1050
1051          if Nkind (N) in N_Subexpr then
1052
1053             if Assignment_OK (N) then
1054                Print_Str (Prefix_Str_Char);
1055                Print_Str ("Assignment_OK = True");
1056                Print_Eol;
1057             end if;
1058
1059             if Do_Range_Check (N) then
1060                Print_Str (Prefix_Str_Char);
1061                Print_Str ("Do_Range_Check = True");
1062                Print_Eol;
1063             end if;
1064
1065             if Has_Dynamic_Length_Check (N) then
1066                Print_Str (Prefix_Str_Char);
1067                Print_Str ("Has_Dynamic_Length_Check = True");
1068                Print_Eol;
1069             end if;
1070
1071             if Has_Aspects (N) then
1072                Print_Str (Prefix_Str_Char);
1073                Print_Str ("Has_Aspects = True");
1074                Print_Eol;
1075             end if;
1076
1077             if Has_Dynamic_Range_Check (N) then
1078                Print_Str (Prefix_Str_Char);
1079                Print_Str ("Has_Dynamic_Range_Check = True");
1080                Print_Eol;
1081             end if;
1082
1083             if Is_Controlling_Actual (N) then
1084                Print_Str (Prefix_Str_Char);
1085                Print_Str ("Is_Controlling_Actual = True");
1086                Print_Eol;
1087             end if;
1088
1089             if Is_Overloaded (N) then
1090                Print_Str (Prefix_Str_Char);
1091                Print_Str ("Is_Overloaded = True");
1092                Print_Eol;
1093             end if;
1094
1095             if Is_Static_Expression (N) then
1096                Print_Str (Prefix_Str_Char);
1097                Print_Str ("Is_Static_Expression = True");
1098                Print_Eol;
1099             end if;
1100
1101             if Must_Not_Freeze (N) then
1102                Print_Str (Prefix_Str_Char);
1103                Print_Str ("Must_Not_Freeze = True");
1104                Print_Eol;
1105             end if;
1106
1107             if Paren_Count (N) /= 0 then
1108                Print_Str (Prefix_Str_Char);
1109                Print_Str ("Paren_Count = ");
1110                Print_Int (Int (Paren_Count (N)));
1111                Print_Eol;
1112             end if;
1113
1114             if Raises_Constraint_Error (N) then
1115                Print_Str (Prefix_Str_Char);
1116                Print_Str ("Raise_Constraint_Error = True");
1117                Print_Eol;
1118             end if;
1119
1120          end if;
1121
1122          --  Print Do_Overflow_Check field if present
1123
1124          if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
1125             Print_Str (Prefix_Str_Char);
1126             Print_Str ("Do_Overflow_Check = True");
1127             Print_Eol;
1128          end if;
1129
1130          --  Print Etype field if present (printing of this field for entities
1131          --  is handled by the Print_Entity_Info procedure).
1132
1133          if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
1134             Print_Str (Prefix_Str_Char);
1135             Print_Str ("Etype = ");
1136             Print_Node_Ref (Etype (N));
1137             Print_Eol;
1138          end if;
1139       end if;
1140
1141       --  Loop to print fields included in Pchars array
1142
1143       while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
1144          F := Pchars (P);
1145          P := P + 1;
1146
1147          --  Check for case of False flag, which we never print, or
1148          --  an Empty field, which is also never printed
1149
1150          case F is
1151             when F_Field1 =>
1152                Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
1153
1154             when F_Field2 =>
1155                Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
1156
1157             when F_Field3 =>
1158                Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
1159
1160             when F_Field4 =>
1161                Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
1162
1163             when F_Field5 =>
1164                Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
1165
1166             --  Flag3 is obsolete, so this probably gets removed ???
1167
1168             when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N);
1169
1170             when F_Flag4  => Field_To_Be_Printed := Flag4  (N);
1171             when F_Flag5  => Field_To_Be_Printed := Flag5  (N);
1172             when F_Flag6  => Field_To_Be_Printed := Flag6  (N);
1173             when F_Flag7  => Field_To_Be_Printed := Flag7  (N);
1174             when F_Flag8  => Field_To_Be_Printed := Flag8  (N);
1175             when F_Flag9  => Field_To_Be_Printed := Flag9  (N);
1176             when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
1177             when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
1178             when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
1179             when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
1180             when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
1181             when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
1182             when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
1183             when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
1184             when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
1185
1186             --  Flag1,2 are no longer used
1187
1188             when F_Flag1  => raise Program_Error;
1189             when F_Flag2  => raise Program_Error;
1190          end case;
1191
1192          --  Print field if it is to be printed
1193
1194          if Field_To_Be_Printed then
1195             Print_Str (Prefix_Str_Char);
1196
1197             while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
1198               and then Pchars (P) not in Fchar
1199             loop
1200                Print_Char (Pchars (P));
1201                P := P + 1;
1202             end loop;
1203
1204             Print_Str (" = ");
1205
1206             case F is
1207                when F_Field1 => Print_Field (Field1 (N), Fmt);
1208                when F_Field2 => Print_Field (Field2 (N), Fmt);
1209                when F_Field3 => Print_Field (Field3 (N), Fmt);
1210                when F_Field4 => Print_Field (Field4 (N), Fmt);
1211
1212                --  Special case End_Span = Uint5
1213
1214                when F_Field5 =>
1215                   if Nkind (N) = N_Case_Statement
1216                     or else Nkind (N) = N_If_Statement
1217                   then
1218                      Print_End_Span (N);
1219                   else
1220                      Print_Field (Field5 (N), Fmt);
1221                   end if;
1222
1223                when F_Flag4  => Print_Flag  (Flag4 (N));
1224                when F_Flag5  => Print_Flag  (Flag5 (N));
1225                when F_Flag6  => Print_Flag  (Flag6 (N));
1226                when F_Flag7  => Print_Flag  (Flag7 (N));
1227                when F_Flag8  => Print_Flag  (Flag8 (N));
1228                when F_Flag9  => Print_Flag  (Flag9 (N));
1229                when F_Flag10 => Print_Flag  (Flag10 (N));
1230                when F_Flag11 => Print_Flag  (Flag11 (N));
1231                when F_Flag12 => Print_Flag  (Flag12 (N));
1232                when F_Flag13 => Print_Flag  (Flag13 (N));
1233                when F_Flag14 => Print_Flag  (Flag14 (N));
1234                when F_Flag15 => Print_Flag  (Flag15 (N));
1235                when F_Flag16 => Print_Flag  (Flag16 (N));
1236                when F_Flag17 => Print_Flag  (Flag17 (N));
1237                when F_Flag18 => Print_Flag  (Flag18 (N));
1238
1239                --  Flag1,2 are no longer used
1240
1241                when F_Flag1  => raise Program_Error;
1242                when F_Flag2  => raise Program_Error;
1243
1244                --  Not clear why we need the following ???
1245
1246                when F_Flag3  => Print_Flag (Has_Aspects (N));
1247             end case;
1248
1249             Print_Eol;
1250
1251          --  Field is not to be printed (False flag field)
1252
1253          else
1254             while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
1255               and then Pchars (P) not in Fchar
1256             loop
1257                P := P + 1;
1258             end loop;
1259          end if;
1260       end loop;
1261
1262       --  Print aspects if present
1263
1264       if Has_Aspects (N) then
1265          Print_Str (Prefix_Str_Char);
1266          Print_Str ("Aspect_Specifications = ");
1267          Print_Field (Union_Id (Aspect_Specifications (N)));
1268          Print_Eol;
1269       end if;
1270
1271       --  Print entity information for entities
1272
1273       if Nkind (N) in N_Entity then
1274          Print_Entity_Info (N, Prefix_Str_Char);
1275       end if;
1276
1277       --  Print the SCIL node (if available)
1278
1279       if Present (Get_SCIL_Node (N)) then
1280          Print_Str (Prefix_Str_Char);
1281          Print_Str ("SCIL_Node = ");
1282          Print_Node_Ref (Get_SCIL_Node (N));
1283          Print_Eol;
1284       end if;
1285    end Print_Node;
1286
1287    ------------------------
1288    -- Print_Node_Briefly --
1289    ------------------------
1290
1291    procedure Print_Node_Briefly (N : Node_Id) is
1292    begin
1293       Printing_Descendants := False;
1294       Phase := Printing;
1295       Print_Node_Header (N);
1296    end Print_Node_Briefly;
1297
1298    -----------------------
1299    -- Print_Node_Header --
1300    -----------------------
1301
1302    procedure Print_Node_Header (N : Node_Id) is
1303       Notes : Boolean := False;
1304
1305    begin
1306       Print_Node_Ref (N);
1307
1308       if N > Atree_Private_Part.Nodes.Last then
1309          Print_Str (" (no such node)");
1310          Print_Eol;
1311          return;
1312       end if;
1313
1314       if Comes_From_Source (N) then
1315          Notes := True;
1316          Print_Str (" (source");
1317       end if;
1318
1319       if Analyzed (N) then
1320          if not Notes then
1321             Notes := True;
1322             Print_Str (" (");
1323          else
1324             Print_Str (",");
1325          end if;
1326
1327          Print_Str ("analyzed");
1328       end if;
1329
1330       if Error_Posted (N) then
1331          if not Notes then
1332             Notes := True;
1333             Print_Str (" (");
1334          else
1335             Print_Str (",");
1336          end if;
1337
1338          Print_Str ("posted");
1339       end if;
1340
1341       if Notes then
1342          Print_Char (')');
1343       end if;
1344
1345       Print_Eol;
1346    end Print_Node_Header;
1347
1348    ---------------------
1349    -- Print_Node_Kind --
1350    ---------------------
1351
1352    procedure Print_Node_Kind (N : Node_Id) is
1353       Ucase : Boolean;
1354       S     : constant String := Node_Kind'Image (Nkind (N));
1355
1356    begin
1357       if Phase = Printing then
1358          Ucase := True;
1359
1360          --  Note: the call to Fold_Upper in this loop is to get past the GNAT
1361          --  bug of 'Image returning lower case instead of upper case.
1362
1363          for J in S'Range loop
1364             if Ucase then
1365                Write_Char (Fold_Upper (S (J)));
1366             else
1367                Write_Char (Fold_Lower (S (J)));
1368             end if;
1369
1370             Ucase := (S (J) = '_');
1371          end loop;
1372       end if;
1373    end Print_Node_Kind;
1374
1375    --------------------
1376    -- Print_Node_Ref --
1377    --------------------
1378
1379    procedure Print_Node_Ref (N : Node_Id) is
1380       S : Nat;
1381
1382    begin
1383       if Phase /= Printing then
1384          return;
1385       end if;
1386
1387       if N = Empty then
1388          Write_Str ("<empty>");
1389
1390       elsif N = Error then
1391          Write_Str ("<error>");
1392
1393       else
1394          if Printing_Descendants then
1395             S := Serial_Number (Int (N));
1396
1397             if S /= 0 then
1398                Write_Str ("Node");
1399                Write_Str (" #");
1400                Write_Int (S);
1401                Write_Char (' ');
1402             end if;
1403          end if;
1404
1405          Print_Node_Kind (N);
1406
1407          if Nkind (N) in N_Has_Chars then
1408             Write_Char (' ');
1409             Print_Name (Chars (N));
1410          end if;
1411
1412          if Nkind (N) in N_Entity then
1413             Write_Str (" (Entity_Id=");
1414          else
1415             Write_Str (" (Node_Id=");
1416          end if;
1417
1418          Write_Int (Int (N));
1419
1420          if Sloc (N) <= Standard_Location then
1421             Write_Char ('s');
1422          end if;
1423
1424          Write_Char (')');
1425
1426       end if;
1427    end Print_Node_Ref;
1428
1429    ------------------------
1430    -- Print_Node_Subtree --
1431    ------------------------
1432
1433    procedure Print_Node_Subtree (N : Node_Id) is
1434    begin
1435       Print_Init;
1436
1437       Next_Serial_Number := 1;
1438       Phase := Marking;
1439       Visit_Node (N, "", ' ');
1440
1441       Next_Serial_Number := 1;
1442       Phase := Printing;
1443       Visit_Node (N, "", ' ');
1444
1445       Print_Term;
1446    end Print_Node_Subtree;
1447
1448    ---------------
1449    -- Print_Str --
1450    ---------------
1451
1452    procedure Print_Str (S : String) is
1453    begin
1454       if Phase = Printing then
1455          Write_Str (S);
1456       end if;
1457    end Print_Str;
1458
1459    --------------------------
1460    -- Print_Str_Mixed_Case --
1461    --------------------------
1462
1463    procedure Print_Str_Mixed_Case (S : String) is
1464       Ucase : Boolean;
1465
1466    begin
1467       if Phase = Printing then
1468          Ucase := True;
1469
1470          for J in S'Range loop
1471             if Ucase then
1472                Write_Char (S (J));
1473             else
1474                Write_Char (Fold_Lower (S (J)));
1475             end if;
1476
1477             Ucase := (S (J) = '_');
1478          end loop;
1479       end if;
1480    end Print_Str_Mixed_Case;
1481
1482    ----------------
1483    -- Print_Term --
1484    ----------------
1485
1486    procedure Print_Term is
1487       procedure Free is new Unchecked_Deallocation
1488         (Hash_Table_Type, Access_Hash_Table_Type);
1489
1490    begin
1491       Free (Hash_Table);
1492    end Print_Term;
1493
1494    ---------------------
1495    -- Print_Tree_Elist --
1496    ---------------------
1497
1498    procedure Print_Tree_Elist (E : Elist_Id) is
1499       M : Elmt_Id;
1500
1501    begin
1502       Printing_Descendants := False;
1503       Phase := Printing;
1504
1505       Print_Elist_Ref (E);
1506       Print_Eol;
1507
1508       M := First_Elmt (E);
1509
1510       if No (M) then
1511          Print_Str ("<empty element list>");
1512          Print_Eol;
1513
1514       else
1515          loop
1516             Print_Char ('|');
1517             Print_Eol;
1518             exit when No (Next_Elmt (M));
1519             Print_Node (Node (M), "", '|');
1520             Next_Elmt (M);
1521          end loop;
1522
1523          Print_Node (Node (M), "", ' ');
1524          Print_Eol;
1525       end if;
1526    end Print_Tree_Elist;
1527
1528    ---------------------
1529    -- Print_Tree_List --
1530    ---------------------
1531
1532    procedure Print_Tree_List (L : List_Id) is
1533       N : Node_Id;
1534
1535    begin
1536       Printing_Descendants := False;
1537       Phase := Printing;
1538
1539       Print_List_Ref (L);
1540       Print_Str (" List_Id=");
1541       Print_Int (Int (L));
1542       Print_Eol;
1543
1544       N := First (L);
1545
1546       if N = Empty then
1547          Print_Str ("<empty node list>");
1548          Print_Eol;
1549
1550       else
1551          loop
1552             Print_Char ('|');
1553             Print_Eol;
1554             exit when Next (N) = Empty;
1555             Print_Node (N, "", '|');
1556             Next (N);
1557          end loop;
1558
1559          Print_Node (N, "", ' ');
1560          Print_Eol;
1561       end if;
1562    end Print_Tree_List;
1563
1564    ---------------------
1565    -- Print_Tree_Node --
1566    ---------------------
1567
1568    procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
1569    begin
1570       Printing_Descendants := False;
1571       Phase := Printing;
1572       Print_Node (N, Label, ' ');
1573    end Print_Tree_Node;
1574
1575    --------
1576    -- pt --
1577    --------
1578
1579    procedure pt (N : Node_Id) is
1580    begin
1581       Print_Node_Subtree (N);
1582    end pt;
1583
1584    ---------
1585    -- ppp --
1586    ---------
1587
1588    procedure ppp (N : Node_Id) is
1589    begin
1590       pt (N);
1591    end ppp;
1592
1593    -------------------
1594    -- Serial_Number --
1595    -------------------
1596
1597    --  The hashing algorithm is to use the remainder of the ID value divided
1598    --  by the hash table length as the starting point in the table, and then
1599    --  handle collisions by serial searching wrapping at the end of the table.
1600
1601    Hash_Slot : Nat;
1602    --  Set by an unsuccessful call to Serial_Number (one which returns zero)
1603    --  to save the slot that should be used if Set_Serial_Number is called.
1604
1605    function Serial_Number (Id : Int) return Nat is
1606       H : Int := Id mod Hash_Table_Len;
1607
1608    begin
1609       while Hash_Table (H).Serial /= 0 loop
1610
1611          if Id = Hash_Table (H).Id then
1612             return Hash_Table (H).Serial;
1613          end if;
1614
1615          H := H + 1;
1616
1617          if H > Hash_Table'Last then
1618             H := 0;
1619          end if;
1620       end loop;
1621
1622       --  Entry was not found, save slot number for possible subsequent call
1623       --  to Set_Serial_Number, and unconditionally save the Id in this slot
1624       --  in case of such a call (the Id field is never read if the serial
1625       --  number of the slot is zero, so this is harmless in the case where
1626       --  Set_Serial_Number is not subsequently called).
1627
1628       Hash_Slot := H;
1629       Hash_Table (H).Id := Id;
1630       return 0;
1631
1632    end Serial_Number;
1633
1634    -----------------------
1635    -- Set_Serial_Number --
1636    -----------------------
1637
1638    procedure Set_Serial_Number is
1639    begin
1640       Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
1641       Next_Serial_Number := Next_Serial_Number + 1;
1642    end Set_Serial_Number;
1643
1644    ---------------
1645    -- Tree_Dump --
1646    ---------------
1647
1648    procedure Tree_Dump is
1649       procedure Underline;
1650       --  Put underline under string we just printed
1651
1652       procedure Underline is
1653          Col : constant Int := Column;
1654
1655       begin
1656          Write_Eol;
1657
1658          while Col > Column loop
1659             Write_Char ('-');
1660          end loop;
1661
1662          Write_Eol;
1663       end Underline;
1664
1665    --  Start of processing for Tree_Dump. Note that we turn off the tree dump
1666    --  flags immediately, before starting the dump. This avoids generating two
1667    --  copies of the dump if an abort occurs after printing the dump, and more
1668    --  importantly, avoids an infinite loop if an abort occurs during the dump.
1669
1670    --  Note: unlike in the source print case (in Sprint), we do not output
1671    --  separate trees for each unit. Instead the -df debug switch causes the
1672    --  tree that is output from the main unit to trace references into other
1673    --  units (normally such references are not traced). Since all other units
1674    --  are linked to the main unit by at least one reference, this causes all
1675    --  tree nodes to be included in the output tree.
1676
1677    begin
1678       if Debug_Flag_Y then
1679          Debug_Flag_Y := False;
1680          Write_Eol;
1681          Write_Str ("Tree created for Standard (spec) ");
1682          Underline;
1683          Print_Node_Subtree (Standard_Package_Node);
1684          Write_Eol;
1685       end if;
1686
1687       if Debug_Flag_T then
1688          Debug_Flag_T := False;
1689
1690          Write_Eol;
1691          Write_Str ("Tree created for ");
1692          Write_Unit_Name (Unit_Name (Main_Unit));
1693          Underline;
1694          Print_Node_Subtree (Cunit (Main_Unit));
1695          Write_Eol;
1696       end if;
1697
1698    end Tree_Dump;
1699
1700    -----------------
1701    -- Visit_Elist --
1702    -----------------
1703
1704    procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
1705       M : Elmt_Id;
1706       N : Node_Id;
1707       S : constant Nat := Serial_Number (Int (E));
1708
1709    begin
1710       --  In marking phase, return if already marked, otherwise set next
1711       --  serial number in hash table for later reference.
1712
1713       if Phase = Marking then
1714          if S /= 0 then
1715             return; -- already visited
1716          else
1717             Set_Serial_Number;
1718          end if;
1719
1720       --  In printing phase, if already printed, then return, otherwise we
1721       --  are printing the next item, so increment the serial number.
1722
1723       else
1724          if S < Next_Serial_Number then
1725             return; -- already printed
1726          else
1727             Next_Serial_Number := Next_Serial_Number + 1;
1728          end if;
1729       end if;
1730
1731       --  Now process the list (Print calls have no effect in marking phase)
1732
1733       Print_Str (Prefix_Str);
1734       Print_Elist_Ref (E);
1735       Print_Eol;
1736
1737       if Is_Empty_Elmt_List (E) then
1738          Print_Str (Prefix_Str);
1739          Print_Str ("(Empty element list)");
1740          Print_Eol;
1741          Print_Eol;
1742
1743       else
1744          if Phase = Printing then
1745             M := First_Elmt (E);
1746             while Present (M) loop
1747                N := Node (M);
1748                Print_Str (Prefix_Str);
1749                Print_Str (" ");
1750                Print_Node_Ref (N);
1751                Print_Eol;
1752                Next_Elmt (M);
1753             end loop;
1754
1755             Print_Str (Prefix_Str);
1756             Print_Eol;
1757          end if;
1758
1759          M := First_Elmt (E);
1760          while Present (M) loop
1761             Visit_Node (Node (M), Prefix_Str, ' ');
1762             Next_Elmt (M);
1763          end loop;
1764       end if;
1765    end Visit_Elist;
1766
1767    ----------------
1768    -- Visit_List --
1769    ----------------
1770
1771    procedure Visit_List (L : List_Id; Prefix_Str : String) is
1772       N : Node_Id;
1773       S : constant Nat := Serial_Number (Int (L));
1774
1775    begin
1776       --  In marking phase, return if already marked, otherwise set next
1777       --  serial number in hash table for later reference.
1778
1779       if Phase = Marking then
1780          if S /= 0 then
1781             return;
1782          else
1783             Set_Serial_Number;
1784          end if;
1785
1786       --  In printing phase, if already printed, then return, otherwise we
1787       --  are printing the next item, so increment the serial number.
1788
1789       else
1790          if S < Next_Serial_Number then
1791             return; -- already printed
1792          else
1793             Next_Serial_Number := Next_Serial_Number + 1;
1794          end if;
1795       end if;
1796
1797       --  Now process the list (Print calls have no effect in marking phase)
1798
1799       Print_Str (Prefix_Str);
1800       Print_List_Ref (L);
1801       Print_Eol;
1802
1803       Print_Str (Prefix_Str);
1804       Print_Str ("|Parent = ");
1805       Print_Node_Ref (Parent (L));
1806       Print_Eol;
1807
1808       N := First (L);
1809
1810       if N = Empty then
1811          Print_Str (Prefix_Str);
1812          Print_Str ("(Empty list)");
1813          Print_Eol;
1814          Print_Eol;
1815
1816       else
1817          Print_Str (Prefix_Str);
1818          Print_Char ('|');
1819          Print_Eol;
1820
1821          while Next (N) /= Empty loop
1822             Visit_Node (N, Prefix_Str, '|');
1823             Next (N);
1824          end loop;
1825       end if;
1826
1827       Visit_Node (N, Prefix_Str, ' ');
1828    end Visit_List;
1829
1830    ----------------
1831    -- Visit_Node --
1832    ----------------
1833
1834    procedure Visit_Node
1835      (N           : Node_Id;
1836       Prefix_Str  : String;
1837       Prefix_Char : Character)
1838    is
1839       New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
1840       --  Prefix string for printing referenced fields
1841
1842       procedure Visit_Descendent
1843         (D         : Union_Id;
1844          No_Indent : Boolean := False);
1845       --  This procedure tests the given value of one of the Fields referenced
1846       --  by the current node to determine whether to visit it recursively.
1847       --  Normally No_Indent is false, which means that the visited node will
1848       --  be indented using New_Prefix. If No_Indent is set to True, then
1849       --  this indentation is skipped, and Prefix_Str is used for the call
1850       --  to print the descendent. No_Indent is effective only if the
1851       --  referenced descendent is a node.
1852
1853       ----------------------
1854       -- Visit_Descendent --
1855       ----------------------
1856
1857       procedure Visit_Descendent
1858         (D         : Union_Id;
1859          No_Indent : Boolean := False)
1860       is
1861       begin
1862          --  Case of descendent is a node
1863
1864          if D in Node_Range then
1865
1866             --  Don't bother about Empty or Error descendents
1867
1868             if D <= Union_Id (Empty_Or_Error) then
1869                return;
1870             end if;
1871
1872             declare
1873                Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
1874
1875             begin
1876                --  Descendents in one of the standardly compiled internal
1877                --  packages are normally ignored, unless the parent is also
1878                --  in such a package (happens when Standard itself is output)
1879                --  or if the -df switch is set which causes all links to be
1880                --  followed, even into package standard.
1881
1882                if Sloc (Nod) <= Standard_Location then
1883                   if Sloc (N) > Standard_Location
1884                     and then not Debug_Flag_F
1885                   then
1886                      return;
1887                   end if;
1888
1889                --  Don't bother about a descendent in a different unit than
1890                --  the node we came from unless the -df switch is set. Note
1891                --  that we know at this point that Sloc (D) > Standard_Location
1892
1893                --  Note: the tests for No_Location here just make sure that we
1894                --  don't blow up on a node which is missing an Sloc value. This
1895                --  should not normally happen.
1896
1897                else
1898                   if (Sloc (N) <= Standard_Location
1899                         or else Sloc (N) = No_Location
1900                         or else Sloc (Nod) = No_Location
1901                         or else not In_Same_Source_Unit (Nod, N))
1902                     and then not Debug_Flag_F
1903                   then
1904                      return;
1905                   end if;
1906                end if;
1907
1908                --  Don't bother visiting a source node that has a parent which
1909                --  is not the node we came from. We prefer to trace such nodes
1910                --  from their real parents. This causes the tree to be printed
1911                --  in a more coherent order, e.g. a defining identifier listed
1912                --  next to its corresponding declaration, instead of next to
1913                --  some semantic reference.
1914
1915                --  This test is skipped for nodes in standard packages unless
1916                --  the -dy option is set (which outputs the tree for standard)
1917
1918                --  Also, always follow pointers to Is_Itype entities,
1919                --  since we want to list these when they are first referenced.
1920
1921                if Parent (Nod) /= Empty
1922                  and then Comes_From_Source (Nod)
1923                  and then Parent (Nod) /= N
1924                  and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
1925                then
1926                   return;
1927                end if;
1928
1929                --  If we successfully fall through all the above tests (which
1930                --  execute a return if the node is not to be visited), we can
1931                --  go ahead and visit the node!
1932
1933                if No_Indent then
1934                   Visit_Node (Nod, Prefix_Str, Prefix_Char);
1935                else
1936                   Visit_Node (Nod, New_Prefix, ' ');
1937                end if;
1938             end;
1939
1940          --  Case of descendent is a list
1941
1942          elsif D in List_Range then
1943
1944             --  Don't bother with a missing list, empty list or error list
1945
1946             if D = Union_Id (No_List)
1947               or else D = Union_Id (Error_List)
1948               or else Is_Empty_List (List_Id (D))
1949             then
1950                return;
1951
1952             --  Otherwise we can visit the list. Note that we don't bother
1953             --  to do the parent test that we did for the node case, because
1954             --  it just does not happen that lists are referenced more than
1955             --  one place in the tree. We aren't counting on this being the
1956             --  case to generate valid output, it is just that we don't need
1957             --  in practice to worry about listing the list at a place that
1958             --  is inconvenient.
1959
1960             else
1961                Visit_List (List_Id (D), New_Prefix);
1962             end if;
1963
1964          --  Case of descendent is an element list
1965
1966          elsif D in Elist_Range then
1967
1968             --  Don't bother with a missing list, or an empty list
1969
1970             if D = Union_Id (No_Elist)
1971               or else Is_Empty_Elmt_List (Elist_Id (D))
1972             then
1973                return;
1974
1975             --  Otherwise, visit the referenced element list
1976
1977             else
1978                Visit_Elist (Elist_Id (D), New_Prefix);
1979             end if;
1980
1981          --  For all other kinds of descendents (strings, names, uints etc),
1982          --  there is nothing to visit (the contents of the field will be
1983          --  printed when we print the containing node, but what concerns
1984          --  us now is looking for descendents in the tree.
1985
1986          else
1987             null;
1988          end if;
1989       end Visit_Descendent;
1990
1991    --  Start of processing for Visit_Node
1992
1993    begin
1994       if N = Empty then
1995          return;
1996       end if;
1997
1998       --  Set fatal error node in case we get a blow up during the trace
1999
2000       Current_Error_Node := N;
2001
2002       New_Prefix (Prefix_Str'Range)    := Prefix_Str;
2003       New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
2004       New_Prefix (Prefix_Str'Last + 2) := ' ';
2005
2006       --  In the marking phase, all we do is to set the serial number
2007
2008       if Phase = Marking then
2009          if Serial_Number (Int (N)) /= 0 then
2010             return; -- already visited
2011          else
2012             Set_Serial_Number;
2013          end if;
2014
2015       --  In the printing phase, we print the node
2016
2017       else
2018          if Serial_Number (Int (N)) < Next_Serial_Number then
2019
2020             --  Here we have already visited the node, but if it is in
2021             --  a list, we still want to print the reference, so that
2022             --  it is clear that it belongs to the list.
2023
2024             if Is_List_Member (N) then
2025                Print_Str (Prefix_Str);
2026                Print_Node_Ref (N);
2027                Print_Eol;
2028                Print_Str (Prefix_Str);
2029                Print_Char (Prefix_Char);
2030                Print_Str ("(already output)");
2031                Print_Eol;
2032                Print_Str (Prefix_Str);
2033                Print_Char (Prefix_Char);
2034                Print_Eol;
2035             end if;
2036
2037             return;
2038
2039          else
2040             Print_Node (N, Prefix_Str, Prefix_Char);
2041             Print_Str (Prefix_Str);
2042             Print_Char (Prefix_Char);
2043             Print_Eol;
2044             Next_Serial_Number := Next_Serial_Number + 1;
2045          end if;
2046       end if;
2047
2048       --  Visit all descendents of this node
2049
2050       if Nkind (N) not in N_Entity then
2051          Visit_Descendent (Field1 (N));
2052          Visit_Descendent (Field2 (N));
2053          Visit_Descendent (Field3 (N));
2054          Visit_Descendent (Field4 (N));
2055          Visit_Descendent (Field5 (N));
2056
2057          if Has_Aspects (N) then
2058             Visit_Descendent (Union_Id (Aspect_Specifications (N)));
2059          end if;
2060
2061       --  Entity case
2062
2063       else
2064          Visit_Descendent (Field1 (N));
2065          Visit_Descendent (Field3 (N));
2066          Visit_Descendent (Field4 (N));
2067          Visit_Descendent (Field5 (N));
2068          Visit_Descendent (Field6 (N));
2069          Visit_Descendent (Field7 (N));
2070          Visit_Descendent (Field8 (N));
2071          Visit_Descendent (Field9 (N));
2072          Visit_Descendent (Field10 (N));
2073          Visit_Descendent (Field11 (N));
2074          Visit_Descendent (Field12 (N));
2075          Visit_Descendent (Field13 (N));
2076          Visit_Descendent (Field14 (N));
2077          Visit_Descendent (Field15 (N));
2078          Visit_Descendent (Field16 (N));
2079          Visit_Descendent (Field17 (N));
2080          Visit_Descendent (Field18 (N));
2081          Visit_Descendent (Field19 (N));
2082          Visit_Descendent (Field20 (N));
2083          Visit_Descendent (Field21 (N));
2084          Visit_Descendent (Field22 (N));
2085          Visit_Descendent (Field23 (N));
2086
2087          --  Now an interesting kludge. Normally parents are always printed
2088          --  since we traverse the tree in a downwards direction. There is
2089          --  however an exception to this rule, which is the case where a
2090          --  parent is constructed by the compiler and is not referenced
2091          --  elsewhere in the tree. The following catches this case
2092
2093          if not Comes_From_Source (N) then
2094             Visit_Descendent (Union_Id (Parent (N)));
2095          end if;
2096
2097          --  You may be wondering why we omitted Field2 above. The answer
2098          --  is that this is the Next_Entity field, and we want to treat
2099          --  it rather specially. Why? Because a Next_Entity link does not
2100          --  correspond to a level deeper in the tree, and we do not want
2101          --  the tree to march off to the right of the page due to bogus
2102          --  indentations coming from this effect.
2103
2104          --  To prevent this, what we do is to control references via
2105          --  Next_Entity only from the first entity on a given scope
2106          --  chain, and we keep them all at the same level. Of course
2107          --  if an entity has already been referenced it is not printed.
2108
2109          if Present (Next_Entity (N))
2110            and then Present (Scope (N))
2111            and then First_Entity (Scope (N)) = N
2112          then
2113             declare
2114                Nod : Node_Id;
2115
2116             begin
2117                Nod := N;
2118                while Present (Nod) loop
2119                   Visit_Descendent (Union_Id (Next_Entity (Nod)));
2120                   Nod := Next_Entity (Nod);
2121                end loop;
2122             end;
2123          end if;
2124       end if;
2125    end Visit_Node;
2126
2127 end Treepr;