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