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