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