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