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