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