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