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