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