gcc/ada/sprint.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               S P R I N T                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2015, 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 Casing;   use Casing;
  29 with Csets;    use Csets;
  30 with Debug;    use Debug;
  31 with Einfo;    use Einfo;
  32 with Fname;    use Fname;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Opt;      use Opt;
  37 with Output;   use Output;
  38 with Rtsfind;  use Rtsfind;
  39 with Sem_Eval; use Sem_Eval;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Sinput;   use Sinput;
  43 with Sinput.D; use Sinput.D;
  44 with Snames;   use Snames;
  45 with Stand;    use Stand;
  46 with Stringt;  use Stringt;
  47 with Uintp;    use Uintp;
  48 with Uname;    use Uname;
  49 with Urealp;   use Urealp;
  50
  51 package body Sprint is
  52    Current_Source_File : Source_File_Index;
  53    --  Index of source file whose generated code is being dumped
  54
  55    Dump_Node : Node_Id := Empty;
  56    --  This is set to the current node, used for printing line numbers. In
  57    --  Debug_Generated_Code mode, Dump_Node is set to the current node
  58    --  requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
  59    --  value. The call clears it back to Empty.
  60
  61    First_Debug_Sloc : Source_Ptr;
  62    --  Sloc of first byte of the current output file if we are generating a
  63    --  source debug file.
  64
  65    Debug_Sloc : Source_Ptr;
  66    --  Sloc of first byte of line currently being written if we are
  67    --  generating a source debug file.
  68
  69    Dump_Original_Only : Boolean;
  70    --  Set True if the -gnatdo (dump original tree) flag is set
  71
  72    Dump_Generated_Only : Boolean;
  73    --  Set True if the -gnatdG (dump generated tree) debug flag is set
  74    --  or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
  75
  76    Dump_Freeze_Null : Boolean;
  77    --  Set True if empty freeze nodes and non-source null statements output.
  78    --  Note that freeze nodes containing freeze actions are always output,
  79    --  as are freeze nodes for itypes, which in general have the effect of
  80    --  causing elaboration of the itype.
  81
  82    Freeze_Indent : Int := 0;
  83    --  Keep track of freeze indent level (controls output of blank lines before
  84    --  procedures within expression freeze actions). Relevant only if we are
  85    --  not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
  86    --  output these blank lines in any case.
  87
  88    Indent : Int := 0;
  89    --  Number of columns for current line output indentation
  90
  91    Indent_Annull_Flag : Boolean := False;
  92    --  Set True if subsequent Write_Indent call to be ignored, gets reset
  93    --  by this call, so it is only active to suppress a single indent call.
  94
  95    Last_Line_Printed : Physical_Line_Number;
  96    --  This keeps track of the physical line number of the last source line
  97    --  that has been output. The value is only valid in Dump_Source_Text mode.
  98
  99    -------------------------------
 100    -- Operator Precedence Table --
 101    -------------------------------
 102
 103    --  This table is used to decide whether a subexpression needs to be
 104    --  parenthesized. The rule is that if an operand of an operator (which
 105    --  for this purpose includes AND THEN and OR ELSE) is itself an operator
 106    --  with a lower precedence than the operator (or equal precedence if
 107    --  appearing as the right operand), then parentheses are required.
 108
 109    Op_Prec : constant array (N_Subexpr) of Short_Short_Integer :=
 110                (N_Op_And          => 1,
 111                 N_Op_Or           => 1,
 112                 N_Op_Xor          => 1,
 113                 N_And_Then        => 1,
 114                 N_Or_Else         => 1,
 115
 116                 N_In              => 2,
 117                 N_Not_In          => 2,
 118                 N_Op_Eq           => 2,
 119                 N_Op_Ge           => 2,
 120                 N_Op_Gt           => 2,
 121                 N_Op_Le           => 2,
 122                 N_Op_Lt           => 2,
 123                 N_Op_Ne           => 2,
 124
 125                 N_Op_Add          => 3,
 126                 N_Op_Concat       => 3,
 127                 N_Op_Subtract     => 3,
 128                 N_Op_Plus         => 3,
 129                 N_Op_Minus        => 3,
 130
 131                 N_Op_Divide       => 4,
 132                 N_Op_Mod          => 4,
 133                 N_Op_Rem          => 4,
 134                 N_Op_Multiply     => 4,
 135
 136                 N_Op_Expon        => 5,
 137                 N_Op_Abs          => 5,
 138                 N_Op_Not          => 5,
 139
 140                 others            => 6);
 141
 142    procedure Sprint_Left_Opnd (N : Node_Id);
 143    --  Print left operand of operator, parenthesizing if necessary
 144
 145    procedure Sprint_Right_Opnd (N : Node_Id);
 146    --  Print right operand of operator, parenthesizing if necessary
 147
 148    -----------------------
 149    -- Local Subprograms --
 150    -----------------------
 151
 152    procedure Col_Check (N : Nat);
 153    --  Check that at least N characters remain on current line, and if not,
 154    --  then start an extra line with two characters extra indentation for
 155    --  continuing text on the next line.
 156
 157    procedure Extra_Blank_Line;
 158    --  In some situations we write extra blank lines to separate the generated
 159    --  code to make it more readable. However, these extra blank lines are not
 160    --  generated in Dump_Source_Text mode, since there the source text lines
 161    --  output with preceding blank lines are quite sufficient as separators.
 162    --  This procedure writes a blank line if Dump_Source_Text is False.
 163
 164    procedure Indent_Annull;
 165    --  Causes following call to Write_Indent to be ignored. This is used when
 166    --  a higher level node wants to stop a lower level node from starting a
 167    --  new line, when it would otherwise be inclined to do so (e.g. the case
 168    --  of an accept statement called from an accept alternative with a guard)
 169
 170    procedure Indent_Begin;
 171    --  Increase indentation level
 172
 173    procedure Indent_End;
 174    --  Decrease indentation level
 175
 176    procedure Print_Debug_Line (S : String);
 177    --  Used to print output lines in Debug_Generated_Code mode (this is used
 178    --  as the argument for a call to Set_Special_Output in package Output).
 179
 180    procedure Process_TFAI_RR_Flags (Nod : Node_Id);
 181    --  Given a divide, multiplication or division node, check the flags
 182    --  Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
 183    --  appropriate special syntax characters (# and @).
 184
 185    procedure Set_Debug_Sloc;
 186    --  If Dump_Node is non-empty, this routine sets the appropriate value
 187    --  in its Sloc field, from the current location in the debug source file
 188    --  that is currently being written.
 189
 190    procedure Sprint_And_List (List : List_Id);
 191    --  Print the given list with items separated by vertical "and"
 192
 193    procedure Sprint_Aspect_Specifications
 194      (Node      : Node_Id;
 195       Semicolon : Boolean);
 196    --  Node is a declaration node that has aspect specifications (Has_Aspects
 197    --  flag set True). It outputs the aspect specifications. For the case
 198    --  of Semicolon = True, it is called after outputting the terminating
 199    --  semicolon for the related node. The effect is to remove the semicolon
 200    --  and print the aspect specifications followed by a terminating semicolon.
 201    --  For the case of Semicolon False, no semicolon is removed or output, and
 202    --  all the aspects are printed on a single line.
 203
 204    procedure Sprint_Bar_List (List : List_Id);
 205    --  Print the given list with items separated by vertical bars
 206
 207    procedure Sprint_End_Label
 208      (Node    : Node_Id;
 209       Default : Node_Id);
 210    --  Print the end label for a Handled_Sequence_Of_Statements in a body.
 211    --  If there is no end label, use the defining identifier of the enclosing
 212    --  construct. If the end label is present, treat it as a reference to the
 213    --  defining entity of the construct: this guarantees that it carries the
 214    --  proper sloc information for debugging purposes.
 215
 216    procedure Sprint_Node_Actual (Node : Node_Id);
 217    --  This routine prints its node argument. It is a lower level routine than
 218    --  Sprint_Node, in that it does not bother about rewritten trees.
 219
 220    procedure Sprint_Node_Sloc (Node : Node_Id);
 221    --  Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
 222    --  sets the Sloc of the current debug node to be a copy of the Sloc
 223    --  of the sprinted node Node. Note that this is done after printing
 224    --  Node, so that the Sloc is the proper updated value for the debug file.
 225
 226    procedure Update_Itype (Node : Node_Id);
 227    --  Update the Sloc of an itype that is not attached to the tree, when
 228    --  debugging expanded code. This routine is called from nodes whose
 229    --  type can be an Itype, such as defining_identifiers that may be of
 230    --  an anonymous access type, or ranges in slices.
 231
 232    procedure Write_Char_Sloc (C : Character);
 233    --  Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
 234    --  called to ensure that the current node has a proper Sloc set.
 235
 236    procedure Write_Condition_And_Reason (Node : Node_Id);
 237    --  Write Condition and Reason codes of Raise_xxx_Error node
 238
 239    procedure Write_Corresponding_Source (S : String);
 240    --  If S is a string with a single keyword (possibly followed by a space),
 241    --  and if the next non-comment non-blank source line matches this keyword,
 242    --  then output all source lines up to this matching line.
 243
 244    procedure Write_Discr_Specs (N : Node_Id);
 245    --  Output discriminant specification for node, which is any of the type
 246    --  declarations that can have discriminants.
 247
 248    procedure Write_Ekind (E : Entity_Id);
 249    --  Write the String corresponding to the Ekind without "E_"
 250
 251    procedure Write_Id (N : Node_Id);
 252    --  N is a node with a Chars field. This procedure writes the name that
 253    --  will be used in the generated code associated with the name. For a
 254    --  node with no associated entity, this is simply the Chars field. For
 255    --  the case where there is an entity associated with the node, we print
 256    --  the name associated with the entity (since it may have been encoded).
 257    --  One other special case is that an entity has an active external name
 258    --  (i.e. an external name present with no address clause), then this
 259    --  external name is output. This procedure also deals with outputting
 260    --  declarations of referenced itypes, if not output earlier.
 261
 262    function Write_Identifiers (Node : Node_Id) return Boolean;
 263    --  Handle node where the grammar has a list of defining identifiers, but
 264    --  the tree has a separate declaration for each identifier. Handles the
 265    --  printing of the defining identifier, and returns True if the type and
 266    --  initialization information is to be printed, False if it is to be
 267    --  skipped (the latter case happens when printing defining identifiers
 268    --  other than the first in the original tree output case).
 269
 270    procedure Write_Implicit_Def (E : Entity_Id);
 271    pragma Warnings (Off, Write_Implicit_Def);
 272    --  Write the definition of the implicit type E according to its Ekind
 273    --  For now a debugging procedure, but might be used in the future.
 274
 275    procedure Write_Indent;
 276    --  Start a new line and write indentation spacing
 277
 278    function Write_Indent_Identifiers (Node : Node_Id) return Boolean;
 279    --  Like Write_Identifiers except that each new printed declaration
 280    --  is at the start of a new line.
 281
 282    function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean;
 283    --  Like Write_Indent_Identifiers except that in Debug_Generated_Code
 284    --  mode, the Sloc of the current debug node is set to point to the
 285    --  first output identifier.
 286
 287    procedure Write_Indent_Str (S : String);
 288    --  Start a new line and write indent spacing followed by given string
 289
 290    procedure Write_Indent_Str_Sloc (S : String);
 291    --  Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
 292    --  the Sloc of the current node is set to the first non-blank character
 293    --  in the string S.
 294
 295    procedure Write_Itype (Typ : Entity_Id);
 296    --  If Typ is an Itype that has not been written yet, write it. If Typ is
 297    --  any other kind of entity or tree node, the call is ignored.
 298
 299    procedure Write_Name_With_Col_Check (N : Name_Id);
 300    --  Write name (using Write_Name) with initial column check, and possible
 301    --  initial Write_Indent (to get new line) if current line is too full.
 302
 303    procedure Write_Name_With_Col_Check_Sloc (N : Name_Id);
 304    --  Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
 305    --  mode, sets Sloc of current debug node to first character of name.
 306
 307    procedure Write_Operator (N : Node_Id; S : String);
 308    --  Like Write_Str_Sloc, used for operators, encloses the string in
 309    --  characters {} if the Do_Overflow flag is set on the node N.
 310
 311    procedure Write_Param_Specs (N : Node_Id);
 312    --  Output parameter specifications for node N (which is a subprogram, or
 313    --  entry or entry family or access-subprogram-definition, all of which
 314    --  have a Parameter_Specificatioons field).
 315
 316    procedure Write_Rewrite_Str (S : String);
 317    --  Writes out a string (typically containing <<< or >>>}) for a node
 318    --  created by rewriting the tree. Suppressed if we are outputting the
 319    --  generated code only, since in this case we don't specially mark nodes
 320    --  created by rewriting).
 321
 322    procedure Write_Source_Line (L : Physical_Line_Number);
 323    --  If writing of interspersed source lines is enabled, then write the given
 324    --  line from the source file, preceded by Eol, then an extra blank line if
 325    --  the line has at least one blank, is not a comment and is not line one,
 326    --  then "--" and the line number followed by period followed by text of the
 327    --  source line (without terminating Eol). If interspersed source line
 328    --  output not enabled, then the call has no effect.
 329
 330    procedure Write_Source_Lines (L : Physical_Line_Number);
 331    --  If writing of interspersed source lines is enabled, then writes source
 332    --  lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
 333    --  interspersed source line output not enabled, then call has no effect.
 334
 335    procedure Write_Str_Sloc (S : String);
 336    --  Like Write_Str, but sets debug Sloc of current debug node to first
 337    --  non-blank character if a current debug node is active.
 338
 339    procedure Write_Str_With_Col_Check (S : String);
 340    --  Write string (using Write_Str) with initial column check, and possible
 341    --  initial Write_Indent (to get new line) if current line is too full.
 342
 343    procedure Write_Str_With_Col_Check_Sloc (S : String);
 344    --  Like Write_Str_With_Col_Check, but sets debug Sloc of current debug
 345    --  node to first non-blank character if a current debug node is active.
 346
 347    procedure Write_Subprogram_Name (N : Node_Id);
 348    --  N is the Name field of a function call or procedure statement call.
 349    --  The effect of the call is to output the name, preceded by a $ if the
 350    --  call is identified as an implicit call to a run time routine.
 351
 352    procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format);
 353    --  Write Uint (using UI_Write) with initial column check, and possible
 354    --  initial Write_Indent (to get new line) if current line is too full.
 355    --  The format parameter determines the output format (see UI_Write).
 356
 357    procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
 358    --  Write Uint (using UI_Write) with initial column check, and possible
 359    --  initial Write_Indent (to get new line) if current line is too full.
 360    --  The format parameter determines the output format (see UI_Write).
 361    --  In addition, in Debug_Generated_Code mode, sets the current node
 362    --  Sloc to the first character of the output value.
 363
 364    procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal);
 365    --  Write Ureal (using same output format as UR_Write) with column checks
 366    --  and a possible initial Write_Indent (to get new line) if current line
 367    --  is too full. In addition, in Debug_Generated_Code mode, sets the
 368    --  current node Sloc to the first character of the output value.
 369
 370    ---------------
 371    -- Col_Check --
 372    ---------------
 373
 374    procedure Col_Check (N : Nat) is
 375    begin
 376       if N + Column > Sprint_Line_Limit then
 377          Write_Indent_Str ("  ");
 378       end if;
 379    end Col_Check;
 380
 381    ----------------------
 382    -- Extra_Blank_Line --
 383    ----------------------
 384
 385    procedure Extra_Blank_Line is
 386    begin
 387       if not Dump_Source_Text then
 388          Write_Indent;
 389       end if;
 390    end Extra_Blank_Line;
 391
 392    -------------------
 393    -- Indent_Annull --
 394    -------------------
 395
 396    procedure Indent_Annull is
 397    begin
 398       Indent_Annull_Flag := True;
 399    end Indent_Annull;
 400
 401    ------------------
 402    -- Indent_Begin --
 403    ------------------
 404
 405    procedure Indent_Begin is
 406    begin
 407       Indent := Indent + 3;
 408    end Indent_Begin;
 409
 410    ----------------
 411    -- Indent_End --
 412    ----------------
 413
 414    procedure Indent_End is
 415    begin
 416       Indent := Indent - 3;
 417    end Indent_End;
 418
 419    --------
 420    -- pg --
 421    --------
 422
 423    procedure pg (Arg : Union_Id) is
 424    begin
 425       Dump_Generated_Only := True;
 426       Dump_Original_Only  := False;
 427       Dump_Freeze_Null    := True;
 428       Current_Source_File := No_Source_File;
 429
 430       if Arg in List_Range then
 431          Sprint_Node_List (List_Id (Arg), New_Lines => True);
 432
 433       elsif Arg in Node_Range then
 434          Sprint_Node (Node_Id (Arg));
 435
 436       else
 437          null;
 438       end if;
 439
 440       Write_Eol;
 441    end pg;
 442
 443    --------
 444    -- po --
 445    --------
 446
 447    procedure po (Arg : Union_Id) is
 448    begin
 449       Dump_Generated_Only := False;
 450       Dump_Original_Only := True;
 451       Current_Source_File := No_Source_File;
 452
 453       if Arg in List_Range then
 454          Sprint_Node_List (List_Id (Arg), New_Lines => True);
 455
 456       elsif Arg in Node_Range then
 457          Sprint_Node (Node_Id (Arg));
 458
 459       else
 460          null;
 461       end if;
 462
 463       Write_Eol;
 464    end po;
 465
 466    ----------------------
 467    -- Print_Debug_Line --
 468    ----------------------
 469
 470    procedure Print_Debug_Line (S : String) is
 471    begin
 472       Write_Debug_Line (S, Debug_Sloc);
 473    end Print_Debug_Line;
 474
 475    ---------------------------
 476    -- Process_TFAI_RR_Flags --
 477    ---------------------------
 478
 479    procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
 480    begin
 481       if Treat_Fixed_As_Integer (Nod) then
 482          Write_Char ('#');
 483       end if;
 484
 485       if Rounded_Result (Nod) then
 486          Write_Char ('@');
 487       end if;
 488    end Process_TFAI_RR_Flags;
 489
 490    --------
 491    -- ps --
 492    --------
 493
 494    procedure ps (Arg : Union_Id) is
 495    begin
 496       Dump_Generated_Only := False;
 497       Dump_Original_Only := False;
 498       Current_Source_File := No_Source_File;
 499
 500       if Arg in List_Range then
 501          Sprint_Node_List (List_Id (Arg), New_Lines => True);
 502
 503       elsif Arg in Node_Range then
 504          Sprint_Node (Node_Id (Arg));
 505
 506       else
 507          null;
 508       end if;
 509
 510       Write_Eol;
 511    end ps;
 512
 513    --------------------
 514    -- Set_Debug_Sloc --
 515    --------------------
 516
 517    procedure Set_Debug_Sloc is
 518    begin
 519       if Debug_Generated_Code and then Present (Dump_Node) then
 520          declare
 521             Loc : constant Source_Ptr := Sloc (Dump_Node);
 522
 523          begin
 524             --  Do not change the location of nodes defined in package Standard
 525             --  and nodes of pragmas scanned by Targparm.
 526
 527             if Loc <= Standard_Location then
 528                null;
 529
 530             --  Update the location of a node which is part of the current .dg
 531             --  output. This situation occurs in comma separated parameter
 532             --  declarations since each parameter references the same parameter
 533             --  type node (ie. obj1, obj2 : <param-type>).
 534
 535             --  Note: This case is needed here since we cannot use the routine
 536             --  In_Extended_Main_Code_Unit with nodes whose location is a .dg
 537             --  file.
 538
 539             elsif Loc >= First_Debug_Sloc then
 540                Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
 541
 542             --  Do not change the location of nodes which are not part of the
 543             --  generated code
 544
 545             elsif not In_Extended_Main_Code_Unit (Loc) then
 546                null;
 547
 548             else
 549                Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
 550             end if;
 551          end;
 552
 553          --  We do not know the actual end location in the generated code and
 554          --  it could be much closer than in the source code, so play safe.
 555
 556          if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then
 557             Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
 558          end if;
 559
 560          Dump_Node := Empty;
 561       end if;
 562    end Set_Debug_Sloc;
 563
 564    -----------------
 565    -- Source_Dump --
 566    -----------------
 567
 568    procedure Source_Dump is
 569
 570       procedure Underline;
 571       --  Put underline under string we just printed
 572
 573       ---------------
 574       -- Underline --
 575       ---------------
 576
 577       procedure Underline is
 578          Col : constant Int := Column;
 579
 580       begin
 581          Write_Eol;
 582
 583          while Col > Column loop
 584             Write_Char ('-');
 585          end loop;
 586
 587          Write_Eol;
 588       end Underline;
 589
 590    --  Start of processing for Source_Dump
 591
 592    begin
 593       Dump_Generated_Only := Debug_Flag_G or
 594                              Print_Generated_Code or
 595                              Debug_Generated_Code;
 596       Dump_Original_Only  := Debug_Flag_O;
 597       Dump_Freeze_Null    := Debug_Flag_S or Debug_Flag_G;
 598
 599       --  Note that we turn off the tree dump flags immediately, before
 600       --  starting the dump. This avoids generating two copies of the dump
 601       --  if an abort occurs after printing the dump, and more importantly,
 602       --  avoids an infinite loop if an abort occurs during the dump.
 603
 604       if Debug_Flag_Z then
 605          Current_Source_File := No_Source_File;
 606          Debug_Flag_Z := False;
 607          Write_Eol;
 608          Write_Eol;
 609          Write_Str ("Source recreated from tree of Standard (spec)");
 610          Underline;
 611          Sprint_Node (Standard_Package_Node);
 612          Write_Eol;
 613          Write_Eol;
 614       end if;
 615
 616       if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
 617          Debug_Flag_G := False;
 618          Debug_Flag_O := False;
 619          Debug_Flag_S := False;
 620          First_Debug_Sloc := No_Location;
 621
 622          --  Dump requested units
 623
 624          for U in Main_Unit .. Last_Unit loop
 625             Current_Source_File := Source_Index (U);
 626
 627             --  Dump all units if -gnatdf set, otherwise we dump only
 628             --  the source files that are in the extended main source.
 629
 630             if Debug_Flag_F
 631               or else In_Extended_Main_Source_Unit (Cunit_Entity (U))
 632             then
 633                --  If we are generating debug files, setup to write them
 634
 635                if Debug_Generated_Code then
 636                   Set_Special_Output (Print_Debug_Line'Access);
 637                   Create_Debug_Source (Source_Index (U), Debug_Sloc);
 638                   First_Debug_Sloc := Debug_Sloc;
 639                   Write_Source_Line (1);
 640                   Last_Line_Printed := 1;
 641                   Sprint_Node (Cunit (U));
 642                   Write_Source_Lines (Last_Source_Line (Current_Source_File));
 643                   Write_Eol;
 644                   Close_Debug_Source;
 645                   Set_Special_Output (null);
 646
 647                --  Normal output to standard output file
 648
 649                else
 650                   Write_Str ("Source recreated from tree for ");
 651                   Write_Unit_Name (Unit_Name (U));
 652                   Underline;
 653                   Write_Source_Line (1);
 654                   Last_Line_Printed := 1;
 655                   Sprint_Node (Cunit (U));
 656                   Write_Source_Lines (Last_Source_Line (Current_Source_File));
 657                   Write_Eol;
 658                   Write_Eol;
 659                end if;
 660             end if;
 661          end loop;
 662       end if;
 663    end Source_Dump;
 664
 665    ---------------------
 666    -- Sprint_And_List --
 667    ---------------------
 668
 669    procedure Sprint_And_List (List : List_Id) is
 670       Node : Node_Id;
 671    begin
 672       if Is_Non_Empty_List (List) then
 673          Node := First (List);
 674          loop
 675             Sprint_Node (Node);
 676             Next (Node);
 677             exit when Node = Empty;
 678             Write_Str (" and ");
 679          end loop;
 680       end if;
 681    end Sprint_And_List;
 682
 683    ----------------------------------
 684    -- Sprint_Aspect_Specifications --
 685    ----------------------------------
 686
 687    procedure Sprint_Aspect_Specifications
 688      (Node      : Node_Id;
 689       Semicolon : Boolean)
 690    is
 691       AS : constant List_Id := Aspect_Specifications (Node);
 692       A  : Node_Id;
 693
 694    begin
 695       if Semicolon then
 696          Write_Erase_Char (';');
 697          Indent := Indent + 2;
 698          Write_Indent;
 699          Write_Str ("with ");
 700          Indent := Indent + 5;
 701
 702       else
 703          Write_Str (" with ");
 704       end if;
 705
 706       A := First (AS);
 707       loop
 708          Sprint_Node (Identifier (A));
 709
 710          if Class_Present (A) then
 711             Write_Str ("'Class");
 712          end if;
 713
 714          if Present (Expression (A)) then
 715             Write_Str (" => ");
 716             Sprint_Node (Expression (A));
 717          end if;
 718
 719          Next (A);
 720
 721          exit when No (A);
 722          Write_Char (',');
 723
 724          if Semicolon then
 725             Write_Indent;
 726          end if;
 727       end loop;
 728
 729       if Semicolon then
 730          Indent := Indent - 7;
 731          Write_Char (';');
 732       end if;
 733    end Sprint_Aspect_Specifications;
 734
 735    ---------------------
 736    -- Sprint_Bar_List --
 737    ---------------------
 738
 739    procedure Sprint_Bar_List (List : List_Id) is
 740       Node : Node_Id;
 741    begin
 742       if Is_Non_Empty_List (List) then
 743          Node := First (List);
 744          loop
 745             Sprint_Node (Node);
 746             Next (Node);
 747             exit when Node = Empty;
 748             Write_Str (" | ");
 749          end loop;
 750       end if;
 751    end Sprint_Bar_List;
 752
 753    ----------------------
 754    -- Sprint_End_Label --
 755    ----------------------
 756
 757    procedure Sprint_End_Label
 758      (Node    : Node_Id;
 759       Default : Node_Id)
 760    is
 761    begin
 762       if Present (Node)
 763         and then Present (End_Label (Node))
 764         and then Is_Entity_Name (End_Label (Node))
 765       then
 766          Set_Entity (End_Label (Node), Default);
 767
 768          --  For a function whose name is an operator, use the qualified name
 769          --  created for the defining entity.
 770
 771          if Nkind (End_Label (Node)) = N_Operator_Symbol then
 772             Set_Chars (End_Label (Node), Chars (Default));
 773          end if;
 774
 775          Sprint_Node (End_Label (Node));
 776       else
 777          Sprint_Node (Default);
 778       end if;
 779    end Sprint_End_Label;
 780
 781    -----------------------
 782    -- Sprint_Comma_List --
 783    -----------------------
 784
 785    procedure Sprint_Comma_List (List : List_Id) is
 786       Node : Node_Id;
 787
 788    begin
 789       if Is_Non_Empty_List (List) then
 790          Node := First (List);
 791          loop
 792             Sprint_Node (Node);
 793             Next (Node);
 794             exit when Node = Empty;
 795
 796             if not Is_Rewrite_Insertion (Node)
 797               or else not Dump_Original_Only
 798             then
 799                Write_Str (", ");
 800             end if;
 801          end loop;
 802       end if;
 803    end Sprint_Comma_List;
 804
 805    --------------------------
 806    -- Sprint_Indented_List --
 807    --------------------------
 808
 809    procedure Sprint_Indented_List (List : List_Id) is
 810    begin
 811       Indent_Begin;
 812       Sprint_Node_List (List);
 813       Indent_End;
 814    end Sprint_Indented_List;
 815
 816    ---------------------
 817    -- Sprint_Left_Opnd --
 818    ---------------------
 819
 820    procedure Sprint_Left_Opnd (N : Node_Id) is
 821       Opnd : constant Node_Id := Left_Opnd (N);
 822
 823    begin
 824       if Paren_Count (Opnd) /= 0
 825         or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N))
 826       then
 827          Sprint_Node (Opnd);
 828
 829       else
 830          Write_Char ('(');
 831          Sprint_Node (Opnd);
 832          Write_Char (')');
 833       end if;
 834    end Sprint_Left_Opnd;
 835
 836    -----------------
 837    -- Sprint_Node --
 838    -----------------
 839
 840    procedure Sprint_Node (Node : Node_Id) is
 841    begin
 842       if Is_Rewrite_Insertion (Node) then
 843          if not Dump_Original_Only then
 844
 845             --  For special cases of nodes that always output <<< >>>
 846             --  do not duplicate the output at this point.
 847
 848             if Nkind (Node) = N_Freeze_Entity
 849               or else Nkind (Node) = N_Freeze_Generic_Entity
 850               or else Nkind (Node) = N_Implicit_Label_Declaration
 851             then
 852                Sprint_Node_Actual (Node);
 853
 854             --  Normal case where <<< >>> may be required
 855
 856             else
 857                Write_Rewrite_Str ("<<<");
 858                Sprint_Node_Actual (Node);
 859                Write_Rewrite_Str (">>>");
 860             end if;
 861          end if;
 862
 863       elsif Is_Rewrite_Substitution (Node) then
 864
 865          --  Case of dump generated only
 866
 867          if Dump_Generated_Only then
 868             Sprint_Node_Actual (Node);
 869
 870          --  Case of dump original only
 871
 872          elsif Dump_Original_Only then
 873             Sprint_Node_Actual (Original_Node (Node));
 874
 875          --  Case of both being dumped
 876
 877          else
 878             Sprint_Node_Actual (Original_Node (Node));
 879             Write_Rewrite_Str ("<<<");
 880             Sprint_Node_Actual (Node);
 881             Write_Rewrite_Str (">>>");
 882          end if;
 883
 884       else
 885          Sprint_Node_Actual (Node);
 886       end if;
 887    end Sprint_Node;
 888
 889    ------------------------
 890    -- Sprint_Node_Actual --
 891    ------------------------
 892
 893    procedure Sprint_Node_Actual (Node : Node_Id) is
 894       Save_Dump_Node : constant Node_Id := Dump_Node;
 895
 896    begin
 897       if Node = Empty then
 898          return;
 899       end if;
 900
 901       for J in 1 .. Paren_Count (Node) loop
 902          Write_Str_With_Col_Check ("(");
 903       end loop;
 904
 905       --  Setup current dump node
 906
 907       Dump_Node := Node;
 908
 909       if Nkind (Node) in N_Subexpr
 910         and then Do_Range_Check (Node)
 911       then
 912          Write_Str_With_Col_Check ("{");
 913       end if;
 914
 915       --  Select print circuit based on node kind
 916
 917       case Nkind (Node) is
 918          when N_Abort_Statement =>
 919             Write_Indent_Str_Sloc ("abort ");
 920             Sprint_Comma_List (Names (Node));
 921             Write_Char (';');
 922
 923          when N_Abortable_Part =>
 924             Set_Debug_Sloc;
 925             Write_Str_Sloc ("abort ");
 926             Sprint_Indented_List (Statements (Node));
 927
 928          when N_Abstract_Subprogram_Declaration =>
 929             Write_Indent;
 930             Sprint_Node (Specification (Node));
 931             Write_Str_With_Col_Check (" is ");
 932             Write_Str_Sloc ("abstract;");
 933
 934          when N_Accept_Alternative =>
 935             Sprint_Node_List (Pragmas_Before (Node));
 936
 937             if Present (Condition (Node)) then
 938                Write_Indent_Str ("when ");
 939                Sprint_Node (Condition (Node));
 940                Write_Str (" => ");
 941                Indent_Annull;
 942             end if;
 943
 944             Sprint_Node_Sloc (Accept_Statement (Node));
 945             Sprint_Node_List (Statements (Node));
 946
 947          when N_Accept_Statement =>
 948             Write_Indent_Str_Sloc ("accept ");
 949             Write_Id (Entry_Direct_Name (Node));
 950
 951             if Present (Entry_Index (Node)) then
 952                Write_Str_With_Col_Check (" (");
 953                Sprint_Node (Entry_Index (Node));
 954                Write_Char (')');
 955             end if;
 956
 957             Write_Param_Specs (Node);
 958
 959             if Present (Handled_Statement_Sequence (Node)) then
 960                Write_Str_With_Col_Check (" do");
 961                Sprint_Node (Handled_Statement_Sequence (Node));
 962                Write_Indent_Str ("end ");
 963                Write_Id (Entry_Direct_Name (Node));
 964             end if;
 965
 966             Write_Char (';');
 967
 968          when N_Access_Definition =>
 969
 970             --  Ada 2005 (AI-254)
 971
 972             if Present (Access_To_Subprogram_Definition (Node)) then
 973                Sprint_Node (Access_To_Subprogram_Definition (Node));
 974             else
 975                --  Ada 2005 (AI-231)
 976
 977                if Null_Exclusion_Present (Node) then
 978                   Write_Str ("not null ");
 979                end if;
 980
 981                Write_Str_With_Col_Check_Sloc ("access ");
 982
 983                if All_Present (Node) then
 984                   Write_Str ("all ");
 985                elsif Constant_Present (Node) then
 986                   Write_Str ("constant ");
 987                end if;
 988
 989                Sprint_Node (Subtype_Mark (Node));
 990             end if;
 991
 992          when N_Access_Function_Definition =>
 993
 994             --  Ada 2005 (AI-231)
 995
 996             if Null_Exclusion_Present (Node) then
 997                Write_Str ("not null ");
 998             end if;
 999
1000             Write_Str_With_Col_Check_Sloc ("access ");
1001
1002             if Protected_Present (Node) then
1003                Write_Str_With_Col_Check ("protected ");
1004             end if;
1005
1006             Write_Str_With_Col_Check ("function");
1007             Write_Param_Specs (Node);
1008             Write_Str_With_Col_Check (" return ");
1009             Sprint_Node (Result_Definition (Node));
1010
1011          when N_Access_Procedure_Definition =>
1012
1013             --  Ada 2005 (AI-231)
1014
1015             if Null_Exclusion_Present (Node) then
1016                Write_Str ("not null ");
1017             end if;
1018
1019             Write_Str_With_Col_Check_Sloc ("access ");
1020
1021             if Protected_Present (Node) then
1022                Write_Str_With_Col_Check ("protected ");
1023             end if;
1024
1025             Write_Str_With_Col_Check ("procedure");
1026             Write_Param_Specs (Node);
1027
1028          when N_Access_To_Object_Definition =>
1029             Write_Str_With_Col_Check_Sloc ("access ");
1030
1031             if All_Present (Node) then
1032                Write_Str_With_Col_Check ("all ");
1033             elsif Constant_Present (Node) then
1034                Write_Str_With_Col_Check ("constant ");
1035             end if;
1036
1037             --  Ada 2005 (AI-231)
1038
1039             if Null_Exclusion_Present (Node) then
1040                Write_Str ("not null ");
1041             end if;
1042
1043             Sprint_Node (Subtype_Indication (Node));
1044
1045          when N_Aggregate =>
1046             if Null_Record_Present (Node) then
1047                Write_Str_With_Col_Check_Sloc ("(null record)");
1048
1049             else
1050                Write_Str_With_Col_Check_Sloc ("(");
1051
1052                if Present (Expressions (Node)) then
1053                   Sprint_Comma_List (Expressions (Node));
1054
1055                   if Present (Component_Associations (Node))
1056                     and then not Is_Empty_List (Component_Associations (Node))
1057                   then
1058                      Write_Str (", ");
1059                   end if;
1060                end if;
1061
1062                if Present (Component_Associations (Node))
1063                  and then not Is_Empty_List (Component_Associations (Node))
1064                then
1065                   Indent_Begin;
1066
1067                   declare
1068                      Nd : Node_Id;
1069
1070                   begin
1071                      Nd := First (Component_Associations (Node));
1072
1073                      loop
1074                         Write_Indent;
1075                         Sprint_Node (Nd);
1076                         Next (Nd);
1077                         exit when No (Nd);
1078
1079                         if not Is_Rewrite_Insertion (Nd)
1080                           or else not Dump_Original_Only
1081                         then
1082                            Write_Str (", ");
1083                         end if;
1084                      end loop;
1085                   end;
1086
1087                   Indent_End;
1088                end if;
1089
1090                Write_Char (')');
1091             end if;
1092
1093          when N_Allocator =>
1094             Write_Str_With_Col_Check_Sloc ("new ");
1095
1096             --  Ada 2005 (AI-231)
1097
1098             if Null_Exclusion_Present (Node) then
1099                Write_Str ("not null ");
1100             end if;
1101
1102             Sprint_Node (Expression (Node));
1103
1104             if Present (Storage_Pool (Node)) then
1105                Write_Str_With_Col_Check ("[storage_pool = ");
1106                Sprint_Node (Storage_Pool (Node));
1107                Write_Char (']');
1108             end if;
1109
1110          when N_And_Then =>
1111             Sprint_Left_Opnd (Node);
1112             Write_Str_Sloc (" and then ");
1113             Sprint_Right_Opnd (Node);
1114
1115          --  Note: the following code for N_Aspect_Specification is not
1116          --  normally used, since we deal with aspects as part of a
1117          --  declaration, but it is here in case we deliberately try
1118          --  to print an N_Aspect_Speficiation node (e.g. from GDB).
1119
1120          when N_Aspect_Specification =>
1121             Sprint_Node (Identifier (Node));
1122             Write_Str (" => ");
1123             Sprint_Node (Expression (Node));
1124
1125          when N_Assignment_Statement =>
1126             Write_Indent;
1127             Sprint_Node (Name (Node));
1128             Write_Str_Sloc (" := ");
1129             Sprint_Node (Expression (Node));
1130             Write_Char (';');
1131
1132          when N_Asynchronous_Select =>
1133             Write_Indent_Str_Sloc ("select");
1134             Indent_Begin;
1135             Sprint_Node (Triggering_Alternative (Node));
1136             Indent_End;
1137
1138             --  Note: let the printing of Abortable_Part handle outputting
1139             --  the ABORT keyword, so that the Sloc can be set correctly.
1140
1141             Write_Indent_Str ("then ");
1142             Sprint_Node (Abortable_Part (Node));
1143             Write_Indent_Str ("end select;");
1144
1145          when N_At_Clause =>
1146             Write_Indent_Str_Sloc ("for ");
1147             Write_Id (Identifier (Node));
1148             Write_Str_With_Col_Check (" use at ");
1149             Sprint_Node (Expression (Node));
1150             Write_Char (';');
1151
1152          when N_Attribute_Definition_Clause =>
1153             Write_Indent_Str_Sloc ("for ");
1154             Sprint_Node (Name (Node));
1155             Write_Char (''');
1156             Write_Name_With_Col_Check (Chars (Node));
1157             Write_Str_With_Col_Check (" use ");
1158             Sprint_Node (Expression (Node));
1159             Write_Char (';');
1160
1161          when N_Attribute_Reference =>
1162             if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
1163                Write_Indent;
1164             end if;
1165
1166             Sprint_Node (Prefix (Node));
1167             Write_Char_Sloc (''');
1168             Write_Name_With_Col_Check (Attribute_Name (Node));
1169             Sprint_Paren_Comma_List (Expressions (Node));
1170
1171             if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
1172                Write_Char (';');
1173             end if;
1174
1175          when N_Block_Statement =>
1176             Write_Indent;
1177
1178             if Present (Identifier (Node))
1179               and then (not Has_Created_Identifier (Node)
1180                          or else not Dump_Original_Only)
1181             then
1182                Write_Rewrite_Str ("<<<");
1183                Write_Id (Identifier (Node));
1184                Write_Str (" : ");
1185                Write_Rewrite_Str (">>>");
1186             end if;
1187
1188             if Present (Declarations (Node)) then
1189                Write_Str_With_Col_Check_Sloc ("declare");
1190                Sprint_Indented_List (Declarations (Node));
1191                Write_Indent;
1192             end if;
1193
1194             Write_Str_With_Col_Check_Sloc ("begin");
1195             Sprint_Node (Handled_Statement_Sequence (Node));
1196             Write_Indent_Str ("end");
1197
1198             if Present (Identifier (Node))
1199               and then (not Has_Created_Identifier (Node)
1200                           or else not Dump_Original_Only)
1201             then
1202                Write_Rewrite_Str ("<<<");
1203                Write_Char (' ');
1204                Write_Id (Identifier (Node));
1205                Write_Rewrite_Str (">>>");
1206             end if;
1207
1208             Write_Char (';');
1209
1210          when N_Case_Expression =>
1211             declare
1212                Has_Parens : constant Boolean := Paren_Count (Node) > 0;
1213                Alt        : Node_Id;
1214
1215             begin
1216                --  The syntax for case_expression does not include parentheses,
1217                --  but sometimes parentheses are required, so unconditionally
1218                --  generate them here unless already present.
1219
1220                if not Has_Parens then
1221                   Write_Char ('(');
1222                end if;
1223
1224                Write_Str_With_Col_Check_Sloc ("case ");
1225                Sprint_Node (Expression (Node));
1226                Write_Str_With_Col_Check (" is");
1227
1228                Alt := First (Alternatives (Node));
1229                loop
1230                   Sprint_Node (Alt);
1231                   Next (Alt);
1232                   exit when No (Alt);
1233                   Write_Char (',');
1234                end loop;
1235
1236                if not Has_Parens then
1237                   Write_Char (')');
1238                end if;
1239             end;
1240
1241          when N_Case_Expression_Alternative =>
1242             Write_Str_With_Col_Check (" when ");
1243             Sprint_Bar_List (Discrete_Choices (Node));
1244             Write_Str (" => ");
1245             Sprint_Node (Expression (Node));
1246
1247          when N_Case_Statement =>
1248             Write_Indent_Str_Sloc ("case ");
1249             Sprint_Node (Expression (Node));
1250             Write_Str (" is");
1251             Sprint_Indented_List (Alternatives (Node));
1252             Write_Indent_Str ("end case;");
1253
1254          when N_Case_Statement_Alternative =>
1255             Write_Indent_Str_Sloc ("when ");
1256             Sprint_Bar_List (Discrete_Choices (Node));
1257             Write_Str (" => ");
1258             Sprint_Indented_List (Statements (Node));
1259
1260          when N_Character_Literal =>
1261             if Column > Sprint_Line_Limit - 2 then
1262                Write_Indent_Str ("  ");
1263             end if;
1264
1265             Write_Char_Sloc (''');
1266             Write_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
1267             Write_Char (''');
1268
1269          when N_Code_Statement =>
1270             Write_Indent;
1271             Set_Debug_Sloc;
1272             Sprint_Node (Expression (Node));
1273             Write_Char (';');
1274
1275          when N_Compilation_Unit =>
1276             Sprint_Node_List (Context_Items (Node));
1277             Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
1278
1279             if Private_Present (Node) then
1280                Write_Indent_Str ("private ");
1281                Indent_Annull;
1282             end if;
1283
1284             Sprint_Node_Sloc (Unit (Node));
1285
1286             if Present (Actions (Aux_Decls_Node (Node)))
1287                  or else
1288                Present (Pragmas_After (Aux_Decls_Node (Node)))
1289             then
1290                Write_Indent;
1291             end if;
1292
1293             Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
1294             Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
1295
1296          when N_Compilation_Unit_Aux =>
1297             null; -- nothing to do, never used, see above
1298
1299          when N_Component_Association =>
1300             Set_Debug_Sloc;
1301             Sprint_Bar_List (Choices (Node));
1302             Write_Str (" => ");
1303
1304             --  Ada 2005 (AI-287): Print the box if present
1305
1306             if Box_Present (Node) then
1307                Write_Str_With_Col_Check ("<>");
1308             else
1309                Sprint_Node (Expression (Node));
1310             end if;
1311
1312          when N_Component_Clause =>
1313             Write_Indent;
1314             Sprint_Node (Component_Name (Node));
1315             Write_Str_Sloc (" at ");
1316             Sprint_Node (Position (Node));
1317             Write_Char (' ');
1318             Write_Str_With_Col_Check ("range ");
1319             Sprint_Node (First_Bit (Node));
1320             Write_Str (" .. ");
1321             Sprint_Node (Last_Bit (Node));
1322             Write_Char (';');
1323
1324          when N_Component_Definition =>
1325             Set_Debug_Sloc;
1326
1327             --  Ada 2005 (AI-230): Access definition components
1328
1329             if Present (Access_Definition (Node)) then
1330                Sprint_Node (Access_Definition (Node));
1331
1332             elsif Present (Subtype_Indication (Node)) then
1333                if Aliased_Present (Node) then
1334                   Write_Str_With_Col_Check ("aliased ");
1335                end if;
1336
1337                --  Ada 2005 (AI-231)
1338
1339                if Null_Exclusion_Present (Node) then
1340                   Write_Str (" not null ");
1341                end if;
1342
1343                Sprint_Node (Subtype_Indication (Node));
1344
1345             else
1346                Write_Str (" ??? ");
1347             end if;
1348
1349          when N_Component_Declaration =>
1350             if Write_Indent_Identifiers_Sloc (Node) then
1351                Write_Str (" : ");
1352                Sprint_Node (Component_Definition (Node));
1353
1354                if Present (Expression (Node)) then
1355                   Write_Str (" := ");
1356                   Sprint_Node (Expression (Node));
1357                end if;
1358
1359                Write_Char (';');
1360             end if;
1361
1362          when N_Component_List =>
1363             if Null_Present (Node) then
1364                Indent_Begin;
1365                Write_Indent_Str_Sloc ("null");
1366                Write_Char (';');
1367                Indent_End;
1368
1369             else
1370                Set_Debug_Sloc;
1371                Sprint_Indented_List (Component_Items (Node));
1372                Sprint_Node (Variant_Part (Node));
1373             end if;
1374
1375          when N_Compound_Statement =>
1376             Write_Indent_Str ("do");
1377             Indent_Begin;
1378             Sprint_Node_List (Actions (Node));
1379             Indent_End;
1380             Write_Indent_Str ("end;");
1381
1382          when N_Conditional_Entry_Call =>
1383             Write_Indent_Str_Sloc ("select");
1384             Indent_Begin;
1385             Sprint_Node (Entry_Call_Alternative (Node));
1386             Indent_End;
1387             Write_Indent_Str ("else");
1388             Sprint_Indented_List (Else_Statements (Node));
1389             Write_Indent_Str ("end select;");
1390
1391          when N_Constrained_Array_Definition =>
1392             Write_Str_With_Col_Check_Sloc ("array ");
1393             Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
1394             Write_Str (" of ");
1395
1396             Sprint_Node (Component_Definition (Node));
1397
1398          --  A contract node should not appear in the tree. It is a semantic
1399          --  node attached to entry and [generic] subprogram entities. But we
1400          --  still provide meaningful output, in case called from the debugger.
1401
1402          when N_Contract =>
1403             declare
1404                P : Node_Id;
1405
1406             begin
1407                Indent_Begin;
1408                Write_Str ("N_Contract node");
1409                Write_Eol;
1410
1411                Write_Indent_Str ("Pre_Post_Conditions");
1412                Indent_Begin;
1413
1414                P := Pre_Post_Conditions (Node);
1415                while Present (P) loop
1416                   Sprint_Node (P);
1417                   P := Next_Pragma (P);
1418                end loop;
1419
1420                Write_Eol;
1421                Indent_End;
1422
1423                Write_Indent_Str ("Contract_Test_Cases");
1424                Indent_Begin;
1425
1426                P := Contract_Test_Cases (Node);
1427                while Present (P) loop
1428                   Sprint_Node (P);
1429                   P := Next_Pragma (P);
1430                end loop;
1431
1432                Write_Eol;
1433                Indent_End;
1434
1435                Write_Indent_Str ("Classifications");
1436                Indent_Begin;
1437
1438                P := Classifications (Node);
1439                while Present (P) loop
1440                   Sprint_Node (P);
1441                   P := Next_Pragma (P);
1442                end loop;
1443
1444                Write_Eol;
1445                Indent_End;
1446                Indent_End;
1447             end;
1448
1449          when N_Decimal_Fixed_Point_Definition =>
1450             Write_Str_With_Col_Check_Sloc (" delta ");
1451             Sprint_Node (Delta_Expression (Node));
1452             Write_Str_With_Col_Check ("digits ");
1453             Sprint_Node (Digits_Expression (Node));
1454             Sprint_Opt_Node (Real_Range_Specification (Node));
1455
1456          when N_Defining_Character_Literal =>
1457             Write_Name_With_Col_Check_Sloc (Chars (Node));
1458
1459          when N_Defining_Identifier =>
1460             Set_Debug_Sloc;
1461             Write_Id (Node);
1462
1463          when N_Defining_Operator_Symbol =>
1464             Write_Name_With_Col_Check_Sloc (Chars (Node));
1465
1466          when N_Defining_Program_Unit_Name =>
1467             Set_Debug_Sloc;
1468             Sprint_Node (Name (Node));
1469             Write_Char ('.');
1470             Write_Id (Defining_Identifier (Node));
1471
1472          when N_Delay_Alternative =>
1473             Sprint_Node_List (Pragmas_Before (Node));
1474
1475             if Present (Condition (Node)) then
1476                Write_Indent;
1477                Write_Str_With_Col_Check ("when ");
1478                Sprint_Node (Condition (Node));
1479                Write_Str (" => ");
1480                Indent_Annull;
1481             end if;
1482
1483             Sprint_Node_Sloc (Delay_Statement (Node));
1484             Sprint_Node_List (Statements (Node));
1485
1486          when N_Delay_Relative_Statement =>
1487             Write_Indent_Str_Sloc ("delay ");
1488             Sprint_Node (Expression (Node));
1489             Write_Char (';');
1490
1491          when N_Delay_Until_Statement =>
1492             Write_Indent_Str_Sloc ("delay until ");
1493             Sprint_Node (Expression (Node));
1494             Write_Char (';');
1495
1496          when N_Delta_Constraint =>
1497             Write_Str_With_Col_Check_Sloc ("delta ");
1498             Sprint_Node (Delta_Expression (Node));
1499             Sprint_Opt_Node (Range_Constraint (Node));
1500
1501          when N_Derived_Type_Definition =>
1502             if Abstract_Present (Node) then
1503                Write_Str_With_Col_Check ("abstract ");
1504             end if;
1505
1506             Write_Str_With_Col_Check ("new ");
1507
1508             --  Ada 2005 (AI-231)
1509
1510             if Null_Exclusion_Present (Node) then
1511                Write_Str_With_Col_Check ("not null ");
1512             end if;
1513
1514             Sprint_Node (Subtype_Indication (Node));
1515
1516             if Present (Interface_List (Node)) then
1517                Write_Str_With_Col_Check (" and ");
1518                Sprint_And_List (Interface_List (Node));
1519                Write_Str_With_Col_Check (" with ");
1520             end if;
1521
1522             if Present (Record_Extension_Part (Node)) then
1523                if No (Interface_List (Node)) then
1524                   Write_Str_With_Col_Check (" with ");
1525                end if;
1526
1527                Sprint_Node (Record_Extension_Part (Node));
1528             end if;
1529
1530          when N_Designator =>
1531             Sprint_Node (Name (Node));
1532             Write_Char_Sloc ('.');
1533             Write_Id (Identifier (Node));
1534
1535          when N_Digits_Constraint =>
1536             Write_Str_With_Col_Check_Sloc ("digits ");
1537             Sprint_Node (Digits_Expression (Node));
1538             Sprint_Opt_Node (Range_Constraint (Node));
1539
1540          when N_Discriminant_Association =>
1541             Set_Debug_Sloc;
1542
1543             if Present (Selector_Names (Node)) then
1544                Sprint_Bar_List (Selector_Names (Node));
1545                Write_Str (" => ");
1546             end if;
1547
1548             Set_Debug_Sloc;
1549             Sprint_Node (Expression (Node));
1550
1551          when N_Discriminant_Specification =>
1552             Set_Debug_Sloc;
1553
1554             if Write_Identifiers (Node) then
1555                Write_Str (" : ");
1556
1557                if Null_Exclusion_Present (Node) then
1558                   Write_Str ("not null ");
1559                end if;
1560
1561                Sprint_Node (Discriminant_Type (Node));
1562
1563                if Present (Expression (Node)) then
1564                   Write_Str (" := ");
1565                   Sprint_Node (Expression (Node));
1566                end if;
1567             else
1568                Write_Str (", ");
1569             end if;
1570
1571          when N_Elsif_Part =>
1572             Write_Indent_Str_Sloc ("elsif ");
1573             Sprint_Node (Condition (Node));
1574             Write_Str_With_Col_Check (" then");
1575             Sprint_Indented_List (Then_Statements (Node));
1576
1577          when N_Empty =>
1578             null;
1579
1580          when N_Entry_Body =>
1581             Write_Indent_Str_Sloc ("entry ");
1582             Write_Id (Defining_Identifier (Node));
1583             Sprint_Node (Entry_Body_Formal_Part (Node));
1584             Write_Str_With_Col_Check (" is");
1585             Sprint_Indented_List (Declarations (Node));
1586             Write_Indent_Str ("begin");
1587             Sprint_Node (Handled_Statement_Sequence (Node));
1588             Write_Indent_Str ("end ");
1589             Write_Id (Defining_Identifier (Node));
1590             Write_Char (';');
1591
1592          when N_Entry_Body_Formal_Part =>
1593             if Present (Entry_Index_Specification (Node)) then
1594                Write_Str_With_Col_Check_Sloc (" (");
1595                Sprint_Node (Entry_Index_Specification (Node));
1596                Write_Char (')');
1597             end if;
1598
1599             Write_Param_Specs (Node);
1600             Write_Str_With_Col_Check_Sloc (" when ");
1601             Sprint_Node (Condition (Node));
1602
1603          when N_Entry_Call_Alternative =>
1604             Sprint_Node_List (Pragmas_Before (Node));
1605             Sprint_Node_Sloc (Entry_Call_Statement (Node));
1606             Sprint_Node_List (Statements (Node));
1607
1608          when N_Entry_Call_Statement =>
1609             Write_Indent;
1610             Sprint_Node_Sloc (Name (Node));
1611             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1612             Write_Char (';');
1613
1614          when N_Entry_Declaration =>
1615             Write_Indent_Str_Sloc ("entry ");
1616             Write_Id (Defining_Identifier (Node));
1617
1618             if Present (Discrete_Subtype_Definition (Node)) then
1619                Write_Str_With_Col_Check (" (");
1620                Sprint_Node (Discrete_Subtype_Definition (Node));
1621                Write_Char (')');
1622             end if;
1623
1624             Write_Param_Specs (Node);
1625             Write_Char (';');
1626
1627          when N_Entry_Index_Specification =>
1628             Write_Str_With_Col_Check_Sloc ("for ");
1629             Write_Id (Defining_Identifier (Node));
1630             Write_Str_With_Col_Check (" in ");
1631             Sprint_Node (Discrete_Subtype_Definition (Node));
1632
1633          when N_Enumeration_Representation_Clause =>
1634             Write_Indent_Str_Sloc ("for ");
1635             Write_Id (Identifier (Node));
1636             Write_Str_With_Col_Check (" use ");
1637             Sprint_Node (Array_Aggregate (Node));
1638             Write_Char (';');
1639
1640          when N_Enumeration_Type_Definition =>
1641             Set_Debug_Sloc;
1642
1643             --  Skip attempt to print Literals field if it's not there and
1644             --  we are in package Standard (case of Character, which is
1645             --  handled specially (without an explicit literals list).
1646
1647             if Sloc (Node) > Standard_Location
1648               or else Present (Literals (Node))
1649             then
1650                Sprint_Paren_Comma_List (Literals (Node));
1651             end if;
1652
1653          when N_Error =>
1654             Write_Str_With_Col_Check_Sloc ("<error>");
1655
1656          when N_Exception_Declaration =>
1657             if Write_Indent_Identifiers (Node) then
1658                Write_Str_With_Col_Check (" : ");
1659
1660                if Is_Statically_Allocated (Defining_Identifier (Node)) then
1661                   Write_Str_With_Col_Check ("static ");
1662                end if;
1663
1664                Write_Str_Sloc ("exception");
1665
1666                if Present (Expression (Node)) then
1667                   Write_Str (" := ");
1668                   Sprint_Node (Expression (Node));
1669                end if;
1670
1671                Write_Char (';');
1672             end if;
1673
1674          when N_Exception_Handler =>
1675             Write_Indent_Str_Sloc ("when ");
1676
1677             if Present (Choice_Parameter (Node)) then
1678                Sprint_Node (Choice_Parameter (Node));
1679                Write_Str (" : ");
1680             end if;
1681
1682             Sprint_Bar_List (Exception_Choices (Node));
1683             Write_Str (" => ");
1684             Sprint_Indented_List (Statements (Node));
1685
1686          when N_Exception_Renaming_Declaration =>
1687             Write_Indent;
1688             Set_Debug_Sloc;
1689             Sprint_Node (Defining_Identifier (Node));
1690             Write_Str_With_Col_Check (" : exception renames ");
1691             Sprint_Node (Name (Node));
1692             Write_Char (';');
1693
1694          when N_Exit_Statement =>
1695             Write_Indent_Str_Sloc ("exit");
1696             Sprint_Opt_Node (Name (Node));
1697
1698             if Present (Condition (Node)) then
1699                Write_Str_With_Col_Check (" when ");
1700                Sprint_Node (Condition (Node));
1701             end if;
1702
1703             Write_Char (';');
1704
1705          when N_Expanded_Name =>
1706             Sprint_Node (Prefix (Node));
1707             Write_Char_Sloc ('.');
1708             Sprint_Node (Selector_Name (Node));
1709
1710          when N_Explicit_Dereference =>
1711             Sprint_Node (Prefix (Node));
1712             Write_Char_Sloc ('.');
1713             Write_Str_Sloc ("all");
1714
1715          when N_Expression_With_Actions =>
1716             Indent_Begin;
1717             Write_Indent_Str_Sloc ("do ");
1718             Indent_Begin;
1719             Sprint_Node_List (Actions (Node));
1720             Indent_End;
1721             Write_Indent;
1722             Write_Str_With_Col_Check_Sloc ("in ");
1723             Sprint_Node (Expression (Node));
1724             Write_Str_With_Col_Check (" end");
1725             Indent_End;
1726             Write_Indent;
1727
1728          when N_Expression_Function =>
1729             Write_Indent;
1730             Sprint_Node_Sloc (Specification (Node));
1731             Write_Str (" is");
1732             Indent_Begin;
1733             Write_Indent;
1734             Sprint_Node (Expression (Node));
1735             Write_Char (';');
1736             Indent_End;
1737
1738          when N_Extended_Return_Statement =>
1739             Write_Indent_Str_Sloc ("return ");
1740             Sprint_Node_List (Return_Object_Declarations (Node));
1741
1742             if Present (Handled_Statement_Sequence (Node)) then
1743                Write_Str_With_Col_Check (" do");
1744                Sprint_Node (Handled_Statement_Sequence (Node));
1745                Write_Indent_Str ("end return;");
1746             else
1747                Write_Indent_Str (";");
1748             end if;
1749
1750          when N_Extension_Aggregate =>
1751             Write_Str_With_Col_Check_Sloc ("(");
1752             Sprint_Node (Ancestor_Part (Node));
1753             Write_Str_With_Col_Check (" with ");
1754
1755             if Null_Record_Present (Node) then
1756                Write_Str_With_Col_Check ("null record");
1757             else
1758                if Present (Expressions (Node)) then
1759                   Sprint_Comma_List (Expressions (Node));
1760
1761                   if Present (Component_Associations (Node)) then
1762                      Write_Str (", ");
1763                   end if;
1764                end if;
1765
1766                if Present (Component_Associations (Node)) then
1767                   Sprint_Comma_List (Component_Associations (Node));
1768                end if;
1769             end if;
1770
1771             Write_Char (')');
1772
1773          when N_Floating_Point_Definition =>
1774             Write_Str_With_Col_Check_Sloc ("digits ");
1775             Sprint_Node (Digits_Expression (Node));
1776             Sprint_Opt_Node (Real_Range_Specification (Node));
1777
1778          when N_Formal_Decimal_Fixed_Point_Definition =>
1779             Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
1780
1781          when N_Formal_Derived_Type_Definition =>
1782             Write_Str_With_Col_Check_Sloc ("new ");
1783             Sprint_Node (Subtype_Mark (Node));
1784
1785             if Present (Interface_List (Node)) then
1786                Write_Str_With_Col_Check (" and ");
1787                Sprint_And_List (Interface_List (Node));
1788             end if;
1789
1790             if Private_Present (Node) then
1791                Write_Str_With_Col_Check (" with private");
1792             end if;
1793
1794          when N_Formal_Abstract_Subprogram_Declaration =>
1795             Write_Indent_Str_Sloc ("with ");
1796             Sprint_Node (Specification (Node));
1797
1798             Write_Str_With_Col_Check (" is abstract");
1799
1800             if Box_Present (Node) then
1801                Write_Str_With_Col_Check (" <>");
1802             elsif Present (Default_Name (Node)) then
1803                Write_Str_With_Col_Check (" ");
1804                Sprint_Node (Default_Name (Node));
1805             end if;
1806
1807             Write_Char (';');
1808
1809          when N_Formal_Concrete_Subprogram_Declaration =>
1810             Write_Indent_Str_Sloc ("with ");
1811             Sprint_Node (Specification (Node));
1812
1813             if Box_Present (Node) then
1814                Write_Str_With_Col_Check (" is <>");
1815             elsif Present (Default_Name (Node)) then
1816                Write_Str_With_Col_Check (" is ");
1817                Sprint_Node (Default_Name (Node));
1818             end if;
1819
1820             Write_Char (';');
1821
1822          when N_Formal_Discrete_Type_Definition =>
1823             Write_Str_With_Col_Check_Sloc ("<>");
1824
1825          when N_Formal_Floating_Point_Definition =>
1826             Write_Str_With_Col_Check_Sloc ("digits <>");
1827
1828          when N_Formal_Modular_Type_Definition =>
1829             Write_Str_With_Col_Check_Sloc ("mod <>");
1830
1831          when N_Formal_Object_Declaration =>
1832             Set_Debug_Sloc;
1833
1834             if Write_Indent_Identifiers (Node) then
1835                Write_Str (" : ");
1836
1837                if In_Present (Node) then
1838                   Write_Str_With_Col_Check ("in ");
1839                end if;
1840
1841                if Out_Present (Node) then
1842                   Write_Str_With_Col_Check ("out ");
1843                end if;
1844
1845                if Present (Subtype_Mark (Node)) then
1846
1847                   --  Ada 2005 (AI-423): Formal object with null exclusion
1848
1849                   if Null_Exclusion_Present (Node) then
1850                      Write_Str ("not null ");
1851                   end if;
1852
1853                   Sprint_Node (Subtype_Mark (Node));
1854
1855                --  Ada 2005 (AI-423): Formal object with access definition
1856
1857                else
1858                   pragma Assert (Present (Access_Definition (Node)));
1859
1860                   Sprint_Node (Access_Definition (Node));
1861                end if;
1862
1863                if Present (Default_Expression (Node)) then
1864                   Write_Str (" := ");
1865                   Sprint_Node (Default_Expression (Node));
1866                end if;
1867
1868                Write_Char (';');
1869             end if;
1870
1871          when N_Formal_Ordinary_Fixed_Point_Definition =>
1872             Write_Str_With_Col_Check_Sloc ("delta <>");
1873
1874          when N_Formal_Package_Declaration =>
1875             Write_Indent_Str_Sloc ("with package ");
1876             Write_Id (Defining_Identifier (Node));
1877             Write_Str_With_Col_Check (" is new ");
1878             Sprint_Node (Name (Node));
1879             Write_Str_With_Col_Check (" (<>);");
1880
1881          when N_Formal_Private_Type_Definition =>
1882             if Abstract_Present (Node) then
1883                Write_Str_With_Col_Check ("abstract ");
1884             end if;
1885
1886             if Tagged_Present (Node) then
1887                Write_Str_With_Col_Check ("tagged ");
1888             end if;
1889
1890             if Limited_Present (Node) then
1891                Write_Str_With_Col_Check ("limited ");
1892             end if;
1893
1894             Write_Str_With_Col_Check_Sloc ("private");
1895
1896          when N_Formal_Incomplete_Type_Definition =>
1897             if Tagged_Present (Node) then
1898                Write_Str_With_Col_Check ("is tagged ");
1899             end if;
1900
1901          when N_Formal_Signed_Integer_Type_Definition =>
1902             Write_Str_With_Col_Check_Sloc ("range <>");
1903
1904          when N_Formal_Type_Declaration =>
1905             Write_Indent_Str_Sloc ("type ");
1906             Write_Id (Defining_Identifier (Node));
1907
1908             if Present (Discriminant_Specifications (Node)) then
1909                Write_Discr_Specs (Node);
1910             elsif Unknown_Discriminants_Present (Node) then
1911                Write_Str_With_Col_Check ("(<>)");
1912             end if;
1913
1914             if Nkind (Formal_Type_Definition (Node)) /=
1915                 N_Formal_Incomplete_Type_Definition
1916             then
1917                Write_Str_With_Col_Check (" is ");
1918             end if;
1919
1920             Sprint_Node (Formal_Type_Definition (Node));
1921             Write_Char (';');
1922
1923          when N_Free_Statement =>
1924             Write_Indent_Str_Sloc ("free ");
1925             Sprint_Node (Expression (Node));
1926             Write_Char (';');
1927
1928          when N_Freeze_Entity =>
1929             if Dump_Original_Only then
1930                null;
1931
1932             --  A freeze node is output if it has some effect (i.e. non-empty
1933             --  actions, or freeze node for an itype, which causes elaboration
1934             --  of the itype), and is also always output if Dump_Freeze_Null
1935             --  is set True.
1936
1937             elsif Present (Actions (Node))
1938               or else Is_Itype (Entity (Node))
1939               or else Dump_Freeze_Null
1940             then
1941                Write_Indent;
1942                Write_Rewrite_Str ("<<<");
1943                Write_Str_With_Col_Check_Sloc ("freeze ");
1944                Write_Id (Entity (Node));
1945                Write_Str (" [");
1946
1947                if No (Actions (Node)) then
1948                   Write_Char (']');
1949
1950                else
1951                   --  Output freeze actions. We increment Freeze_Indent during
1952                   --  this output to avoid generating extra blank lines before
1953                   --  any procedures included in the freeze actions.
1954
1955                   Freeze_Indent := Freeze_Indent + 1;
1956                   Sprint_Indented_List (Actions (Node));
1957                   Freeze_Indent := Freeze_Indent - 1;
1958                   Write_Indent_Str ("]");
1959                end if;
1960
1961                Write_Rewrite_Str (">>>");
1962             end if;
1963
1964          when N_Freeze_Generic_Entity =>
1965             if Dump_Original_Only then
1966                null;
1967
1968             else
1969                Write_Indent;
1970                Write_Str_With_Col_Check_Sloc ("freeze_generic ");
1971                Write_Id (Entity (Node));
1972             end if;
1973
1974          when N_Full_Type_Declaration =>
1975             Write_Indent_Str_Sloc ("type ");
1976             Sprint_Node (Defining_Identifier (Node));
1977             Write_Discr_Specs (Node);
1978             Write_Str_With_Col_Check (" is ");
1979             Sprint_Node (Type_Definition (Node));
1980             Write_Char (';');
1981
1982          when N_Function_Call =>
1983             Set_Debug_Sloc;
1984             Write_Subprogram_Name (Name (Node));
1985             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1986
1987          when N_Function_Instantiation =>
1988             Write_Indent_Str_Sloc ("function ");
1989             Sprint_Node (Defining_Unit_Name (Node));
1990             Write_Str_With_Col_Check (" is new ");
1991             Sprint_Node (Name (Node));
1992             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
1993             Write_Char (';');
1994
1995          when N_Function_Specification =>
1996             Write_Str_With_Col_Check_Sloc ("function ");
1997             Sprint_Node (Defining_Unit_Name (Node));
1998             Write_Param_Specs (Node);
1999             Write_Str_With_Col_Check (" return ");
2000
2001             --  Ada 2005 (AI-231)
2002
2003             if Nkind (Result_Definition (Node)) /= N_Access_Definition
2004               and then Null_Exclusion_Present (Node)
2005             then
2006                Write_Str (" not null ");
2007             end if;
2008
2009             Sprint_Node (Result_Definition (Node));
2010
2011          when N_Generic_Association =>
2012             Set_Debug_Sloc;
2013
2014             if Present (Selector_Name (Node)) then
2015                Sprint_Node (Selector_Name (Node));
2016                Write_Str (" => ");
2017             end if;
2018
2019             Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
2020
2021          when N_Generic_Function_Renaming_Declaration =>
2022             Write_Indent_Str_Sloc ("generic function ");
2023             Sprint_Node (Defining_Unit_Name (Node));
2024             Write_Str_With_Col_Check (" renames ");
2025             Sprint_Node (Name (Node));
2026             Write_Char (';');
2027
2028          when N_Generic_Package_Declaration =>
2029             Extra_Blank_Line;
2030             Write_Indent_Str_Sloc ("generic ");
2031             Sprint_Indented_List (Generic_Formal_Declarations (Node));
2032             Write_Indent;
2033             Sprint_Node (Specification (Node));
2034             Write_Char (';');
2035
2036          when N_Generic_Package_Renaming_Declaration =>
2037             Write_Indent_Str_Sloc ("generic package ");
2038             Sprint_Node (Defining_Unit_Name (Node));
2039             Write_Str_With_Col_Check (" renames ");
2040             Sprint_Node (Name (Node));
2041             Write_Char (';');
2042
2043          when N_Generic_Procedure_Renaming_Declaration =>
2044             Write_Indent_Str_Sloc ("generic procedure ");
2045             Sprint_Node (Defining_Unit_Name (Node));
2046             Write_Str_With_Col_Check (" renames ");
2047             Sprint_Node (Name (Node));
2048             Write_Char (';');
2049
2050          when N_Generic_Subprogram_Declaration =>
2051             Extra_Blank_Line;
2052             Write_Indent_Str_Sloc ("generic ");
2053             Sprint_Indented_List (Generic_Formal_Declarations (Node));
2054             Write_Indent;
2055             Sprint_Node (Specification (Node));
2056             Write_Char (';');
2057
2058          when N_Goto_Statement =>
2059             Write_Indent_Str_Sloc ("goto ");
2060             Sprint_Node (Name (Node));
2061             Write_Char (';');
2062
2063             if Nkind (Next (Node)) = N_Label then
2064                Write_Indent;
2065             end if;
2066
2067          when N_Handled_Sequence_Of_Statements =>
2068             Set_Debug_Sloc;
2069             Sprint_Indented_List (Statements (Node));
2070
2071             if Present (Exception_Handlers (Node)) then
2072                Write_Indent_Str ("exception");
2073                Indent_Begin;
2074                Sprint_Node_List (Exception_Handlers (Node));
2075                Indent_End;
2076             end if;
2077
2078             if Present (At_End_Proc (Node)) then
2079                Write_Indent_Str ("at end");
2080                Indent_Begin;
2081                Write_Indent;
2082                Sprint_Node (At_End_Proc (Node));
2083                Write_Char (';');
2084                Indent_End;
2085             end if;
2086
2087          when N_Identifier =>
2088             Set_Debug_Sloc;
2089             Write_Id (Node);
2090
2091          when N_If_Expression =>
2092             declare
2093                Has_Parens : constant Boolean := Paren_Count (Node) > 0;
2094                Condition  : constant Node_Id := First (Expressions (Node));
2095                Then_Expr  : constant Node_Id := Next (Condition);
2096
2097             begin
2098                --  The syntax for if_expression does not include parentheses,
2099                --  but sometimes parentheses are required, so unconditionally
2100                --  generate them here unless already present.
2101
2102                if not Has_Parens then
2103                   Write_Char ('(');
2104                end if;
2105
2106                Write_Str_With_Col_Check_Sloc ("if ");
2107                Sprint_Node (Condition);
2108                Write_Str_With_Col_Check (" then ");
2109
2110                --  Defense against junk here
2111
2112                if Present (Then_Expr) then
2113                   Sprint_Node (Then_Expr);
2114
2115                   if Present (Next (Then_Expr)) then
2116                      Write_Str_With_Col_Check (" else ");
2117                      Sprint_Node (Next (Then_Expr));
2118                   end if;
2119                end if;
2120
2121                if not Has_Parens then
2122                   Write_Char (')');
2123                end if;
2124             end;
2125
2126          when N_If_Statement =>
2127             Write_Indent_Str_Sloc ("if ");
2128             Sprint_Node (Condition (Node));
2129             Write_Str_With_Col_Check (" then");
2130             Sprint_Indented_List (Then_Statements (Node));
2131             Sprint_Opt_Node_List (Elsif_Parts (Node));
2132
2133             if Present (Else_Statements (Node)) then
2134                Write_Indent_Str ("else");
2135                Sprint_Indented_List (Else_Statements (Node));
2136             end if;
2137
2138             Write_Indent_Str ("end if;");
2139
2140          when N_Implicit_Label_Declaration =>
2141             if not Dump_Original_Only then
2142                Write_Indent;
2143                Write_Rewrite_Str ("<<<");
2144                Set_Debug_Sloc;
2145                Write_Id (Defining_Identifier (Node));
2146                Write_Str (" : ");
2147                Write_Str_With_Col_Check ("label");
2148                Write_Rewrite_Str (">>>");
2149             end if;
2150
2151          when N_In =>
2152             Sprint_Left_Opnd (Node);
2153             Write_Str_Sloc (" in ");
2154
2155             if Present (Right_Opnd (Node)) then
2156                Sprint_Right_Opnd (Node);
2157             else
2158                Sprint_Bar_List (Alternatives (Node));
2159             end if;
2160
2161          when N_Incomplete_Type_Declaration =>
2162             Write_Indent_Str_Sloc ("type ");
2163             Write_Id (Defining_Identifier (Node));
2164
2165             if Present (Discriminant_Specifications (Node)) then
2166                Write_Discr_Specs (Node);
2167             elsif Unknown_Discriminants_Present (Node) then
2168                Write_Str_With_Col_Check ("(<>)");
2169             end if;
2170
2171             Write_Char (';');
2172
2173          when N_Index_Or_Discriminant_Constraint =>
2174             Set_Debug_Sloc;
2175             Sprint_Paren_Comma_List (Constraints (Node));
2176
2177          when N_Indexed_Component =>
2178             Sprint_Node_Sloc (Prefix (Node));
2179             Sprint_Opt_Paren_Comma_List (Expressions (Node));
2180
2181          when N_Integer_Literal =>
2182             if Print_In_Hex (Node) then
2183                Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
2184             else
2185                Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
2186             end if;
2187
2188          when N_Iteration_Scheme =>
2189             if Present (Condition (Node)) then
2190                Write_Str_With_Col_Check_Sloc ("while ");
2191                Sprint_Node (Condition (Node));
2192             else
2193                Write_Str_With_Col_Check_Sloc ("for ");
2194
2195                if Present (Iterator_Specification (Node)) then
2196                   Sprint_Node (Iterator_Specification (Node));
2197                else
2198                   Sprint_Node (Loop_Parameter_Specification (Node));
2199                end if;
2200             end if;
2201
2202             Write_Char (' ');
2203
2204          when N_Iterator_Specification =>
2205             Set_Debug_Sloc;
2206             Write_Id (Defining_Identifier (Node));
2207
2208             if Present (Subtype_Indication (Node)) then
2209                Write_Str_With_Col_Check (" : ");
2210                Sprint_Node (Subtype_Indication (Node));
2211             end if;
2212
2213             if Of_Present (Node) then
2214                Write_Str_With_Col_Check (" of ");
2215             else
2216                Write_Str_With_Col_Check (" in ");
2217             end if;
2218
2219             if Reverse_Present (Node) then
2220                Write_Str_With_Col_Check ("reverse ");
2221             end if;
2222
2223             Sprint_Node (Name (Node));
2224
2225          when N_Itype_Reference =>
2226             Write_Indent_Str_Sloc ("reference ");
2227             Write_Id (Itype (Node));
2228
2229          when N_Label =>
2230             Write_Indent_Str_Sloc ("<<");
2231             Write_Id (Identifier (Node));
2232             Write_Str (">>");
2233
2234          when N_Loop_Parameter_Specification =>
2235             Set_Debug_Sloc;
2236             Write_Id (Defining_Identifier (Node));
2237             Write_Str_With_Col_Check (" in ");
2238
2239             if Reverse_Present (Node) then
2240                Write_Str_With_Col_Check ("reverse ");
2241             end if;
2242
2243             Sprint_Node (Discrete_Subtype_Definition (Node));
2244
2245          when N_Loop_Statement =>
2246             Write_Indent;
2247
2248             if Present (Identifier (Node))
2249               and then (not Has_Created_Identifier (Node)
2250                           or else not Dump_Original_Only)
2251             then
2252                Write_Rewrite_Str ("<<<");
2253                Write_Id (Identifier (Node));
2254                Write_Str (" : ");
2255                Write_Rewrite_Str (">>>");
2256                Sprint_Node (Iteration_Scheme (Node));
2257                Write_Str_With_Col_Check_Sloc ("loop");
2258                Sprint_Indented_List (Statements (Node));
2259                Write_Indent_Str ("end loop ");
2260                Write_Rewrite_Str ("<<<");
2261                Write_Id (Identifier (Node));
2262                Write_Rewrite_Str (">>>");
2263                Write_Char (';');
2264
2265             else
2266                Sprint_Node (Iteration_Scheme (Node));
2267                Write_Str_With_Col_Check_Sloc ("loop");
2268                Sprint_Indented_List (Statements (Node));
2269                Write_Indent_Str ("end loop;");
2270             end if;
2271
2272          when N_Mod_Clause =>
2273             Sprint_Node_List (Pragmas_Before (Node));
2274             Write_Str_With_Col_Check_Sloc ("at mod ");
2275             Sprint_Node (Expression (Node));
2276
2277          when N_Modular_Type_Definition =>
2278             Write_Str_With_Col_Check_Sloc ("mod ");
2279             Sprint_Node (Expression (Node));
2280
2281          when N_Not_In =>
2282             Sprint_Left_Opnd (Node);
2283             Write_Str_Sloc (" not in ");
2284
2285             if Present (Right_Opnd (Node)) then
2286                Sprint_Right_Opnd (Node);
2287             else
2288                Sprint_Bar_List (Alternatives (Node));
2289             end if;
2290
2291          when N_Null =>
2292             Write_Str_With_Col_Check_Sloc ("null");
2293
2294          when N_Null_Statement =>
2295             if Comes_From_Source (Node)
2296               or else Dump_Freeze_Null
2297               or else not Is_List_Member (Node)
2298               or else (No (Prev (Node)) and then No (Next (Node)))
2299             then
2300                Write_Indent_Str_Sloc ("null;");
2301             end if;
2302
2303          when N_Number_Declaration =>
2304             Set_Debug_Sloc;
2305
2306             if Write_Indent_Identifiers (Node) then
2307                Write_Str_With_Col_Check (" : constant ");
2308                Write_Str (" := ");
2309                Sprint_Node (Expression (Node));
2310                Write_Char (';');
2311             end if;
2312
2313          when N_Object_Declaration =>
2314             Set_Debug_Sloc;
2315
2316             if Write_Indent_Identifiers (Node) then
2317                declare
2318                   Def_Id : constant Entity_Id := Defining_Identifier (Node);
2319
2320                begin
2321                   Write_Str_With_Col_Check (" : ");
2322
2323                   if Is_Statically_Allocated (Def_Id) then
2324                      Write_Str_With_Col_Check ("static ");
2325                   end if;
2326
2327                   if Aliased_Present (Node) then
2328                      Write_Str_With_Col_Check ("aliased ");
2329                   end if;
2330
2331                   if Constant_Present (Node) then
2332                      Write_Str_With_Col_Check ("constant ");
2333                   end if;
2334
2335                   --  Ada 2005 (AI-231)
2336
2337                   if Null_Exclusion_Present (Node) then
2338                      Write_Str_With_Col_Check ("not null ");
2339                   end if;
2340
2341                   --  Print type. We used to print the Object_Definition from
2342                   --  the node, but it is much more useful to print the Etype
2343                   --  of the defining identifier for the case where the nominal
2344                   --  type is an unconstrained array type. For example, this
2345                   --  will be a clear reference to the Itype with the bounds
2346                   --  in the case of a type like String. The object after
2347                   --  all is constrained, even if its nominal subtype is
2348                   --  unconstrained.
2349
2350                   declare
2351                      Odef : constant Node_Id := Object_Definition (Node);
2352
2353                   begin
2354                      if Nkind (Odef) = N_Identifier
2355                        and then Present (Etype (Odef))
2356                        and then Is_Array_Type (Etype (Odef))
2357                        and then not Is_Constrained (Etype (Odef))
2358                        and then Present (Etype (Def_Id))
2359                      then
2360                         Sprint_Node (Etype (Def_Id));
2361
2362                      --  In other cases, the nominal type is fine to print
2363
2364                      else
2365                         Sprint_Node (Odef);
2366                      end if;
2367                   end;
2368
2369                   if Present (Expression (Node)) then
2370                      Write_Str (" := ");
2371                      Sprint_Node (Expression (Node));
2372                   end if;
2373
2374                   Write_Char (';');
2375
2376                   --  Handle implicit importation and implicit exportation of
2377                   --  object declarations:
2378                   --    $pragma import (Convention_Id, Def_Id, "...");
2379                   --    $pragma export (Convention_Id, Def_Id, "...");
2380
2381                   if Is_Internal (Def_Id)
2382                     and then Present (Interface_Name (Def_Id))
2383                   then
2384                      Write_Indent_Str_Sloc ("$pragma ");
2385
2386                      if Is_Imported (Def_Id) then
2387                         Write_Str ("import (");
2388
2389                      else pragma Assert (Is_Exported (Def_Id));
2390                         Write_Str ("export (");
2391                      end if;
2392
2393                      declare
2394                         Prefix : constant String  := "Convention_";
2395                         S      : constant String  := Convention (Def_Id)'Img;
2396
2397                      begin
2398                         Name_Len := S'Last - Prefix'Last;
2399                         Name_Buffer (1 .. Name_Len) :=
2400                           S (Prefix'Last + 1 .. S'Last);
2401                         Set_Casing (All_Lower_Case);
2402                         Write_Str (Name_Buffer (1 .. Name_Len));
2403                      end;
2404
2405                      Write_Str (", ");
2406                      Write_Id  (Def_Id);
2407                      Write_Str (", ");
2408                      Write_String_Table_Entry
2409                        (Strval (Interface_Name (Def_Id)));
2410                      Write_Str (");");
2411                   end if;
2412                end;
2413             end if;
2414
2415          when N_Object_Renaming_Declaration =>
2416             Write_Indent;
2417             Set_Debug_Sloc;
2418             Sprint_Node (Defining_Identifier (Node));
2419             Write_Str (" : ");
2420
2421             --  Ada 2005 (AI-230): Access renamings
2422
2423             if Present (Access_Definition (Node)) then
2424                Sprint_Node (Access_Definition (Node));
2425
2426             elsif Present (Subtype_Mark (Node)) then
2427
2428                --  Ada 2005 (AI-423): Object renaming with a null exclusion
2429
2430                if Null_Exclusion_Present (Node) then
2431                   Write_Str ("not null ");
2432                end if;
2433
2434                Sprint_Node (Subtype_Mark (Node));
2435
2436             else
2437                Write_Str (" ??? ");
2438             end if;
2439
2440             Write_Str_With_Col_Check (" renames ");
2441             Sprint_Node (Name (Node));
2442             Write_Char (';');
2443
2444          when N_Op_Abs =>
2445             Write_Operator (Node, "abs ");
2446             Sprint_Right_Opnd (Node);
2447
2448          when N_Op_Add =>
2449             Sprint_Left_Opnd (Node);
2450             Write_Operator (Node, " + ");
2451             Sprint_Right_Opnd (Node);
2452
2453          when N_Op_And =>
2454             Sprint_Left_Opnd (Node);
2455             Write_Operator (Node, " and ");
2456             Sprint_Right_Opnd (Node);
2457
2458          when N_Op_Concat =>
2459             Sprint_Left_Opnd (Node);
2460             Write_Operator (Node, " & ");
2461             Sprint_Right_Opnd (Node);
2462
2463          when N_Op_Divide =>
2464             Sprint_Left_Opnd (Node);
2465             Write_Char (' ');
2466             Process_TFAI_RR_Flags (Node);
2467             Write_Operator (Node, "/ ");
2468             Sprint_Right_Opnd (Node);
2469
2470          when N_Op_Eq =>
2471             Sprint_Left_Opnd (Node);
2472             Write_Operator (Node, " = ");
2473             Sprint_Right_Opnd (Node);
2474
2475          when N_Op_Expon =>
2476             Sprint_Left_Opnd (Node);
2477             Write_Operator (Node, " ** ");
2478             Sprint_Right_Opnd (Node);
2479
2480          when N_Op_Ge =>
2481             Sprint_Left_Opnd (Node);
2482             Write_Operator (Node, " >= ");
2483             Sprint_Right_Opnd (Node);
2484
2485          when N_Op_Gt =>
2486             Sprint_Left_Opnd (Node);
2487             Write_Operator (Node, " > ");
2488             Sprint_Right_Opnd (Node);
2489
2490          when N_Op_Le =>
2491             Sprint_Left_Opnd (Node);
2492             Write_Operator (Node, " <= ");
2493             Sprint_Right_Opnd (Node);
2494
2495          when N_Op_Lt =>
2496             Sprint_Left_Opnd (Node);
2497             Write_Operator (Node, " < ");
2498             Sprint_Right_Opnd (Node);
2499
2500          when N_Op_Minus =>
2501             Write_Operator (Node, "-");
2502             Sprint_Right_Opnd (Node);
2503
2504          when N_Op_Mod =>
2505             Sprint_Left_Opnd (Node);
2506
2507             if Treat_Fixed_As_Integer (Node) then
2508                Write_Str (" #");
2509             end if;
2510
2511             Write_Operator (Node, " mod ");
2512             Sprint_Right_Opnd (Node);
2513
2514          when N_Op_Multiply =>
2515             Sprint_Left_Opnd (Node);
2516             Write_Char (' ');
2517             Process_TFAI_RR_Flags (Node);
2518             Write_Operator (Node, "* ");
2519             Sprint_Right_Opnd (Node);
2520
2521          when N_Op_Ne =>
2522             Sprint_Left_Opnd (Node);
2523             Write_Operator (Node, " /= ");
2524             Sprint_Right_Opnd (Node);
2525
2526          when N_Op_Not =>
2527             Write_Operator (Node, "not ");
2528             Sprint_Right_Opnd (Node);
2529
2530          when N_Op_Or =>
2531             Sprint_Left_Opnd (Node);
2532             Write_Operator (Node, " or ");
2533             Sprint_Right_Opnd (Node);
2534
2535          when N_Op_Plus =>
2536             Write_Operator (Node, "+");
2537             Sprint_Right_Opnd (Node);
2538
2539          when N_Op_Rem =>
2540             Sprint_Left_Opnd (Node);
2541
2542             if Treat_Fixed_As_Integer (Node) then
2543                Write_Str (" #");
2544             end if;
2545
2546             Write_Operator (Node, " rem ");
2547             Sprint_Right_Opnd (Node);
2548
2549          when N_Op_Shift =>
2550             Set_Debug_Sloc;
2551             Write_Id (Node);
2552             Write_Char ('!');
2553             Write_Str_With_Col_Check ("(");
2554             Sprint_Node (Left_Opnd (Node));
2555             Write_Str (", ");
2556             Sprint_Node (Right_Opnd (Node));
2557             Write_Char (')');
2558
2559          when N_Op_Subtract =>
2560             Sprint_Left_Opnd (Node);
2561             Write_Operator (Node, " - ");
2562             Sprint_Right_Opnd (Node);
2563
2564          when N_Op_Xor =>
2565             Sprint_Left_Opnd (Node);
2566             Write_Operator (Node, " xor ");
2567             Sprint_Right_Opnd (Node);
2568
2569          when N_Operator_Symbol =>
2570             Write_Name_With_Col_Check_Sloc (Chars (Node));
2571
2572          when N_Ordinary_Fixed_Point_Definition =>
2573             Write_Str_With_Col_Check_Sloc ("delta ");
2574             Sprint_Node (Delta_Expression (Node));
2575             Sprint_Opt_Node (Real_Range_Specification (Node));
2576
2577          when N_Or_Else =>
2578             Sprint_Left_Opnd (Node);
2579             Write_Str_Sloc (" or else ");
2580             Sprint_Right_Opnd (Node);
2581
2582          when N_Others_Choice =>
2583             if All_Others (Node) then
2584                Write_Str_With_Col_Check ("all ");
2585             end if;
2586
2587             Write_Str_With_Col_Check_Sloc ("others");
2588
2589          when N_Package_Body =>
2590             Extra_Blank_Line;
2591             Write_Indent_Str_Sloc ("package body ");
2592             Sprint_Node (Defining_Unit_Name (Node));
2593             Write_Str (" is");
2594             Sprint_Indented_List (Declarations (Node));
2595
2596             if Present (Handled_Statement_Sequence (Node)) then
2597                Write_Indent_Str ("begin");
2598                Sprint_Node (Handled_Statement_Sequence (Node));
2599             end if;
2600
2601             Write_Indent_Str ("end ");
2602             Sprint_End_Label
2603               (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
2604             Write_Char (';');
2605
2606          when N_Package_Body_Stub =>
2607             Write_Indent_Str_Sloc ("package body ");
2608             Sprint_Node (Defining_Identifier (Node));
2609             Write_Str_With_Col_Check (" is separate;");
2610
2611          when N_Package_Declaration =>
2612             Extra_Blank_Line;
2613             Write_Indent;
2614             Sprint_Node_Sloc (Specification (Node));
2615             Write_Char (';');
2616
2617             --  If this is an instantiation, get the aspects from the original
2618             --  instantiation node.
2619
2620             if Is_Generic_Instance (Defining_Entity (Node))
2621               and then Has_Aspects
2622                          (Package_Instantiation (Defining_Entity (Node)))
2623             then
2624                Sprint_Aspect_Specifications
2625                  (Package_Instantiation (Defining_Entity (Node)),
2626                    Semicolon => True);
2627             end if;
2628
2629          when N_Package_Instantiation =>
2630             Extra_Blank_Line;
2631             Write_Indent_Str_Sloc ("package ");
2632             Sprint_Node (Defining_Unit_Name (Node));
2633             Write_Str (" is new ");
2634             Sprint_Node (Name (Node));
2635             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2636             Write_Char (';');
2637
2638          when N_Package_Renaming_Declaration =>
2639             Write_Indent_Str_Sloc ("package ");
2640             Sprint_Node (Defining_Unit_Name (Node));
2641             Write_Str_With_Col_Check (" renames ");
2642             Sprint_Node (Name (Node));
2643             Write_Char (';');
2644
2645          when N_Package_Specification =>
2646             Write_Str_With_Col_Check_Sloc ("package ");
2647             Sprint_Node (Defining_Unit_Name (Node));
2648
2649             if Nkind (Parent (Node)) = N_Generic_Package_Declaration
2650               and then Has_Aspects (Parent (Node))
2651             then
2652                Sprint_Aspect_Specifications
2653                  (Parent (Node), Semicolon => False);
2654
2655             --  An instantiation is rewritten as a package declaration, but
2656             --  the aspects belong to the instantiation node.
2657
2658             elsif Nkind (Parent (Node)) = N_Package_Declaration then
2659                declare
2660                   Pack : constant Entity_Id := Defining_Entity (Node);
2661
2662                begin
2663                   if not Is_Generic_Instance (Pack) then
2664                      if Has_Aspects (Parent (Node)) then
2665                         Sprint_Aspect_Specifications
2666                           (Parent (Node), Semicolon => False);
2667                      end if;
2668                   end if;
2669                end;
2670             end if;
2671
2672             Write_Str (" is");
2673             Sprint_Indented_List (Visible_Declarations (Node));
2674
2675             if Present (Private_Declarations (Node)) then
2676                Write_Indent_Str ("private");
2677                Sprint_Indented_List (Private_Declarations (Node));
2678             end if;
2679
2680             Write_Indent_Str ("end ");
2681             Sprint_Node (Defining_Unit_Name (Node));
2682
2683          when N_Parameter_Association =>
2684             Sprint_Node_Sloc (Selector_Name (Node));
2685             Write_Str (" => ");
2686             Sprint_Node (Explicit_Actual_Parameter (Node));
2687
2688          when N_Parameter_Specification =>
2689             Set_Debug_Sloc;
2690
2691             if Write_Identifiers (Node) then
2692                Write_Str (" : ");
2693
2694                if In_Present (Node) then
2695                   Write_Str_With_Col_Check ("in ");
2696                end if;
2697
2698                if Out_Present (Node) then
2699                   Write_Str_With_Col_Check ("out ");
2700                end if;
2701
2702                --  Ada 2005 (AI-231): Parameter specification may carry null
2703                --  exclusion. Do not print it now if this is an access formal,
2704                --  it is emitted when the access definition is displayed.
2705
2706                if Null_Exclusion_Present (Node)
2707                  and then Nkind (Parameter_Type (Node)) /= N_Access_Definition
2708                then
2709                   Write_Str ("not null ");
2710                end if;
2711
2712                if Aliased_Present (Node) then
2713                   Write_Str ("aliased ");
2714                end if;
2715
2716                Sprint_Node (Parameter_Type (Node));
2717
2718                if Present (Expression (Node)) then
2719                   Write_Str (" := ");
2720                   Sprint_Node (Expression (Node));
2721                end if;
2722             else
2723                Write_Str (", ");
2724             end if;
2725
2726          when N_Pop_Constraint_Error_Label =>
2727             Write_Indent_Str ("%pop_constraint_error_label");
2728
2729          when N_Pop_Program_Error_Label =>
2730             Write_Indent_Str ("%pop_program_error_label");
2731
2732          when N_Pop_Storage_Error_Label =>
2733             Write_Indent_Str ("%pop_storage_error_label");
2734
2735          when N_Private_Extension_Declaration =>
2736             Write_Indent_Str_Sloc ("type ");
2737             Write_Id (Defining_Identifier (Node));
2738
2739             if Present (Discriminant_Specifications (Node)) then
2740                Write_Discr_Specs (Node);
2741             elsif Unknown_Discriminants_Present (Node) then
2742                Write_Str_With_Col_Check ("(<>)");
2743             end if;
2744
2745             Write_Str_With_Col_Check (" is new ");
2746             Sprint_Node (Subtype_Indication (Node));
2747
2748             if Present (Interface_List (Node)) then
2749                Write_Str_With_Col_Check (" and ");
2750                Sprint_And_List (Interface_List (Node));
2751             end if;
2752
2753             Write_Str_With_Col_Check (" with private;");
2754
2755          when N_Private_Type_Declaration =>
2756             Write_Indent_Str_Sloc ("type ");
2757             Write_Id (Defining_Identifier (Node));
2758
2759             if Present (Discriminant_Specifications (Node)) then
2760                Write_Discr_Specs (Node);
2761             elsif Unknown_Discriminants_Present (Node) then
2762                Write_Str_With_Col_Check ("(<>)");
2763             end if;
2764
2765             Write_Str (" is ");
2766
2767             if Tagged_Present (Node) then
2768                Write_Str_With_Col_Check ("tagged ");
2769             end if;
2770
2771             if Limited_Present (Node) then
2772                Write_Str_With_Col_Check ("limited ");
2773             end if;
2774
2775             Write_Str_With_Col_Check ("private;");
2776
2777          when N_Push_Constraint_Error_Label =>
2778             Write_Indent_Str ("%push_constraint_error_label (");
2779
2780             if Present (Exception_Label (Node)) then
2781                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2782             end if;
2783
2784             Write_Str (")");
2785
2786          when N_Push_Program_Error_Label =>
2787             Write_Indent_Str ("%push_program_error_label (");
2788
2789             if Present (Exception_Label (Node)) then
2790                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2791             end if;
2792
2793             Write_Str (")");
2794
2795          when N_Push_Storage_Error_Label =>
2796             Write_Indent_Str ("%push_storage_error_label (");
2797
2798             if Present (Exception_Label (Node)) then
2799                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2800             end if;
2801
2802             Write_Str (")");
2803
2804          when N_Pragma =>
2805             Write_Indent_Str_Sloc ("pragma ");
2806             Write_Name_With_Col_Check (Pragma_Name (Node));
2807
2808             if Present (Pragma_Argument_Associations (Node)) then
2809                Sprint_Opt_Paren_Comma_List
2810                  (Pragma_Argument_Associations (Node));
2811             end if;
2812
2813             Write_Char (';');
2814
2815          when N_Pragma_Argument_Association =>
2816             Set_Debug_Sloc;
2817
2818             if Chars (Node) /= No_Name then
2819                Write_Name_With_Col_Check (Chars (Node));
2820                Write_Str (" => ");
2821             end if;
2822
2823             Sprint_Node (Expression (Node));
2824
2825          when N_Procedure_Call_Statement =>
2826             Write_Indent;
2827             Set_Debug_Sloc;
2828             Write_Subprogram_Name (Name (Node));
2829             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
2830             Write_Char (';');
2831
2832          when N_Procedure_Instantiation =>
2833             Write_Indent_Str_Sloc ("procedure ");
2834             Sprint_Node (Defining_Unit_Name (Node));
2835             Write_Str_With_Col_Check (" is new ");
2836             Sprint_Node (Name (Node));
2837             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2838             Write_Char (';');
2839
2840          when N_Procedure_Specification =>
2841             Write_Str_With_Col_Check_Sloc ("procedure ");
2842             Sprint_Node (Defining_Unit_Name (Node));
2843             Write_Param_Specs (Node);
2844
2845          when N_Protected_Body =>
2846             Write_Indent_Str_Sloc ("protected body ");
2847             Write_Id (Defining_Identifier (Node));
2848             Write_Str (" is");
2849             Sprint_Indented_List (Declarations (Node));
2850             Write_Indent_Str ("end ");
2851             Write_Id (Defining_Identifier (Node));
2852             Write_Char (';');
2853
2854          when N_Protected_Body_Stub =>
2855             Write_Indent_Str_Sloc ("protected body ");
2856             Write_Id (Defining_Identifier (Node));
2857             Write_Str_With_Col_Check (" is separate;");
2858
2859          when N_Protected_Definition =>
2860             Set_Debug_Sloc;
2861             Sprint_Indented_List (Visible_Declarations (Node));
2862
2863             if Present (Private_Declarations (Node)) then
2864                Write_Indent_Str ("private");
2865                Sprint_Indented_List (Private_Declarations (Node));
2866             end if;
2867
2868             Write_Indent_Str ("end ");
2869
2870          when N_Protected_Type_Declaration =>
2871             Write_Indent_Str_Sloc ("protected type ");
2872             Sprint_Node (Defining_Identifier (Node));
2873             Write_Discr_Specs (Node);
2874
2875             if Present (Interface_List (Node)) then
2876                Write_Str (" is new ");
2877                Sprint_And_List (Interface_List (Node));
2878                Write_Str (" with ");
2879             else
2880                Write_Str (" is");
2881             end if;
2882
2883             Sprint_Node (Protected_Definition (Node));
2884             Write_Id (Defining_Identifier (Node));
2885             Write_Char (';');
2886
2887          when N_Qualified_Expression =>
2888             Sprint_Node (Subtype_Mark (Node));
2889             Write_Char_Sloc (''');
2890
2891             --  Print expression, make sure we have at least one level of
2892             --  parentheses around the expression. For cases of qualified
2893             --  expressions in the source, this is always the case, but
2894             --  for generated qualifications, there may be no explicit
2895             --  parentheses present.
2896
2897             if Paren_Count (Expression (Node)) /= 0 then
2898                Sprint_Node (Expression (Node));
2899
2900             else
2901                Write_Char ('(');
2902                Sprint_Node (Expression (Node));
2903
2904                --  Odd case, for the qualified expressions used in machine
2905                --  code the argument may be a procedure call, resulting in
2906                --  a junk semicolon before the right parent, get rid of it.
2907
2908                Write_Erase_Char (';');
2909
2910                --  Now we can add the terminating right paren
2911
2912                Write_Char (')');
2913             end if;
2914
2915          when N_Quantified_Expression =>
2916             Write_Str (" for");
2917
2918             if All_Present (Node) then
2919                Write_Str (" all ");
2920             else
2921                Write_Str (" some ");
2922             end if;
2923
2924             if Present (Iterator_Specification (Node)) then
2925                Sprint_Node (Iterator_Specification (Node));
2926             else
2927                Sprint_Node (Loop_Parameter_Specification (Node));
2928             end if;
2929
2930             Write_Str (" => ");
2931             Sprint_Node (Condition (Node));
2932
2933          when N_Raise_Expression =>
2934             declare
2935                Has_Parens : constant Boolean := Paren_Count (Node) > 0;
2936
2937             begin
2938                --  The syntax for raise_expression does not include parentheses
2939                --  but sometimes parentheses are required, so unconditionally
2940                --  generate them here unless already present.
2941
2942                if not Has_Parens then
2943                   Write_Char ('(');
2944                end if;
2945
2946                Write_Str_With_Col_Check_Sloc ("raise ");
2947                Sprint_Node (Name (Node));
2948
2949                if Present (Expression (Node)) then
2950                   Write_Str_With_Col_Check (" with ");
2951                   Sprint_Node (Expression (Node));
2952                end if;
2953
2954                if not Has_Parens then
2955                   Write_Char (')');
2956                end if;
2957             end;
2958
2959          when N_Raise_Constraint_Error =>
2960
2961             --  This node can be used either as a subexpression or as a
2962             --  statement form. The following test is a reasonably reliable
2963             --  way to distinguish the two cases.
2964
2965             if Is_List_Member (Node)
2966               and then Nkind (Parent (Node)) not in N_Subexpr
2967             then
2968                Write_Indent;
2969             end if;
2970
2971             Write_Str_With_Col_Check_Sloc ("[constraint_error");
2972             Write_Condition_And_Reason (Node);
2973
2974          when N_Raise_Program_Error =>
2975
2976             --  This node can be used either as a subexpression or as a
2977             --  statement form. The following test is a reasonably reliable
2978             --  way to distinguish the two cases.
2979
2980             if Is_List_Member (Node)
2981               and then Nkind (Parent (Node)) not in N_Subexpr
2982             then
2983                Write_Indent;
2984             end if;
2985
2986             Write_Str_With_Col_Check_Sloc ("[program_error");
2987             Write_Condition_And_Reason (Node);
2988
2989          when N_Raise_Storage_Error =>
2990
2991             --  This node can be used either as a subexpression or as a
2992             --  statement form. The following test is a reasonably reliable
2993             --  way to distinguish the two cases.
2994
2995             if Is_List_Member (Node)
2996               and then Nkind (Parent (Node)) not in N_Subexpr
2997             then
2998                Write_Indent;
2999             end if;
3000
3001             Write_Str_With_Col_Check_Sloc ("[storage_error");
3002             Write_Condition_And_Reason (Node);
3003
3004          when N_Raise_Statement =>
3005             Write_Indent_Str_Sloc ("raise ");
3006             Sprint_Node (Name (Node));
3007
3008             if Present (Expression (Node)) then
3009                Write_Str_With_Col_Check_Sloc (" with ");
3010                Sprint_Node (Expression (Node));
3011             end if;
3012
3013             Write_Char (';');
3014
3015          when N_Range =>
3016             Sprint_Node (Low_Bound (Node));
3017             Write_Str_Sloc (" .. ");
3018             Sprint_Node (High_Bound (Node));
3019             Update_Itype (Node);
3020
3021          when N_Range_Constraint =>
3022             Write_Str_With_Col_Check_Sloc ("range ");
3023             Sprint_Node (Range_Expression (Node));
3024
3025          when N_Real_Literal =>
3026             Write_Ureal_With_Col_Check_Sloc (Realval (Node));
3027
3028          when N_Real_Range_Specification =>
3029             Write_Str_With_Col_Check_Sloc ("range ");
3030             Sprint_Node (Low_Bound (Node));
3031             Write_Str (" .. ");
3032             Sprint_Node (High_Bound (Node));
3033
3034          when N_Record_Definition =>
3035             if Abstract_Present (Node) then
3036                Write_Str_With_Col_Check ("abstract ");
3037             end if;
3038
3039             if Tagged_Present (Node) then
3040                Write_Str_With_Col_Check ("tagged ");
3041             end if;
3042
3043             if Limited_Present (Node) then
3044                Write_Str_With_Col_Check ("limited ");
3045             end if;
3046
3047             if Null_Present (Node) then
3048                Write_Str_With_Col_Check_Sloc ("null record");
3049
3050             else
3051                Write_Str_With_Col_Check_Sloc ("record");
3052                Sprint_Node (Component_List (Node));
3053                Write_Indent_Str ("end record");
3054             end if;
3055
3056          when N_Record_Representation_Clause =>
3057             Write_Indent_Str_Sloc ("for ");
3058             Sprint_Node (Identifier (Node));
3059             Write_Str_With_Col_Check (" use record ");
3060
3061             if Present (Mod_Clause (Node)) then
3062                Sprint_Node (Mod_Clause (Node));
3063             end if;
3064
3065             Sprint_Indented_List (Component_Clauses (Node));
3066             Write_Indent_Str ("end record;");
3067
3068          when N_Reference =>
3069             Sprint_Node (Prefix (Node));
3070             Write_Str_With_Col_Check_Sloc ("'reference");
3071
3072          when N_Requeue_Statement =>
3073             Write_Indent_Str_Sloc ("requeue ");
3074             Sprint_Node (Name (Node));
3075
3076             if Abort_Present (Node) then
3077                Write_Str_With_Col_Check (" with abort");
3078             end if;
3079
3080             Write_Char (';');
3081
3082          --  Don't we want to print more detail???
3083
3084          --  Doc of this extended syntax belongs in sinfo.ads and/or
3085          --  sprint.ads ???
3086
3087          when N_SCIL_Dispatch_Table_Tag_Init =>
3088             Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
3089
3090          when N_SCIL_Dispatching_Call =>
3091             Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
3092
3093          when N_SCIL_Membership_Test =>
3094             Write_Indent_Str ("[N_SCIL_Membership_Test]");
3095
3096          when N_Simple_Return_Statement =>
3097             if Present (Expression (Node)) then
3098                Write_Indent_Str_Sloc ("return ");
3099                Sprint_Node (Expression (Node));
3100                Write_Char (';');
3101             else
3102                Write_Indent_Str_Sloc ("return;");
3103             end if;
3104
3105          when N_Selective_Accept =>
3106             Write_Indent_Str_Sloc ("select");
3107
3108             declare
3109                Alt_Node : Node_Id;
3110             begin
3111                Alt_Node := First (Select_Alternatives (Node));
3112                loop
3113                   Indent_Begin;
3114                   Sprint_Node (Alt_Node);
3115                   Indent_End;
3116                   Next (Alt_Node);
3117                   exit when No (Alt_Node);
3118                   Write_Indent_Str ("or");
3119                end loop;
3120             end;
3121
3122             if Present (Else_Statements (Node)) then
3123                Write_Indent_Str ("else");
3124                Sprint_Indented_List (Else_Statements (Node));
3125             end if;
3126
3127             Write_Indent_Str ("end select;");
3128
3129          when N_Signed_Integer_Type_Definition =>
3130             Write_Str_With_Col_Check_Sloc ("range ");
3131             Sprint_Node (Low_Bound (Node));
3132             Write_Str (" .. ");
3133             Sprint_Node (High_Bound (Node));
3134
3135          when N_Single_Protected_Declaration =>
3136             Write_Indent_Str_Sloc ("protected ");
3137             Write_Id (Defining_Identifier (Node));
3138             Write_Str (" is");
3139             Sprint_Node (Protected_Definition (Node));
3140             Write_Id (Defining_Identifier (Node));
3141             Write_Char (';');
3142
3143          when N_Single_Task_Declaration =>
3144             Write_Indent_Str_Sloc ("task ");
3145             Sprint_Node (Defining_Identifier (Node));
3146
3147             if Present (Task_Definition (Node)) then
3148                Write_Str (" is");
3149                Sprint_Node (Task_Definition (Node));
3150             end if;
3151
3152             Write_Char (';');
3153
3154          when N_Selected_Component =>
3155             Sprint_Node (Prefix (Node));
3156             Write_Char_Sloc ('.');
3157             Sprint_Node (Selector_Name (Node));
3158
3159          when N_Slice =>
3160             Set_Debug_Sloc;
3161             Sprint_Node (Prefix (Node));
3162             Write_Str_With_Col_Check (" (");
3163             Sprint_Node (Discrete_Range (Node));
3164             Write_Char (')');
3165
3166          when N_String_Literal =>
3167             if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then
3168                Write_Indent_Str ("  ");
3169             end if;
3170
3171             Set_Debug_Sloc;
3172             Write_String_Table_Entry (Strval (Node));
3173
3174          when N_Subprogram_Body =>
3175
3176             --  Output extra blank line unless we are in freeze actions
3177
3178             if Freeze_Indent = 0 then
3179                Extra_Blank_Line;
3180             end if;
3181
3182             Write_Indent;
3183
3184             if Present (Corresponding_Spec (Node)) then
3185                Sprint_Node_Sloc (Parent (Corresponding_Spec (Node)));
3186             else
3187                Sprint_Node_Sloc (Specification (Node));
3188             end if;
3189
3190             Write_Str (" is");
3191
3192             Sprint_Indented_List (Declarations (Node));
3193             Write_Indent_Str ("begin");
3194             Sprint_Node (Handled_Statement_Sequence (Node));
3195
3196             Write_Indent_Str ("end ");
3197
3198             Sprint_End_Label
3199               (Handled_Statement_Sequence (Node),
3200                  Defining_Unit_Name (Specification (Node)));
3201             Write_Char (';');
3202
3203             if Is_List_Member (Node)
3204               and then Present (Next (Node))
3205               and then Nkind (Next (Node)) /= N_Subprogram_Body
3206             then
3207                Write_Indent;
3208             end if;
3209
3210          when N_Subprogram_Body_Stub =>
3211             Write_Indent;
3212             Sprint_Node_Sloc (Specification (Node));
3213             Write_Str_With_Col_Check (" is separate;");
3214
3215          when N_Subprogram_Declaration =>
3216             Write_Indent;
3217             Sprint_Node_Sloc (Specification (Node));
3218
3219             if Nkind (Specification (Node)) = N_Procedure_Specification
3220               and then Null_Present (Specification (Node))
3221             then
3222                Write_Str_With_Col_Check (" is null");
3223             end if;
3224
3225             Write_Char (';');
3226
3227          when N_Subprogram_Renaming_Declaration =>
3228             Write_Indent;
3229             Sprint_Node (Specification (Node));
3230             Write_Str_With_Col_Check_Sloc (" renames ");
3231             Sprint_Node (Name (Node));
3232             Write_Char (';');
3233
3234          when N_Subtype_Declaration =>
3235             Write_Indent_Str_Sloc ("subtype ");
3236             Sprint_Node (Defining_Identifier (Node));
3237             Write_Str (" is ");
3238
3239             --  Ada 2005 (AI-231)
3240
3241             if Null_Exclusion_Present (Node) then
3242                Write_Str ("not null ");
3243             end if;
3244
3245             Sprint_Node (Subtype_Indication (Node));
3246             Write_Char (';');
3247
3248          when N_Subtype_Indication =>
3249             Sprint_Node_Sloc (Subtype_Mark (Node));
3250             Write_Char (' ');
3251             Sprint_Node (Constraint (Node));
3252
3253          when N_Subunit =>
3254             Write_Indent_Str_Sloc ("separate (");
3255             Sprint_Node (Name (Node));
3256             Write_Char (')');
3257             Extra_Blank_Line;
3258             Sprint_Node (Proper_Body (Node));
3259
3260          when N_Task_Body =>
3261             Write_Indent_Str_Sloc ("task body ");
3262             Write_Id (Defining_Identifier (Node));
3263             Write_Str (" is");
3264             Sprint_Indented_List (Declarations (Node));
3265             Write_Indent_Str ("begin");
3266             Sprint_Node (Handled_Statement_Sequence (Node));
3267             Write_Indent_Str ("end ");
3268             Sprint_End_Label
3269               (Handled_Statement_Sequence (Node), Defining_Identifier (Node));
3270             Write_Char (';');
3271
3272          when N_Task_Body_Stub =>
3273             Write_Indent_Str_Sloc ("task body ");
3274             Write_Id (Defining_Identifier (Node));
3275             Write_Str_With_Col_Check (" is separate;");
3276
3277          when N_Task_Definition =>
3278             Set_Debug_Sloc;
3279             Sprint_Indented_List (Visible_Declarations (Node));
3280
3281             if Present (Private_Declarations (Node)) then
3282                Write_Indent_Str ("private");
3283                Sprint_Indented_List (Private_Declarations (Node));
3284             end if;
3285
3286             Write_Indent_Str ("end ");
3287             Sprint_End_Label (Node, Defining_Identifier (Parent (Node)));
3288
3289          when N_Task_Type_Declaration =>
3290             Write_Indent_Str_Sloc ("task type ");
3291             Sprint_Node (Defining_Identifier (Node));
3292             Write_Discr_Specs (Node);
3293
3294             if Present (Interface_List (Node)) then
3295                Write_Str (" is new ");
3296                Sprint_And_List (Interface_List (Node));
3297             end if;
3298
3299             if Present (Task_Definition (Node)) then
3300                if No (Interface_List (Node)) then
3301                   Write_Str (" is");
3302                else
3303                   Write_Str (" with ");
3304                end if;
3305
3306                Sprint_Node (Task_Definition (Node));
3307             end if;
3308
3309             Write_Char (';');
3310
3311          when N_Terminate_Alternative =>
3312             Sprint_Node_List (Pragmas_Before (Node));
3313             Write_Indent;
3314
3315             if Present (Condition (Node)) then
3316                Write_Str_With_Col_Check ("when ");
3317                Sprint_Node (Condition (Node));
3318                Write_Str (" => ");
3319             end if;
3320
3321             Write_Str_With_Col_Check_Sloc ("terminate;");
3322             Sprint_Node_List (Pragmas_After (Node));
3323
3324          when N_Timed_Entry_Call =>
3325             Write_Indent_Str_Sloc ("select");
3326             Indent_Begin;
3327             Sprint_Node (Entry_Call_Alternative (Node));
3328             Indent_End;
3329             Write_Indent_Str ("or");
3330             Indent_Begin;
3331             Sprint_Node (Delay_Alternative (Node));
3332             Indent_End;
3333             Write_Indent_Str ("end select;");
3334
3335          when N_Triggering_Alternative =>
3336             Sprint_Node_List (Pragmas_Before (Node));
3337             Sprint_Node_Sloc (Triggering_Statement (Node));
3338             Sprint_Node_List (Statements (Node));
3339
3340          when N_Type_Conversion =>
3341             Set_Debug_Sloc;
3342             Sprint_Node (Subtype_Mark (Node));
3343             Col_Check (4);
3344
3345             if Conversion_OK (Node) then
3346                Write_Char ('?');
3347             end if;
3348
3349             if Float_Truncate (Node) then
3350                Write_Char ('^');
3351             end if;
3352
3353             if Rounded_Result (Node) then
3354                Write_Char ('@');
3355             end if;
3356
3357             Write_Char ('(');
3358             Sprint_Node (Expression (Node));
3359             Write_Char (')');
3360
3361          when N_Unchecked_Expression =>
3362             Col_Check (10);
3363             Write_Str ("`(");
3364             Sprint_Node_Sloc (Expression (Node));
3365             Write_Char (')');
3366
3367          when N_Unchecked_Type_Conversion =>
3368             Sprint_Node (Subtype_Mark (Node));
3369             Write_Char ('!');
3370             Write_Str_With_Col_Check ("(");
3371             Sprint_Node_Sloc (Expression (Node));
3372             Write_Char (')');
3373
3374          when N_Unconstrained_Array_Definition =>
3375             Write_Str_With_Col_Check_Sloc ("array (");
3376
3377             declare
3378                Node1 : Node_Id;
3379             begin
3380                Node1 := First (Subtype_Marks (Node));
3381                loop
3382                   Sprint_Node (Node1);
3383                   Write_Str_With_Col_Check (" range <>");
3384                   Next (Node1);
3385                   exit when Node1 = Empty;
3386                   Write_Str (", ");
3387                end loop;
3388             end;
3389
3390             Write_Str (") of ");
3391             Sprint_Node (Component_Definition (Node));
3392
3393          when N_Unused_At_Start | N_Unused_At_End =>
3394             Write_Indent_Str ("***** Error, unused node encountered *****");
3395             Write_Eol;
3396
3397          when N_Use_Package_Clause =>
3398             Write_Indent_Str_Sloc ("use ");
3399             Sprint_Comma_List (Names (Node));
3400             Write_Char (';');
3401
3402          when N_Use_Type_Clause =>
3403             Write_Indent_Str_Sloc ("use type ");
3404             Sprint_Comma_List (Subtype_Marks (Node));
3405             Write_Char (';');
3406
3407          when N_Validate_Unchecked_Conversion =>
3408             Write_Indent_Str_Sloc ("validate unchecked_conversion (");
3409             Sprint_Node (Source_Type (Node));
3410             Write_Str (", ");
3411             Sprint_Node (Target_Type (Node));
3412             Write_Str (");");
3413
3414          when N_Variant =>
3415             Write_Indent_Str_Sloc ("when ");
3416             Sprint_Bar_List (Discrete_Choices (Node));
3417             Write_Str (" => ");
3418             Sprint_Node (Component_List (Node));
3419
3420          when N_Variant_Part =>
3421             Indent_Begin;
3422             Write_Indent_Str_Sloc ("case ");
3423             Sprint_Node (Name (Node));
3424             Write_Str (" is ");
3425             Sprint_Indented_List (Variants (Node));
3426             Write_Indent_Str ("end case");
3427             Indent_End;
3428
3429          when N_With_Clause =>
3430
3431             --  Special test, if we are dumping the original tree only,
3432             --  then we want to eliminate the bogus with clauses that
3433             --  correspond to the non-existent children of Text_IO.
3434
3435             if Dump_Original_Only
3436               and then Is_Text_IO_Special_Unit (Name (Node))
3437             then
3438                null;
3439
3440             --  Normal case, output the with clause
3441
3442             else
3443                if First_Name (Node) or else not Dump_Original_Only then
3444
3445                   --  Ada 2005 (AI-50217): Print limited with_clauses
3446
3447                   if Private_Present (Node) and Limited_Present (Node) then
3448                      Write_Indent_Str ("limited private with ");
3449
3450                   elsif Private_Present (Node) then
3451                      Write_Indent_Str ("private with ");
3452
3453                   elsif Limited_Present (Node) then
3454                      Write_Indent_Str ("limited with ");
3455
3456                   else
3457                      Write_Indent_Str ("with ");
3458                   end if;
3459
3460                else
3461                   Write_Str (", ");
3462                end if;
3463
3464                Sprint_Node_Sloc (Name (Node));
3465
3466                if Last_Name (Node) or else not Dump_Original_Only then
3467                   Write_Char (';');
3468                end if;
3469             end if;
3470       end case;
3471
3472       --  Print aspects, except for special case of package declaration,
3473       --  where the aspects are printed inside the package specification.
3474
3475       if Has_Aspects (Node)
3476          and then not Nkind_In (Node, N_Package_Declaration,
3477                                       N_Generic_Package_Declaration)
3478       then
3479          Sprint_Aspect_Specifications (Node, Semicolon => True);
3480       end if;
3481
3482       if Nkind (Node) in N_Subexpr
3483         and then Do_Range_Check (Node)
3484       then
3485          Write_Str ("}");
3486       end if;
3487
3488       for J in 1 .. Paren_Count (Node) loop
3489          Write_Char (')');
3490       end loop;
3491
3492       Dump_Node := Save_Dump_Node;
3493    end Sprint_Node_Actual;
3494
3495    ----------------------
3496    -- Sprint_Node_List --
3497    ----------------------
3498
3499    procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is
3500       Node : Node_Id;
3501
3502    begin
3503       if Is_Non_Empty_List (List) then
3504          Node := First (List);
3505
3506          loop
3507             Sprint_Node (Node);
3508             Next (Node);
3509             exit when Node = Empty;
3510          end loop;
3511       end if;
3512
3513       if New_Lines and then Column /= 1 then
3514          Write_Eol;
3515       end if;
3516    end Sprint_Node_List;
3517
3518    ----------------------
3519    -- Sprint_Node_Sloc --
3520    ----------------------
3521
3522    procedure Sprint_Node_Sloc (Node : Node_Id) is
3523    begin
3524       Sprint_Node (Node);
3525
3526       if Debug_Generated_Code and then Present (Dump_Node) then
3527          Set_Sloc (Dump_Node, Sloc (Node));
3528          Dump_Node := Empty;
3529       end if;
3530    end Sprint_Node_Sloc;
3531
3532    ---------------------
3533    -- Sprint_Opt_Node --
3534    ---------------------
3535
3536    procedure Sprint_Opt_Node (Node : Node_Id) is
3537    begin
3538       if Present (Node) then
3539          Write_Char (' ');
3540          Sprint_Node (Node);
3541       end if;
3542    end Sprint_Opt_Node;
3543
3544    --------------------------
3545    -- Sprint_Opt_Node_List --
3546    --------------------------
3547
3548    procedure Sprint_Opt_Node_List (List : List_Id) is
3549    begin
3550       if Present (List) then
3551          Sprint_Node_List (List);
3552       end if;
3553    end Sprint_Opt_Node_List;
3554
3555    ---------------------------------
3556    -- Sprint_Opt_Paren_Comma_List --
3557    ---------------------------------
3558
3559    procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
3560    begin
3561       if Is_Non_Empty_List (List) then
3562          Write_Char (' ');
3563          Sprint_Paren_Comma_List (List);
3564       end if;
3565    end Sprint_Opt_Paren_Comma_List;
3566
3567    -----------------------------
3568    -- Sprint_Paren_Comma_List --
3569    -----------------------------
3570
3571    procedure Sprint_Paren_Comma_List (List : List_Id) is
3572       N           : Node_Id;
3573       Node_Exists : Boolean := False;
3574
3575    begin
3576
3577       if Is_Non_Empty_List (List) then
3578
3579          if Dump_Original_Only then
3580             N := First (List);
3581             while Present (N) loop
3582                if not Is_Rewrite_Insertion (N) then
3583                   Node_Exists := True;
3584                   exit;
3585                end if;
3586
3587                Next (N);
3588             end loop;
3589
3590             if not Node_Exists then
3591                return;
3592             end if;
3593          end if;
3594
3595          Write_Str_With_Col_Check ("(");
3596          Sprint_Comma_List (List);
3597          Write_Char (')');
3598       end if;
3599    end Sprint_Paren_Comma_List;
3600
3601    ----------------------
3602    -- Sprint_Right_Opnd --
3603    ----------------------
3604
3605    procedure Sprint_Right_Opnd (N : Node_Id) is
3606       Opnd : constant Node_Id := Right_Opnd (N);
3607
3608    begin
3609       if Paren_Count (Opnd) /= 0
3610         or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N))
3611       then
3612          Sprint_Node (Opnd);
3613
3614       else
3615          Write_Char ('(');
3616          Sprint_Node (Opnd);
3617          Write_Char (')');
3618       end if;
3619    end Sprint_Right_Opnd;
3620
3621    ------------------
3622    -- Update_Itype --
3623    ------------------
3624
3625    procedure Update_Itype (Node : Node_Id) is
3626    begin
3627       if Present (Etype (Node))
3628         and then Is_Itype (Etype (Node))
3629         and then Debug_Generated_Code
3630       then
3631          Set_Sloc (Etype (Node), Sloc (Node));
3632       end if;
3633    end Update_Itype;
3634
3635    ---------------------
3636    -- Write_Char_Sloc --
3637    ---------------------
3638
3639    procedure Write_Char_Sloc (C : Character) is
3640    begin
3641       if Debug_Generated_Code and then C /= ' ' then
3642          Set_Debug_Sloc;
3643       end if;
3644
3645       Write_Char (C);
3646    end Write_Char_Sloc;
3647
3648    --------------------------------
3649    -- Write_Condition_And_Reason --
3650    --------------------------------
3651
3652    procedure Write_Condition_And_Reason (Node : Node_Id) is
3653       Cond  : constant Node_Id := Condition (Node);
3654       Image : constant String  := RT_Exception_Code'Image
3655                                     (RT_Exception_Code'Val
3656                                        (UI_To_Int (Reason (Node))));
3657
3658    begin
3659       if Present (Cond) then
3660
3661          --  If condition is a single entity, or NOT with a single entity,
3662          --  output all on one line, since it will likely fit just fine.
3663
3664          if Is_Entity_Name (Cond)
3665            or else (Nkind (Cond) = N_Op_Not
3666                      and then Is_Entity_Name (Right_Opnd (Cond)))
3667          then
3668             Write_Str_With_Col_Check (" when ");
3669             Sprint_Node (Cond);
3670             Write_Char (' ');
3671
3672             --  Otherwise for more complex condition, multiple lines
3673
3674          else
3675             Write_Str_With_Col_Check (" when");
3676             Indent := Indent + 2;
3677             Write_Indent;
3678             Sprint_Node (Cond);
3679             Write_Indent;
3680             Indent := Indent - 2;
3681          end if;
3682
3683       --  If no condition, just need a space (all on one line)
3684
3685       else
3686          Write_Char (' ');
3687       end if;
3688
3689       --  Write the reason
3690
3691       Write_Char ('"');
3692
3693       for J in 4 .. Image'Last loop
3694          if Image (J) = '_' then
3695             Write_Char (' ');
3696          else
3697             Write_Char (Fold_Lower (Image (J)));
3698          end if;
3699       end loop;
3700
3701       Write_Str ("""]");
3702    end Write_Condition_And_Reason;
3703
3704    --------------------------------
3705    -- Write_Corresponding_Source --
3706    --------------------------------
3707
3708    procedure Write_Corresponding_Source (S : String) is
3709       Loc : Source_Ptr;
3710       Src : Source_Buffer_Ptr;
3711
3712    begin
3713       --  Ignore if not in dump source text mode, or if in freeze actions
3714
3715       if Dump_Source_Text and then Freeze_Indent = 0 then
3716
3717          --  Ignore null string
3718
3719          if S = "" then
3720             return;
3721          end if;
3722
3723          --  Ignore space or semicolon at end of given string
3724
3725          if S (S'Last) = ' ' or else S (S'Last) = ';' then
3726             Write_Corresponding_Source (S (S'First .. S'Last - 1));
3727             return;
3728          end if;
3729
3730          --  Loop to look at next lines not yet printed in source file
3731
3732          for L in
3733            Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File)
3734          loop
3735             Src := Source_Text (Current_Source_File);
3736             Loc := Line_Start (L, Current_Source_File);
3737
3738             --  If comment, keep looking
3739
3740             if Src (Loc .. Loc + 1) = "--" then
3741                null;
3742
3743             --  Search to first non-blank
3744
3745             else
3746                while Src (Loc) not in Line_Terminator loop
3747
3748                   --  Non-blank found
3749
3750                   if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then
3751
3752                      --  Loop through characters in string to see if we match
3753
3754                      for J in S'Range loop
3755
3756                         --  If mismatch, then not the case we are looking for
3757
3758                         if Src (Loc) /= S (J) then
3759                            return;
3760                         end if;
3761
3762                         Loc := Loc + 1;
3763                      end loop;
3764
3765                      --  If we fall through, string matched, if white space or
3766                      --  semicolon after the matched string, this is the case
3767                      --  we are looking for.
3768
3769                      if Src (Loc) in Line_Terminator
3770                        or else Src (Loc) = ' '
3771                        or else Src (Loc) = ASCII.HT
3772                        or else Src (Loc) = ';'
3773                      then
3774                         --  So output source lines up to and including this one
3775
3776                         Write_Source_Lines (L);
3777                         return;
3778                      end if;
3779                   end if;
3780
3781                   Loc := Loc + 1;
3782                end loop;
3783             end if;
3784
3785          --  Line was all blanks, or a comment line, keep looking
3786
3787          end loop;
3788       end if;
3789    end Write_Corresponding_Source;
3790
3791    -----------------------
3792    -- Write_Discr_Specs --
3793    -----------------------
3794
3795    procedure Write_Discr_Specs (N : Node_Id) is
3796       Specs : List_Id;
3797       Spec  : Node_Id;
3798
3799    begin
3800       Specs := Discriminant_Specifications (N);
3801
3802       if Present (Specs) then
3803          Write_Str_With_Col_Check (" (");
3804          Spec := First (Specs);
3805
3806          loop
3807             Sprint_Node (Spec);
3808             Next (Spec);
3809             exit when Spec = Empty;
3810
3811             --  Add semicolon, unless we are printing original tree and the
3812             --  next specification is part of a list (but not the first
3813             --  element of that list)
3814
3815             if not Dump_Original_Only or else not Prev_Ids (Spec) then
3816                Write_Str ("; ");
3817             end if;
3818          end loop;
3819
3820          Write_Char (')');
3821       end if;
3822    end Write_Discr_Specs;
3823
3824    -----------------
3825    -- Write_Ekind --
3826    -----------------
3827
3828    procedure Write_Ekind (E : Entity_Id) is
3829       S : constant String := Entity_Kind'Image (Ekind (E));
3830
3831    begin
3832       Name_Len := S'Length;
3833       Name_Buffer (1 .. Name_Len) := S;
3834       Set_Casing (Mixed_Case);
3835       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3836    end Write_Ekind;
3837
3838    --------------
3839    -- Write_Id --
3840    --------------
3841
3842    procedure Write_Id (N : Node_Id) is
3843    begin
3844       --  Deal with outputting Itype
3845
3846       --  Note: if we are printing the full tree with -gnatds, then we may
3847       --  end up picking up the Associated_Node link from a generic template
3848       --  here which overlaps the Entity field, but as documented, Write_Itype
3849       --  is defended against junk calls.
3850
3851       if Nkind (N) in N_Entity then
3852          Write_Itype (N);
3853       elsif Nkind (N) in N_Has_Entity then
3854          Write_Itype (Entity (N));
3855       end if;
3856
3857       --  Case of a defining identifier
3858
3859       if Nkind (N) = N_Defining_Identifier then
3860
3861          --  If defining identifier has an interface name (and no
3862          --  address clause), then we output the interface name.
3863
3864          if (Is_Imported (N) or else Is_Exported (N))
3865            and then Present (Interface_Name (N))
3866            and then No (Address_Clause (N))
3867          then
3868             String_To_Name_Buffer (Strval (Interface_Name (N)));
3869             Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3870
3871          --  If no interface name (or inactive because there was
3872          --  an address clause), then just output the Chars name.
3873
3874          else
3875             Write_Name_With_Col_Check (Chars (N));
3876          end if;
3877
3878       --  Case of selector of an expanded name where the expanded name
3879       --  has an associated entity, output this entity. Check that the
3880       --  entity or associated node is of the right kind, see above.
3881
3882       elsif Nkind (Parent (N)) = N_Expanded_Name
3883         and then Selector_Name (Parent (N)) = N
3884         and then Present (Entity_Or_Associated_Node (Parent (N)))
3885         and then Nkind (Entity (Parent (N))) in N_Entity
3886       then
3887          Write_Id (Entity (Parent (N)));
3888
3889       --  For any other node with an associated entity, output it
3890
3891       elsif Nkind (N) in N_Has_Entity
3892         and then Present (Entity_Or_Associated_Node (N))
3893         and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
3894       then
3895          Write_Id (Entity (N));
3896
3897       --  All other cases, we just print the Chars field
3898
3899       else
3900          Write_Name_With_Col_Check (Chars (N));
3901       end if;
3902    end Write_Id;
3903
3904    -----------------------
3905    -- Write_Identifiers --
3906    -----------------------
3907
3908    function Write_Identifiers (Node : Node_Id) return Boolean is
3909    begin
3910       Sprint_Node (Defining_Identifier (Node));
3911       Update_Itype (Defining_Identifier (Node));
3912
3913       --  The remainder of the declaration must be printed unless we are
3914       --  printing the original tree and this is not the last identifier
3915
3916       return
3917          not Dump_Original_Only or else not More_Ids (Node);
3918
3919    end Write_Identifiers;
3920
3921    ------------------------
3922    -- Write_Implicit_Def --
3923    ------------------------
3924
3925    procedure Write_Implicit_Def (E : Entity_Id) is
3926       Ind : Node_Id;
3927
3928    begin
3929       case Ekind (E) is
3930          when E_Array_Subtype =>
3931             Write_Str_With_Col_Check ("subtype ");
3932             Write_Id (E);
3933             Write_Str_With_Col_Check (" is ");
3934             Write_Id (Base_Type (E));
3935             Write_Str_With_Col_Check (" (");
3936
3937             Ind := First_Index (E);
3938             while Present (Ind) loop
3939                Sprint_Node (Ind);
3940                Next_Index (Ind);
3941
3942                if Present (Ind) then
3943                   Write_Str (", ");
3944                end if;
3945             end loop;
3946
3947             Write_Str (");");
3948
3949          when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
3950             Write_Str_With_Col_Check ("subtype ");
3951             Write_Id (E);
3952             Write_Str (" is ");
3953             Write_Id (Etype (E));
3954             Write_Str_With_Col_Check (" range ");
3955             Sprint_Node (Scalar_Range (E));
3956             Write_Str (";");
3957
3958          when others =>
3959             Write_Str_With_Col_Check ("type ");
3960             Write_Id (E);
3961             Write_Str_With_Col_Check (" is <");
3962             Write_Ekind (E);
3963             Write_Str (">;");
3964       end case;
3965
3966    end Write_Implicit_Def;
3967
3968    ------------------
3969    -- Write_Indent --
3970    ------------------
3971
3972    procedure Write_Indent is
3973       Loc : constant Source_Ptr := Sloc (Dump_Node);
3974
3975    begin
3976       if Indent_Annull_Flag then
3977          Indent_Annull_Flag := False;
3978       else
3979          --  Deal with Dump_Source_Text output. Note that we ignore implicit
3980          --  label declarations, since they typically have the sloc of the
3981          --  corresponding label, which really messes up the -gnatL output.
3982
3983          if Dump_Source_Text
3984            and then Loc > No_Location
3985            and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration
3986          then
3987             if Get_Source_File_Index (Loc) = Current_Source_File then
3988                Write_Source_Lines
3989                  (Get_Physical_Line_Number (Sloc (Dump_Node)));
3990             end if;
3991          end if;
3992
3993          Write_Eol;
3994
3995          for J in 1 .. Indent loop
3996             Write_Char (' ');
3997          end loop;
3998       end if;
3999    end Write_Indent;
4000
4001    ------------------------------
4002    -- Write_Indent_Identifiers --
4003    ------------------------------
4004
4005    function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
4006    begin
4007       --  We need to start a new line for every node, except in the case
4008       --  where we are printing the original tree and this is not the first
4009       --  defining identifier in the list.
4010
4011       if not Dump_Original_Only or else not Prev_Ids (Node) then
4012          Write_Indent;
4013
4014       --  If printing original tree and this is not the first defining
4015       --  identifier in the list, then the previous call to this procedure
4016       --  printed only the name, and we add a comma to separate the names.
4017
4018       else
4019          Write_Str (", ");
4020       end if;
4021
4022       Sprint_Node (Defining_Identifier (Node));
4023
4024       --  The remainder of the declaration must be printed unless we are
4025       --  printing the original tree and this is not the last identifier
4026
4027       return
4028          not Dump_Original_Only or else not More_Ids (Node);
4029    end Write_Indent_Identifiers;
4030
4031    -----------------------------------
4032    -- Write_Indent_Identifiers_Sloc --
4033    -----------------------------------
4034
4035    function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
4036    begin
4037       --  We need to start a new line for every node, except in the case
4038       --  where we are printing the original tree and this is not the first
4039       --  defining identifier in the list.
4040
4041       if not Dump_Original_Only or else not Prev_Ids (Node) then
4042          Write_Indent;
4043
4044       --  If printing original tree and this is not the first defining
4045       --  identifier in the list, then the previous call to this procedure
4046       --  printed only the name, and we add a comma to separate the names.
4047
4048       else
4049          Write_Str (", ");
4050       end if;
4051
4052       Set_Debug_Sloc;
4053       Sprint_Node (Defining_Identifier (Node));
4054
4055       --  The remainder of the declaration must be printed unless we are
4056       --  printing the original tree and this is not the last identifier
4057
4058       return not Dump_Original_Only or else not More_Ids (Node);
4059    end Write_Indent_Identifiers_Sloc;
4060
4061    ----------------------
4062    -- Write_Indent_Str --
4063    ----------------------
4064
4065    procedure Write_Indent_Str (S : String) is
4066    begin
4067       Write_Corresponding_Source (S);
4068       Write_Indent;
4069       Write_Str (S);
4070    end Write_Indent_Str;
4071
4072    ---------------------------
4073    -- Write_Indent_Str_Sloc --
4074    ---------------------------
4075
4076    procedure Write_Indent_Str_Sloc (S : String) is
4077    begin
4078       Write_Corresponding_Source (S);
4079       Write_Indent;
4080       Write_Str_Sloc (S);
4081    end Write_Indent_Str_Sloc;
4082
4083    -----------------
4084    -- Write_Itype --
4085    -----------------
4086
4087    procedure Write_Itype (Typ : Entity_Id) is
4088
4089       procedure Write_Header (T : Boolean := True);
4090       --  Write type if T is True, subtype if T is false
4091
4092       ------------------
4093       -- Write_Header --
4094       ------------------
4095
4096       procedure Write_Header (T : Boolean := True) is
4097       begin
4098          if T then
4099             Write_Str ("[type ");
4100          else
4101             Write_Str ("[subtype ");
4102          end if;
4103
4104          Write_Name_With_Col_Check (Chars (Typ));
4105          Write_Str (" is ");
4106       end Write_Header;
4107
4108    --  Start of processing for Write_Itype
4109
4110    begin
4111       if Nkind (Typ) in N_Entity
4112         and then Is_Itype (Typ)
4113         and then not Itype_Printed (Typ)
4114       then
4115          --  Itype to be printed
4116
4117          declare
4118             B : constant Node_Id := Etype (Typ);
4119             X : Node_Id;
4120             P : constant Node_Id := Parent (Typ);
4121
4122             S : constant Saved_Output_Buffer := Save_Output_Buffer;
4123             --  Save current output buffer
4124
4125             Old_Sloc : Source_Ptr;
4126             --  Save sloc of related node, so it is not modified when
4127             --  printing with -gnatD.
4128
4129          begin
4130             --  Write indentation at start of line
4131
4132             for J in 1 .. Indent loop
4133                Write_Char (' ');
4134             end loop;
4135
4136             --  If we have a constructed declaration for the itype, print it
4137
4138             if Present (P)
4139               and then Nkind (P) in N_Declaration
4140               and then Defining_Entity (P) = Typ
4141             then
4142                --  We must set Itype_Printed true before the recursive call to
4143                --  print the node, otherwise we get an infinite recursion.
4144
4145                Set_Itype_Printed (Typ, True);
4146
4147                --  Write the declaration enclosed in [], avoiding new line
4148                --  at start of declaration, and semicolon at end.
4149
4150                --  Note: The itype may be imported from another unit, in which
4151                --  case we do not want to modify the Sloc of the declaration.
4152                --  Otherwise the itype may appear to be in the current unit,
4153                --  and the back-end will reject a reference out of scope.
4154
4155                Write_Char ('[');
4156                Indent_Annull_Flag := True;
4157                Old_Sloc := Sloc (P);
4158                Sprint_Node (P);
4159                Set_Sloc (P, Old_Sloc);
4160                Write_Erase_Char (';');
4161
4162             --  If no constructed declaration, then we have to concoct the
4163             --  source corresponding to the type entity that we have at hand.
4164
4165             else
4166                case Ekind (Typ) is
4167
4168                   --  Access types and subtypes
4169
4170                   when Access_Kind =>
4171                      Write_Header (Ekind (Typ) = E_Access_Type);
4172
4173                      if Can_Never_Be_Null (Typ) then
4174                         Write_Str ("not null ");
4175                      end if;
4176
4177                      Write_Str ("access ");
4178
4179                      if Is_Access_Constant (Typ) then
4180                         Write_Str ("constant ");
4181                      end if;
4182
4183                      Write_Id (Directly_Designated_Type (Typ));
4184
4185                   --  Array types and string types
4186
4187                   when E_Array_Type =>
4188                      Write_Header;
4189                      Write_Str ("array (");
4190
4191                      X := First_Index (Typ);
4192                      loop
4193                         Sprint_Node (X);
4194
4195                         if not Is_Constrained (Typ) then
4196                            Write_Str (" range <>");
4197                         end if;
4198
4199                         Next_Index (X);
4200                         exit when No (X);
4201                         Write_Str (", ");
4202                      end loop;
4203
4204                      Write_Str (") of ");
4205                      X := Component_Type (Typ);
4206
4207                      --  Preserve sloc of component type, which is defined
4208                      --  elsewhere than the itype (see comment above).
4209
4210                      Old_Sloc := Sloc (X);
4211                      Sprint_Node (X);
4212                      Set_Sloc (X, Old_Sloc);
4213
4214                      --  Array subtypes and string subtypes.
4215                      --  Preserve Sloc of index subtypes, as above.
4216
4217                   when E_Array_Subtype | E_String_Subtype =>
4218                      Write_Header (False);
4219                      Write_Id (Etype (Typ));
4220                      Write_Str (" (");
4221
4222                      X := First_Index (Typ);
4223                      loop
4224                         Old_Sloc := Sloc (X);
4225                         Sprint_Node (X);
4226                         Set_Sloc (X, Old_Sloc);
4227                         Next_Index (X);
4228                         exit when No (X);
4229                         Write_Str (", ");
4230                      end loop;
4231
4232                      Write_Char (')');
4233
4234                   --  Signed integer types, and modular integer subtypes,
4235                   --  and also enumeration subtypes.
4236
4237                   when E_Signed_Integer_Type     |
4238                        E_Signed_Integer_Subtype  |
4239                        E_Modular_Integer_Subtype |
4240                        E_Enumeration_Subtype     =>
4241
4242                      Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
4243
4244                      if Ekind (Typ) = E_Signed_Integer_Type then
4245                         Write_Str ("new ");
4246                      end if;
4247
4248                      Write_Id (B);
4249
4250                      --  Print bounds if different from base type
4251
4252                      declare
4253                         L  : constant Node_Id := Type_Low_Bound (Typ);
4254                         H  : constant Node_Id := Type_High_Bound (Typ);
4255                         LE : Node_Id;
4256                         HE : Node_Id;
4257
4258                      begin
4259                         --  B can either be a scalar type, in which case the
4260                         --  declaration of Typ may constrain it with different
4261                         --  bounds, or a private type, in which case we know
4262                         --  that the declaration of Typ cannot have a scalar
4263                         --  constraint.
4264
4265                         if Is_Scalar_Type (B) then
4266                            LE := Type_Low_Bound (B);
4267                            HE := Type_High_Bound (B);
4268                         else
4269                            LE := Empty;
4270                            HE := Empty;
4271                         end if;
4272
4273                         if No (LE)
4274                           or else (True
4275                             and then Nkind (L) = N_Integer_Literal
4276                             and then Nkind (H) = N_Integer_Literal
4277                             and then Nkind (LE) = N_Integer_Literal
4278                             and then Nkind (HE) = N_Integer_Literal
4279                             and then UI_Eq (Intval (L), Intval (LE))
4280                             and then UI_Eq (Intval (H), Intval (HE)))
4281                         then
4282                            null;
4283
4284                         else
4285                            Write_Str (" range ");
4286                            Sprint_Node (Type_Low_Bound (Typ));
4287                            Write_Str (" .. ");
4288                            Sprint_Node (Type_High_Bound (Typ));
4289                         end if;
4290                      end;
4291
4292                   --  Modular integer types
4293
4294                   when E_Modular_Integer_Type =>
4295                      Write_Header;
4296                      Write_Str ("mod ");
4297                      Write_Uint_With_Col_Check (Modulus (Typ), Auto);
4298
4299                   --  Floating point types and subtypes
4300
4301                   when E_Floating_Point_Type    |
4302                        E_Floating_Point_Subtype =>
4303
4304                      Write_Header (Ekind (Typ) = E_Floating_Point_Type);
4305
4306                      if Ekind (Typ) = E_Floating_Point_Type then
4307                         Write_Str ("new ");
4308                      end if;
4309
4310                      Write_Id (Etype (Typ));
4311
4312                      if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
4313                         Write_Str (" digits ");
4314                         Write_Uint_With_Col_Check
4315                           (Digits_Value (Typ), Decimal);
4316                      end if;
4317
4318                      --  Print bounds if not different from base type
4319
4320                      declare
4321                         L  : constant Node_Id := Type_Low_Bound (Typ);
4322                         H  : constant Node_Id := Type_High_Bound (Typ);
4323                         LE : constant Node_Id := Type_Low_Bound (B);
4324                         HE : constant Node_Id := Type_High_Bound (B);
4325
4326                      begin
4327                         if Nkind (L) = N_Real_Literal
4328                           and then Nkind (H) = N_Real_Literal
4329                           and then Nkind (LE) = N_Real_Literal
4330                           and then Nkind (HE) = N_Real_Literal
4331                           and then UR_Eq (Realval (L), Realval (LE))
4332                           and then UR_Eq (Realval (H), Realval (HE))
4333                         then
4334                            null;
4335
4336                         else
4337                            Write_Str (" range ");
4338                            Sprint_Node (Type_Low_Bound (Typ));
4339                            Write_Str (" .. ");
4340                            Sprint_Node (Type_High_Bound (Typ));
4341                         end if;
4342                      end;
4343
4344                   --  Record subtypes
4345
4346                   when E_Record_Subtype | E_Record_Subtype_With_Private =>
4347                      Write_Header (False);
4348                      Write_Str ("record");
4349                      Indent_Begin;
4350
4351                      declare
4352                         C : Entity_Id;
4353                      begin
4354                         C := First_Entity (Typ);
4355                         while Present (C) loop
4356                            Write_Indent;
4357                            Write_Id (C);
4358                            Write_Str (" : ");
4359                            Write_Id (Etype (C));
4360                            Next_Entity (C);
4361                         end loop;
4362                      end;
4363
4364                      Indent_End;
4365                      Write_Indent_Str (" end record");
4366
4367                   --  Class-Wide types
4368
4369                   when E_Class_Wide_Type    |
4370                        E_Class_Wide_Subtype =>
4371                      Write_Header (Ekind (Typ) = E_Class_Wide_Type);
4372                      Write_Name_With_Col_Check (Chars (Etype (Typ)));
4373                      Write_Str ("'Class");
4374
4375                   --  Subprogram types
4376
4377                   when E_Subprogram_Type =>
4378                      Write_Header;
4379
4380                      if Etype (Typ) = Standard_Void_Type then
4381                         Write_Str ("procedure");
4382                      else
4383                         Write_Str ("function");
4384                      end if;
4385
4386                      if Present (First_Entity (Typ)) then
4387                         Write_Str (" (");
4388
4389                         declare
4390                            Param : Entity_Id;
4391
4392                         begin
4393                            Param := First_Entity (Typ);
4394                            loop
4395                               Write_Id (Param);
4396                               Write_Str (" : ");
4397
4398                               if Ekind (Param) = E_In_Out_Parameter then
4399                                  Write_Str ("in out ");
4400                               elsif Ekind (Param) = E_Out_Parameter then
4401                                  Write_Str ("out ");
4402                               end if;
4403
4404                               Write_Id (Etype (Param));
4405                               Next_Entity (Param);
4406                               exit when No (Param);
4407                               Write_Str (", ");
4408                            end loop;
4409
4410                            Write_Char (')');
4411                         end;
4412                      end if;
4413
4414                      if Etype (Typ) /= Standard_Void_Type then
4415                         Write_Str (" return ");
4416                         Write_Id (Etype (Typ));
4417                      end if;
4418
4419                   when E_String_Literal_Subtype =>
4420                      declare
4421                         LB  : constant Uint :=
4422                                 Expr_Value (String_Literal_Low_Bound (Typ));
4423                         Len : constant Uint :=
4424                                 String_Literal_Length (Typ);
4425                      begin
4426                         Write_Header (False);
4427                         Write_Str ("String (");
4428                         Write_Int (UI_To_Int (LB));
4429                         Write_Str (" .. ");
4430                         Write_Int (UI_To_Int (LB + Len) - 1);
4431                         Write_Str (");");
4432                      end;
4433
4434                   --  For all other Itypes, print ??? (fill in later)
4435
4436                   when others =>
4437                      Write_Header (True);
4438                      Write_Str ("???");
4439
4440                end case;
4441             end if;
4442
4443             --  Add terminating bracket and restore output buffer
4444
4445             Write_Char (']');
4446             Write_Eol;
4447             Restore_Output_Buffer (S);
4448          end;
4449
4450          Set_Itype_Printed (Typ);
4451       end if;
4452    end Write_Itype;
4453
4454    -------------------------------
4455    -- Write_Name_With_Col_Check --
4456    -------------------------------
4457
4458    procedure Write_Name_With_Col_Check (N : Name_Id) is
4459       J : Natural;
4460       K : Natural;
4461       L : Natural;
4462
4463    begin
4464       Get_Name_String (N);
4465
4466       --  Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4467       --  upper case letter, nnn is one or more digits and b is a lower case
4468       --  letter by C...b, so that listings do not depend on serial numbers.
4469
4470       if Debug_Flag_II then
4471          J := 1;
4472          while J < Name_Len - 1 loop
4473             if Name_Buffer (J) in 'A' .. 'Z'
4474               and then Name_Buffer (J + 1) in '0' .. '9'
4475             then
4476                K := J + 1;
4477                while K < Name_Len loop
4478                   exit when Name_Buffer (K) not in '0' .. '9';
4479                   K := K + 1;
4480                end loop;
4481
4482                if Name_Buffer (K) in 'a' .. 'z' then
4483                   L := Name_Len - K + 1;
4484
4485                   Name_Buffer (J + 4 .. J + L + 3) :=
4486                     Name_Buffer (K .. Name_Len);
4487                   Name_Buffer (J + 1 .. J + 3) := "...";
4488                   Name_Len := J + L + 3;
4489                   J := J + 5;
4490
4491                else
4492                   J := K;
4493                end if;
4494
4495             else
4496                J := J + 1;
4497             end if;
4498          end loop;
4499       end if;
4500
4501       --  Fall through for normal case
4502
4503       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
4504    end Write_Name_With_Col_Check;
4505
4506    ------------------------------------
4507    -- Write_Name_With_Col_Check_Sloc --
4508    ------------------------------------
4509
4510    procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
4511    begin
4512       Get_Name_String (N);
4513       Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
4514    end Write_Name_With_Col_Check_Sloc;
4515
4516    --------------------
4517    -- Write_Operator --
4518    --------------------
4519
4520    procedure Write_Operator (N : Node_Id; S : String) is
4521       F : Natural := S'First;
4522       T : Natural := S'Last;
4523
4524    begin
4525       --  If no overflow check, just write string out, and we are done
4526
4527       if not Do_Overflow_Check (N) then
4528          Write_Str_Sloc (S);
4529
4530       --  If overflow check, we want to surround the operator with curly
4531       --  brackets, but not include spaces within the brackets.
4532
4533       else
4534          if S (F) = ' ' then
4535             Write_Char (' ');
4536             F := F + 1;
4537          end if;
4538
4539          if S (T) = ' ' then
4540             T := T - 1;
4541          end if;
4542
4543          Write_Char ('{');
4544          Write_Str_Sloc (S (F .. T));
4545          Write_Char ('}');
4546
4547          if S (S'Last) = ' ' then
4548             Write_Char (' ');
4549          end if;
4550       end if;
4551    end Write_Operator;
4552
4553    -----------------------
4554    -- Write_Param_Specs --
4555    -----------------------
4556
4557    procedure Write_Param_Specs (N : Node_Id) is
4558       Specs         : constant List_Id := Parameter_Specifications (N);
4559       Specs_Present : constant Boolean := Is_Non_Empty_List (Specs);
4560
4561       Ent    : Entity_Id;
4562       Extras : Node_Id;
4563       Spec   : Node_Id;
4564       Formal : Node_Id;
4565
4566       Output : Boolean := False;
4567       --  Set true if we output at least one parameter
4568
4569    begin
4570       --  Write out explicit specs from Parameter_Speficiations list
4571
4572       if Specs_Present then
4573          Write_Str_With_Col_Check (" (");
4574          Output := True;
4575
4576          Spec := First (Specs);
4577          loop
4578             Sprint_Node (Spec);
4579             Formal := Defining_Identifier (Spec);
4580             Next (Spec);
4581             exit when Spec = Empty;
4582
4583             --  Add semicolon, unless we are printing original tree and the
4584             --  next specification is part of a list (but not the first element
4585             --  of that list).
4586
4587             if not Dump_Original_Only or else not Prev_Ids (Spec) then
4588                Write_Str ("; ");
4589             end if;
4590          end loop;
4591       end if;
4592
4593       --  See if we have extra formals
4594
4595       if Nkind_In (N, N_Function_Specification,
4596                       N_Procedure_Specification)
4597       then
4598          Ent := Defining_Entity (N);
4599
4600          --  Loop to write extra formals (if any)
4601
4602          if Present (Ent) and then Is_Subprogram (Ent) then
4603             Extras := Extra_Formals (Ent);
4604
4605             if Present (Extras) then
4606                if not Specs_Present then
4607                   Write_Str_With_Col_Check (" (");
4608                   Output := True;
4609                end if;
4610
4611                Formal := Extras;
4612                while Present (Formal) loop
4613                   if Specs_Present or else Formal /= Extras then
4614                      Write_Str ("; ");
4615                   end if;
4616
4617                   Write_Name_With_Col_Check (Chars (Formal));
4618                   Write_Str (" : ");
4619                   Write_Name_With_Col_Check (Chars (Etype (Formal)));
4620                   Formal := Extra_Formal (Formal);
4621                end loop;
4622             end if;
4623          end if;
4624       end if;
4625
4626       if Output then
4627          Write_Char (')');
4628       end if;
4629    end Write_Param_Specs;
4630
4631    -----------------------
4632    -- Write_Rewrite_Str --
4633    -----------------------
4634
4635    procedure Write_Rewrite_Str (S : String) is
4636    begin
4637       if not Dump_Generated_Only then
4638          if S'Length = 3 and then S = ">>>" then
4639             Write_Str (">>>");
4640          else
4641             Write_Str_With_Col_Check (S);
4642          end if;
4643       end if;
4644    end Write_Rewrite_Str;
4645
4646    -----------------------
4647    -- Write_Source_Line --
4648    -----------------------
4649
4650    procedure Write_Source_Line (L : Physical_Line_Number) is
4651       Loc : Source_Ptr;
4652       Src : Source_Buffer_Ptr;
4653       Scn : Source_Ptr;
4654
4655    begin
4656       if Dump_Source_Text then
4657          Src := Source_Text (Current_Source_File);
4658          Loc := Line_Start (L, Current_Source_File);
4659          Write_Eol;
4660
4661          --  See if line is a comment line, if not, and if not line one,
4662          --  precede with blank line.
4663
4664          Scn := Loc;
4665          while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
4666             Scn := Scn + 1;
4667          end loop;
4668
4669          if (Src (Scn) in Line_Terminator
4670               or else Src (Scn .. Scn + 1) /= "--")
4671            and then L /= 1
4672          then
4673             Write_Eol;
4674          end if;
4675
4676          --  Now write the source text of the line
4677
4678          Write_Str ("-- ");
4679          Write_Int (Int (L));
4680          Write_Str (": ");
4681
4682          while Src (Loc) not in Line_Terminator loop
4683             Write_Char (Src (Loc));
4684             Loc := Loc + 1;
4685          end loop;
4686       end if;
4687    end Write_Source_Line;
4688
4689    ------------------------
4690    -- Write_Source_Lines --
4691    ------------------------
4692
4693    procedure Write_Source_Lines (L : Physical_Line_Number) is
4694    begin
4695       while Last_Line_Printed < L loop
4696          Last_Line_Printed := Last_Line_Printed + 1;
4697          Write_Source_Line (Last_Line_Printed);
4698       end loop;
4699    end Write_Source_Lines;
4700
4701    --------------------
4702    -- Write_Str_Sloc --
4703    --------------------
4704
4705    procedure Write_Str_Sloc (S : String) is
4706    begin
4707       for J in S'Range loop
4708          Write_Char_Sloc (S (J));
4709       end loop;
4710    end Write_Str_Sloc;
4711
4712    ------------------------------
4713    -- Write_Str_With_Col_Check --
4714    ------------------------------
4715
4716    procedure Write_Str_With_Col_Check (S : String) is
4717    begin
4718       if Int (S'Last) + Column > Sprint_Line_Limit then
4719          Write_Indent_Str ("  ");
4720
4721          if S (S'First) = ' ' then
4722             Write_Str (S (S'First + 1 .. S'Last));
4723          else
4724             Write_Str (S);
4725          end if;
4726
4727       else
4728          Write_Str (S);
4729       end if;
4730    end Write_Str_With_Col_Check;
4731
4732    -----------------------------------
4733    -- Write_Str_With_Col_Check_Sloc --
4734    -----------------------------------
4735
4736    procedure Write_Str_With_Col_Check_Sloc (S : String) is
4737    begin
4738       if Int (S'Last) + Column > Sprint_Line_Limit then
4739          Write_Indent_Str ("  ");
4740
4741          if S (S'First) = ' ' then
4742             Write_Str_Sloc (S (S'First + 1 .. S'Last));
4743          else
4744             Write_Str_Sloc (S);
4745          end if;
4746
4747       else
4748          Write_Str_Sloc (S);
4749       end if;
4750    end Write_Str_With_Col_Check_Sloc;
4751
4752    ---------------------------
4753    -- Write_Subprogram_Name --
4754    ---------------------------
4755
4756    procedure Write_Subprogram_Name (N : Node_Id) is
4757    begin
4758       if not Comes_From_Source (N)
4759         and then Is_Entity_Name (N)
4760       then
4761          declare
4762             Ent : constant Entity_Id := Entity (N);
4763          begin
4764             if not In_Extended_Main_Source_Unit (Ent)
4765               and then
4766                 Is_Predefined_File_Name
4767                   (Unit_File_Name (Get_Source_Unit (Ent)))
4768             then
4769                --  Run-time routine name, output name with a preceding dollar
4770                --  making sure that we do not get a line split between them.
4771
4772                Col_Check (Length_Of_Name (Chars (Ent)) + 1);
4773                Write_Char ('$');
4774                Write_Name (Chars (Ent));
4775                return;
4776             end if;
4777          end;
4778       end if;
4779
4780       --  Normal case, not a run-time routine name
4781
4782       Sprint_Node (N);
4783    end Write_Subprogram_Name;
4784
4785    -------------------------------
4786    -- Write_Uint_With_Col_Check --
4787    -------------------------------
4788
4789    procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is
4790    begin
4791       Col_Check (UI_Decimal_Digits_Hi (U));
4792       UI_Write (U, Format);
4793    end Write_Uint_With_Col_Check;
4794
4795    ------------------------------------
4796    -- Write_Uint_With_Col_Check_Sloc --
4797    ------------------------------------
4798
4799    procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
4800    begin
4801       Col_Check (UI_Decimal_Digits_Hi (U));
4802       Set_Debug_Sloc;
4803       UI_Write (U, Format);
4804    end Write_Uint_With_Col_Check_Sloc;
4805
4806    -------------------------------------
4807    -- Write_Ureal_With_Col_Check_Sloc --
4808    -------------------------------------
4809
4810    procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
4811       D : constant Uint := Denominator (U);
4812       N : constant Uint := Numerator (U);
4813    begin
4814       Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
4815       Set_Debug_Sloc;
4816       UR_Write (U, Brackets => True);
4817    end Write_Ureal_With_Col_Check_Sloc;
4818
4819 end Sprint;