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