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