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-2012, 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), New_Lines => True);
 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), New_Lines => True);
 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), New_Lines => True);
 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
2698             else
2699                Write_Char ('(');
2700                Sprint_Node (Expression (Node));
2701
2702                --  Odd case, for the qualified expressions used in machine
2703                --  code the argument may be a procedure call, resulting in
2704                --  a junk semicolon before the right parent, get rid of it.
2705
2706                Write_Erase_Char (';');
2707
2708                --  Now we can add the terminating right paren
2709
2710                Write_Char (')');
2711             end if;
2712
2713          when N_Quantified_Expression =>
2714             Write_Str (" for");
2715
2716             if All_Present (Node) then
2717                Write_Str (" all ");
2718             else
2719                Write_Str (" some ");
2720             end if;
2721
2722             if Present (Iterator_Specification (Node)) then
2723                Sprint_Node (Iterator_Specification (Node));
2724             else
2725                Sprint_Node (Loop_Parameter_Specification (Node));
2726             end if;
2727
2728             Write_Str (" => ");
2729             Sprint_Node (Condition (Node));
2730
2731          when N_Raise_Constraint_Error =>
2732
2733             --  This node can be used either as a subexpression or as a
2734             --  statement form. The following test is a reasonably reliable
2735             --  way to distinguish the two cases.
2736
2737             if Is_List_Member (Node)
2738               and then Nkind (Parent (Node)) not in N_Subexpr
2739             then
2740                Write_Indent;
2741             end if;
2742
2743             Write_Str_With_Col_Check_Sloc ("[constraint_error");
2744             Write_Condition_And_Reason (Node);
2745
2746          when N_Raise_Program_Error =>
2747
2748             --  This node can be used either as a subexpression or as a
2749             --  statement form. The following test is a reasonably reliable
2750             --  way to distinguish the two cases.
2751
2752             if Is_List_Member (Node)
2753               and then Nkind (Parent (Node)) not in N_Subexpr
2754             then
2755                Write_Indent;
2756             end if;
2757
2758             Write_Str_With_Col_Check_Sloc ("[program_error");
2759             Write_Condition_And_Reason (Node);
2760
2761          when N_Raise_Storage_Error =>
2762
2763             --  This node can be used either as a subexpression or as a
2764             --  statement form. The following test is a reasonably reliable
2765             --  way to distinguish the two cases.
2766
2767             if Is_List_Member (Node)
2768               and then Nkind (Parent (Node)) not in N_Subexpr
2769             then
2770                Write_Indent;
2771             end if;
2772
2773             Write_Str_With_Col_Check_Sloc ("[storage_error");
2774             Write_Condition_And_Reason (Node);
2775
2776          when N_Raise_Statement =>
2777             Write_Indent_Str_Sloc ("raise ");
2778             Sprint_Node (Name (Node));
2779             Write_Char (';');
2780
2781          when N_Range =>
2782             Sprint_Node (Low_Bound (Node));
2783             Write_Str_Sloc (" .. ");
2784             Sprint_Node (High_Bound (Node));
2785             Update_Itype (Node);
2786
2787          when N_Range_Constraint =>
2788             Write_Str_With_Col_Check_Sloc ("range ");
2789             Sprint_Node (Range_Expression (Node));
2790
2791          when N_Real_Literal =>
2792             Write_Ureal_With_Col_Check_Sloc (Realval (Node));
2793
2794          when N_Real_Range_Specification =>
2795             Write_Str_With_Col_Check_Sloc ("range ");
2796             Sprint_Node (Low_Bound (Node));
2797             Write_Str (" .. ");
2798             Sprint_Node (High_Bound (Node));
2799
2800          when N_Record_Definition =>
2801             if Abstract_Present (Node) then
2802                Write_Str_With_Col_Check ("abstract ");
2803             end if;
2804
2805             if Tagged_Present (Node) then
2806                Write_Str_With_Col_Check ("tagged ");
2807             end if;
2808
2809             if Limited_Present (Node) then
2810                Write_Str_With_Col_Check ("limited ");
2811             end if;
2812
2813             if Null_Present (Node) then
2814                Write_Str_With_Col_Check_Sloc ("null record");
2815
2816             else
2817                Write_Str_With_Col_Check_Sloc ("record");
2818                Sprint_Node (Component_List (Node));
2819                Write_Indent_Str ("end record");
2820             end if;
2821
2822          when N_Record_Representation_Clause =>
2823             Write_Indent_Str_Sloc ("for ");
2824             Sprint_Node (Identifier (Node));
2825             Write_Str_With_Col_Check (" use record ");
2826
2827             if Present (Mod_Clause (Node)) then
2828                Sprint_Node (Mod_Clause (Node));
2829             end if;
2830
2831             Sprint_Indented_List (Component_Clauses (Node));
2832             Write_Indent_Str ("end record;");
2833
2834          when N_Reference =>
2835             Sprint_Node (Prefix (Node));
2836             Write_Str_With_Col_Check_Sloc ("'reference");
2837
2838          when N_Requeue_Statement =>
2839             Write_Indent_Str_Sloc ("requeue ");
2840             Sprint_Node (Name (Node));
2841
2842             if Abort_Present (Node) then
2843                Write_Str_With_Col_Check (" with abort");
2844             end if;
2845
2846             Write_Char (';');
2847
2848          --  Don't we want to print more detail???
2849
2850          --  Doc of this extended syntax belongs in sinfo.ads and/or
2851          --  sprint.ads ???
2852
2853          when N_SCIL_Dispatch_Table_Tag_Init =>
2854             Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
2855
2856          when N_SCIL_Dispatching_Call =>
2857             Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
2858
2859          when N_SCIL_Membership_Test =>
2860             Write_Indent_Str ("[N_SCIL_Membership_Test]");
2861
2862          when N_Simple_Return_Statement =>
2863             if Present (Expression (Node)) then
2864                Write_Indent_Str_Sloc ("return ");
2865                Sprint_Node (Expression (Node));
2866                Write_Char (';');
2867             else
2868                Write_Indent_Str_Sloc ("return;");
2869             end if;
2870
2871          when N_Selective_Accept =>
2872             Write_Indent_Str_Sloc ("select");
2873
2874             declare
2875                Alt_Node : Node_Id;
2876             begin
2877                Alt_Node := First (Select_Alternatives (Node));
2878                loop
2879                   Indent_Begin;
2880                   Sprint_Node (Alt_Node);
2881                   Indent_End;
2882                   Next (Alt_Node);
2883                   exit when No (Alt_Node);
2884                   Write_Indent_Str ("or");
2885                end loop;
2886             end;
2887
2888             if Present (Else_Statements (Node)) then
2889                Write_Indent_Str ("else");
2890                Sprint_Indented_List (Else_Statements (Node));
2891             end if;
2892
2893             Write_Indent_Str ("end select;");
2894
2895          when N_Signed_Integer_Type_Definition =>
2896             Write_Str_With_Col_Check_Sloc ("range ");
2897             Sprint_Node (Low_Bound (Node));
2898             Write_Str (" .. ");
2899             Sprint_Node (High_Bound (Node));
2900
2901          when N_Single_Protected_Declaration =>
2902             Write_Indent_Str_Sloc ("protected ");
2903             Write_Id (Defining_Identifier (Node));
2904             Write_Str (" is");
2905             Sprint_Node (Protected_Definition (Node));
2906             Write_Id (Defining_Identifier (Node));
2907             Write_Char (';');
2908
2909          when N_Single_Task_Declaration =>
2910             Write_Indent_Str_Sloc ("task ");
2911             Sprint_Node (Defining_Identifier (Node));
2912
2913             if Present (Task_Definition (Node)) then
2914                Write_Str (" is");
2915                Sprint_Node (Task_Definition (Node));
2916             end if;
2917
2918             Write_Char (';');
2919
2920          when N_Selected_Component =>
2921             Sprint_Node (Prefix (Node));
2922             Write_Char_Sloc ('.');
2923             Sprint_Node (Selector_Name (Node));
2924
2925          when N_Slice =>
2926             Set_Debug_Sloc;
2927             Sprint_Node (Prefix (Node));
2928             Write_Str_With_Col_Check (" (");
2929             Sprint_Node (Discrete_Range (Node));
2930             Write_Char (')');
2931
2932          when N_String_Literal =>
2933             if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then
2934                Write_Indent_Str ("  ");
2935             end if;
2936
2937             Set_Debug_Sloc;
2938             Write_String_Table_Entry (Strval (Node));
2939
2940          when N_Subprogram_Body =>
2941
2942             --  Output extra blank line unless we are in freeze actions
2943
2944             if Freeze_Indent = 0 then
2945                Extra_Blank_Line;
2946             end if;
2947
2948             Write_Indent;
2949
2950             if Present (Corresponding_Spec (Node)) then
2951                Sprint_Node_Sloc (Parent (Corresponding_Spec (Node)));
2952             else
2953                Sprint_Node_Sloc (Specification (Node));
2954             end if;
2955
2956             Write_Str (" is");
2957
2958             Sprint_Indented_List (Declarations (Node));
2959             Write_Indent_Str ("begin");
2960             Sprint_Node (Handled_Statement_Sequence (Node));
2961
2962             Write_Indent_Str ("end ");
2963
2964             Sprint_End_Label
2965               (Handled_Statement_Sequence (Node),
2966                  Defining_Unit_Name (Specification (Node)));
2967             Write_Char (';');
2968
2969             if Is_List_Member (Node)
2970               and then Present (Next (Node))
2971               and then Nkind (Next (Node)) /= N_Subprogram_Body
2972             then
2973                Write_Indent;
2974             end if;
2975
2976          when N_Subprogram_Body_Stub =>
2977             Write_Indent;
2978             Sprint_Node_Sloc (Specification (Node));
2979             Write_Str_With_Col_Check (" is separate;");
2980
2981          when N_Subprogram_Declaration =>
2982             Write_Indent;
2983             Sprint_Node_Sloc (Specification (Node));
2984
2985             if Nkind (Specification (Node)) = N_Procedure_Specification
2986               and then Null_Present (Specification (Node))
2987             then
2988                Write_Str_With_Col_Check (" is null");
2989             end if;
2990
2991             Write_Char (';');
2992
2993          when N_Subprogram_Info =>
2994             Sprint_Node (Identifier (Node));
2995             Write_Str_With_Col_Check_Sloc ("'subprogram_info");
2996
2997          when N_Subprogram_Renaming_Declaration =>
2998             Write_Indent;
2999             Sprint_Node (Specification (Node));
3000             Write_Str_With_Col_Check_Sloc (" renames ");
3001             Sprint_Node (Name (Node));
3002             Write_Char (';');
3003
3004          when N_Subtype_Declaration =>
3005             Write_Indent_Str_Sloc ("subtype ");
3006             Sprint_Node (Defining_Identifier (Node));
3007             Write_Str (" is ");
3008
3009             --  Ada 2005 (AI-231)
3010
3011             if Null_Exclusion_Present (Node) then
3012                Write_Str ("not null ");
3013             end if;
3014
3015             Sprint_Node (Subtype_Indication (Node));
3016             Write_Char (';');
3017
3018          when N_Subtype_Indication =>
3019             Sprint_Node_Sloc (Subtype_Mark (Node));
3020             Write_Char (' ');
3021             Sprint_Node (Constraint (Node));
3022
3023          when N_Subunit =>
3024             Write_Indent_Str_Sloc ("separate (");
3025             Sprint_Node (Name (Node));
3026             Write_Char (')');
3027             Extra_Blank_Line;
3028             Sprint_Node (Proper_Body (Node));
3029
3030          when N_Task_Body =>
3031             Write_Indent_Str_Sloc ("task body ");
3032             Write_Id (Defining_Identifier (Node));
3033             Write_Str (" is");
3034             Sprint_Indented_List (Declarations (Node));
3035             Write_Indent_Str ("begin");
3036             Sprint_Node (Handled_Statement_Sequence (Node));
3037             Write_Indent_Str ("end ");
3038             Sprint_End_Label
3039               (Handled_Statement_Sequence (Node), Defining_Identifier (Node));
3040             Write_Char (';');
3041
3042          when N_Task_Body_Stub =>
3043             Write_Indent_Str_Sloc ("task body ");
3044             Write_Id (Defining_Identifier (Node));
3045             Write_Str_With_Col_Check (" is separate;");
3046
3047          when N_Task_Definition =>
3048             Set_Debug_Sloc;
3049             Sprint_Indented_List (Visible_Declarations (Node));
3050
3051             if Present (Private_Declarations (Node)) then
3052                Write_Indent_Str ("private");
3053                Sprint_Indented_List (Private_Declarations (Node));
3054             end if;
3055
3056             Write_Indent_Str ("end ");
3057             Sprint_End_Label (Node, Defining_Identifier (Parent (Node)));
3058
3059          when N_Task_Type_Declaration =>
3060             Write_Indent_Str_Sloc ("task type ");
3061             Sprint_Node (Defining_Identifier (Node));
3062             Write_Discr_Specs (Node);
3063
3064             if Present (Interface_List (Node)) then
3065                Write_Str (" is new ");
3066                Sprint_And_List (Interface_List (Node));
3067             end if;
3068
3069             if Present (Task_Definition (Node)) then
3070                if No (Interface_List (Node)) then
3071                   Write_Str (" is");
3072                else
3073                   Write_Str (" with ");
3074                end if;
3075
3076                Sprint_Node (Task_Definition (Node));
3077             end if;
3078
3079             Write_Char (';');
3080
3081          when N_Terminate_Alternative =>
3082             Sprint_Node_List (Pragmas_Before (Node));
3083             Write_Indent;
3084
3085             if Present (Condition (Node)) then
3086                Write_Str_With_Col_Check ("when ");
3087                Sprint_Node (Condition (Node));
3088                Write_Str (" => ");
3089             end if;
3090
3091             Write_Str_With_Col_Check_Sloc ("terminate;");
3092             Sprint_Node_List (Pragmas_After (Node));
3093
3094          when N_Timed_Entry_Call =>
3095             Write_Indent_Str_Sloc ("select");
3096             Indent_Begin;
3097             Sprint_Node (Entry_Call_Alternative (Node));
3098             Indent_End;
3099             Write_Indent_Str ("or");
3100             Indent_Begin;
3101             Sprint_Node (Delay_Alternative (Node));
3102             Indent_End;
3103             Write_Indent_Str ("end select;");
3104
3105          when N_Triggering_Alternative =>
3106             Sprint_Node_List (Pragmas_Before (Node));
3107             Sprint_Node_Sloc (Triggering_Statement (Node));
3108             Sprint_Node_List (Statements (Node));
3109
3110          when N_Type_Conversion =>
3111             Set_Debug_Sloc;
3112             Sprint_Node (Subtype_Mark (Node));
3113             Col_Check (4);
3114
3115             if Conversion_OK (Node) then
3116                Write_Char ('?');
3117             end if;
3118
3119             if Float_Truncate (Node) then
3120                Write_Char ('^');
3121             end if;
3122
3123             if Rounded_Result (Node) then
3124                Write_Char ('@');
3125             end if;
3126
3127             Write_Char ('(');
3128             Sprint_Node (Expression (Node));
3129             Write_Char (')');
3130
3131          when N_Unchecked_Expression =>
3132             Col_Check (10);
3133             Write_Str ("`(");
3134             Sprint_Node_Sloc (Expression (Node));
3135             Write_Char (')');
3136
3137          when N_Unchecked_Type_Conversion =>
3138             Sprint_Node (Subtype_Mark (Node));
3139             Write_Char ('!');
3140             Write_Str_With_Col_Check ("(");
3141             Sprint_Node_Sloc (Expression (Node));
3142             Write_Char (')');
3143
3144          when N_Unconstrained_Array_Definition =>
3145             Write_Str_With_Col_Check_Sloc ("array (");
3146
3147             declare
3148                Node1 : Node_Id;
3149             begin
3150                Node1 := First (Subtype_Marks (Node));
3151                loop
3152                   Sprint_Node (Node1);
3153                   Write_Str_With_Col_Check (" range <>");
3154                   Next (Node1);
3155                   exit when Node1 = Empty;
3156                   Write_Str (", ");
3157                end loop;
3158             end;
3159
3160             Write_Str (") of ");
3161             Sprint_Node (Component_Definition (Node));
3162
3163          when N_Unused_At_Start | N_Unused_At_End =>
3164             Write_Indent_Str ("***** Error, unused node encountered *****");
3165             Write_Eol;
3166
3167          when N_Use_Package_Clause =>
3168             Write_Indent_Str_Sloc ("use ");
3169             Sprint_Comma_List (Names (Node));
3170             Write_Char (';');
3171
3172          when N_Use_Type_Clause =>
3173             Write_Indent_Str_Sloc ("use type ");
3174             Sprint_Comma_List (Subtype_Marks (Node));
3175             Write_Char (';');
3176
3177          when N_Validate_Unchecked_Conversion =>
3178             Write_Indent_Str_Sloc ("validate unchecked_conversion (");
3179             Sprint_Node (Source_Type (Node));
3180             Write_Str (", ");
3181             Sprint_Node (Target_Type (Node));
3182             Write_Str (");");
3183
3184          when N_Variant =>
3185             Write_Indent_Str_Sloc ("when ");
3186             Sprint_Bar_List (Discrete_Choices (Node));
3187             Write_Str (" => ");
3188             Sprint_Node (Component_List (Node));
3189
3190          when N_Variant_Part =>
3191             Indent_Begin;
3192             Write_Indent_Str_Sloc ("case ");
3193             Sprint_Node (Name (Node));
3194             Write_Str (" is ");
3195             Sprint_Indented_List (Variants (Node));
3196             Write_Indent_Str ("end case");
3197             Indent_End;
3198
3199          when N_With_Clause =>
3200
3201             --  Special test, if we are dumping the original tree only,
3202             --  then we want to eliminate the bogus with clauses that
3203             --  correspond to the non-existent children of Text_IO.
3204
3205             if Dump_Original_Only
3206               and then Is_Text_IO_Kludge_Unit (Name (Node))
3207             then
3208                null;
3209
3210             --  Normal case, output the with clause
3211
3212             else
3213                if First_Name (Node) or else not Dump_Original_Only then
3214
3215                   --  Ada 2005 (AI-50217): Print limited with_clauses
3216
3217                   if Private_Present (Node) and Limited_Present (Node) then
3218                      Write_Indent_Str ("limited private with ");
3219
3220                   elsif Private_Present (Node) then
3221                      Write_Indent_Str ("private with ");
3222
3223                   elsif Limited_Present (Node) then
3224                      Write_Indent_Str ("limited with ");
3225
3226                   else
3227                      Write_Indent_Str ("with ");
3228                   end if;
3229
3230                else
3231                   Write_Str (", ");
3232                end if;
3233
3234                Sprint_Node_Sloc (Name (Node));
3235
3236                if Last_Name (Node) or else not Dump_Original_Only then
3237                   Write_Char (';');
3238                end if;
3239             end if;
3240       end case;
3241
3242       --  Print aspects, except for special case of package declaration,
3243       --  where the aspects are printed inside the package specification.
3244
3245       if Has_Aspects (Node) and Nkind (Node) /= N_Package_Declaration then
3246          Sprint_Aspect_Specifications (Node, Semicolon => True);
3247       end if;
3248
3249       if Nkind (Node) in N_Subexpr
3250         and then Do_Range_Check (Node)
3251       then
3252          Write_Str ("}");
3253       end if;
3254
3255       for J in 1 .. Paren_Count (Node) loop
3256          Write_Char (')');
3257       end loop;
3258
3259       Dump_Node := Save_Dump_Node;
3260    end Sprint_Node_Actual;
3261
3262    ----------------------
3263    -- Sprint_Node_List --
3264    ----------------------
3265
3266    procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is
3267       Node : Node_Id;
3268
3269    begin
3270       if Is_Non_Empty_List (List) then
3271          Node := First (List);
3272
3273          loop
3274             Sprint_Node (Node);
3275             Next (Node);
3276             exit when Node = Empty;
3277          end loop;
3278       end if;
3279
3280       if New_Lines and then Column /= 1 then
3281          Write_Eol;
3282       end if;
3283    end Sprint_Node_List;
3284
3285    ----------------------
3286    -- Sprint_Node_Sloc --
3287    ----------------------
3288
3289    procedure Sprint_Node_Sloc (Node : Node_Id) is
3290    begin
3291       Sprint_Node (Node);
3292
3293       if Debug_Generated_Code and then Present (Dump_Node) then
3294          Set_Sloc (Dump_Node, Sloc (Node));
3295          Dump_Node := Empty;
3296       end if;
3297    end Sprint_Node_Sloc;
3298
3299    ---------------------
3300    -- Sprint_Opt_Node --
3301    ---------------------
3302
3303    procedure Sprint_Opt_Node (Node : Node_Id) is
3304    begin
3305       if Present (Node) then
3306          Write_Char (' ');
3307          Sprint_Node (Node);
3308       end if;
3309    end Sprint_Opt_Node;
3310
3311    --------------------------
3312    -- Sprint_Opt_Node_List --
3313    --------------------------
3314
3315    procedure Sprint_Opt_Node_List (List : List_Id) is
3316    begin
3317       if Present (List) then
3318          Sprint_Node_List (List);
3319       end if;
3320    end Sprint_Opt_Node_List;
3321
3322    ---------------------------------
3323    -- Sprint_Opt_Paren_Comma_List --
3324    ---------------------------------
3325
3326    procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
3327    begin
3328       if Is_Non_Empty_List (List) then
3329          Write_Char (' ');
3330          Sprint_Paren_Comma_List (List);
3331       end if;
3332    end Sprint_Opt_Paren_Comma_List;
3333
3334    -----------------------------
3335    -- Sprint_Paren_Comma_List --
3336    -----------------------------
3337
3338    procedure Sprint_Paren_Comma_List (List : List_Id) is
3339       N           : Node_Id;
3340       Node_Exists : Boolean := False;
3341
3342    begin
3343
3344       if Is_Non_Empty_List (List) then
3345
3346          if Dump_Original_Only then
3347             N := First (List);
3348             while Present (N) loop
3349                if not Is_Rewrite_Insertion (N) then
3350                   Node_Exists := True;
3351                   exit;
3352                end if;
3353
3354                Next (N);
3355             end loop;
3356
3357             if not Node_Exists then
3358                return;
3359             end if;
3360          end if;
3361
3362          Write_Str_With_Col_Check ("(");
3363          Sprint_Comma_List (List);
3364          Write_Char (')');
3365       end if;
3366    end Sprint_Paren_Comma_List;
3367
3368    ----------------------
3369    -- Sprint_Right_Opnd --
3370    ----------------------
3371
3372    procedure Sprint_Right_Opnd (N : Node_Id) is
3373       Opnd : constant Node_Id := Right_Opnd (N);
3374
3375    begin
3376       if Paren_Count (Opnd) /= 0
3377         or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N))
3378       then
3379          Sprint_Node (Opnd);
3380
3381       else
3382          Write_Char ('(');
3383          Sprint_Node (Opnd);
3384          Write_Char (')');
3385       end if;
3386    end Sprint_Right_Opnd;
3387
3388    ------------------
3389    -- Update_Itype --
3390    ------------------
3391
3392    procedure Update_Itype (Node : Node_Id) is
3393    begin
3394       if Present (Etype (Node))
3395         and then Is_Itype (Etype (Node))
3396         and then Debug_Generated_Code
3397       then
3398          Set_Sloc (Etype (Node), Sloc (Node));
3399       end if;
3400    end Update_Itype;
3401
3402    ---------------------
3403    -- Write_Char_Sloc --
3404    ---------------------
3405
3406    procedure Write_Char_Sloc (C : Character) is
3407    begin
3408       if Debug_Generated_Code and then C /= ' ' then
3409          Set_Debug_Sloc;
3410       end if;
3411
3412       Write_Char (C);
3413    end Write_Char_Sloc;
3414
3415    --------------------------------
3416    -- Write_Condition_And_Reason --
3417    --------------------------------
3418
3419    procedure Write_Condition_And_Reason (Node : Node_Id) is
3420       Cond  : constant Node_Id := Condition (Node);
3421       Image : constant String  := RT_Exception_Code'Image
3422                                     (RT_Exception_Code'Val
3423                                        (UI_To_Int (Reason (Node))));
3424
3425    begin
3426       if Present (Cond) then
3427
3428          --  If condition is a single entity, or NOT with a single entity,
3429          --  output all on one line, since it will likely fit just fine.
3430
3431          if Is_Entity_Name (Cond)
3432            or else (Nkind (Cond) = N_Op_Not
3433                      and then Is_Entity_Name (Right_Opnd (Cond)))
3434          then
3435             Write_Str_With_Col_Check (" when ");
3436             Sprint_Node (Cond);
3437             Write_Char (' ');
3438
3439             --  Otherwise for more complex condition, multiple lines
3440
3441          else
3442             Write_Str_With_Col_Check (" when");
3443             Indent := Indent + 2;
3444             Write_Indent;
3445             Sprint_Node (Cond);
3446             Write_Indent;
3447             Indent := Indent - 2;
3448          end if;
3449
3450       --  If no condition, just need a space (all on one line)
3451
3452       else
3453          Write_Char (' ');
3454       end if;
3455
3456       --  Write the reason
3457
3458       Write_Char ('"');
3459
3460       for J in 4 .. Image'Last loop
3461          if Image (J) = '_' then
3462             Write_Char (' ');
3463          else
3464             Write_Char (Fold_Lower (Image (J)));
3465          end if;
3466       end loop;
3467
3468       Write_Str ("""]");
3469    end Write_Condition_And_Reason;
3470
3471    --------------------------------
3472    -- Write_Corresponding_Source --
3473    --------------------------------
3474
3475    procedure Write_Corresponding_Source (S : String) is
3476       Loc : Source_Ptr;
3477       Src : Source_Buffer_Ptr;
3478
3479    begin
3480       --  Ignore if not in dump source text mode, or if in freeze actions
3481
3482       if Dump_Source_Text and then Freeze_Indent = 0 then
3483
3484          --  Ignore null string
3485
3486          if S = "" then
3487             return;
3488          end if;
3489
3490          --  Ignore space or semicolon at end of given string
3491
3492          if S (S'Last) = ' ' or else S (S'Last) = ';' then
3493             Write_Corresponding_Source (S (S'First .. S'Last - 1));
3494             return;
3495          end if;
3496
3497          --  Loop to look at next lines not yet printed in source file
3498
3499          for L in
3500            Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File)
3501          loop
3502             Src := Source_Text (Current_Source_File);
3503             Loc := Line_Start (L, Current_Source_File);
3504
3505             --  If comment, keep looking
3506
3507             if Src (Loc .. Loc + 1) = "--" then
3508                null;
3509
3510             --  Search to first non-blank
3511
3512             else
3513                while Src (Loc) not in Line_Terminator loop
3514
3515                   --  Non-blank found
3516
3517                   if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then
3518
3519                      --  Loop through characters in string to see if we match
3520
3521                      for J in S'Range loop
3522
3523                         --  If mismatch, then not the case we are looking for
3524
3525                         if Src (Loc) /= S (J) then
3526                            return;
3527                         end if;
3528
3529                         Loc := Loc + 1;
3530                      end loop;
3531
3532                      --  If we fall through, string matched, if white space or
3533                      --  semicolon after the matched string, this is the case
3534                      --  we are looking for.
3535
3536                      if Src (Loc) in Line_Terminator
3537                        or else Src (Loc) = ' '
3538                        or else Src (Loc) = ASCII.HT
3539                        or else Src (Loc) = ';'
3540                      then
3541                         --  So output source lines up to and including this one
3542
3543                         Write_Source_Lines (L);
3544                         return;
3545                      end if;
3546                   end if;
3547
3548                   Loc := Loc + 1;
3549                end loop;
3550             end if;
3551
3552          --  Line was all blanks, or a comment line, keep looking
3553
3554          end loop;
3555       end if;
3556    end Write_Corresponding_Source;
3557
3558    -----------------------
3559    -- Write_Discr_Specs --
3560    -----------------------
3561
3562    procedure Write_Discr_Specs (N : Node_Id) is
3563       Specs : List_Id;
3564       Spec  : Node_Id;
3565
3566    begin
3567       Specs := Discriminant_Specifications (N);
3568
3569       if Present (Specs) then
3570          Write_Str_With_Col_Check (" (");
3571          Spec := First (Specs);
3572
3573          loop
3574             Sprint_Node (Spec);
3575             Next (Spec);
3576             exit when Spec = Empty;
3577
3578             --  Add semicolon, unless we are printing original tree and the
3579             --  next specification is part of a list (but not the first
3580             --  element of that list)
3581
3582             if not Dump_Original_Only or else not Prev_Ids (Spec) then
3583                Write_Str ("; ");
3584             end if;
3585          end loop;
3586
3587          Write_Char (')');
3588       end if;
3589    end Write_Discr_Specs;
3590
3591    -----------------
3592    -- Write_Ekind --
3593    -----------------
3594
3595    procedure Write_Ekind (E : Entity_Id) is
3596       S : constant String := Entity_Kind'Image (Ekind (E));
3597
3598    begin
3599       Name_Len := S'Length;
3600       Name_Buffer (1 .. Name_Len) := S;
3601       Set_Casing (Mixed_Case);
3602       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3603    end Write_Ekind;
3604
3605    --------------
3606    -- Write_Id --
3607    --------------
3608
3609    procedure Write_Id (N : Node_Id) is
3610    begin
3611       --  Deal with outputting Itype
3612
3613       --  Note: if we are printing the full tree with -gnatds, then we may
3614       --  end up picking up the Associated_Node link from a generic template
3615       --  here which overlaps the Entity field, but as documented, Write_Itype
3616       --  is defended against junk calls.
3617
3618       if Nkind (N) in N_Entity then
3619          Write_Itype (N);
3620       elsif Nkind (N) in N_Has_Entity then
3621          Write_Itype (Entity (N));
3622       end if;
3623
3624       --  Case of a defining identifier
3625
3626       if Nkind (N) = N_Defining_Identifier then
3627
3628          --  If defining identifier has an interface name (and no
3629          --  address clause), then we output the interface name.
3630
3631          if (Is_Imported (N) or else Is_Exported (N))
3632            and then Present (Interface_Name (N))
3633            and then No (Address_Clause (N))
3634          then
3635             String_To_Name_Buffer (Strval (Interface_Name (N)));
3636             Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3637
3638          --  If no interface name (or inactive because there was
3639          --  an address clause), then just output the Chars name.
3640
3641          else
3642             Write_Name_With_Col_Check (Chars (N));
3643          end if;
3644
3645       --  Case of selector of an expanded name where the expanded name
3646       --  has an associated entity, output this entity. Check that the
3647       --  entity or associated node is of the right kind, see above.
3648
3649       elsif Nkind (Parent (N)) = N_Expanded_Name
3650         and then Selector_Name (Parent (N)) = N
3651         and then Present (Entity_Or_Associated_Node (Parent (N)))
3652         and then Nkind (Entity (Parent (N))) in N_Entity
3653       then
3654          Write_Id (Entity (Parent (N)));
3655
3656       --  For any other node with an associated entity, output it
3657
3658       elsif Nkind (N) in N_Has_Entity
3659         and then Present (Entity_Or_Associated_Node (N))
3660         and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
3661       then
3662          Write_Id (Entity (N));
3663
3664       --  All other cases, we just print the Chars field
3665
3666       else
3667          Write_Name_With_Col_Check (Chars (N));
3668       end if;
3669    end Write_Id;
3670
3671    -----------------------
3672    -- Write_Identifiers --
3673    -----------------------
3674
3675    function Write_Identifiers (Node : Node_Id) return Boolean is
3676    begin
3677       Sprint_Node (Defining_Identifier (Node));
3678       Update_Itype (Defining_Identifier (Node));
3679
3680       --  The remainder of the declaration must be printed unless we are
3681       --  printing the original tree and this is not the last identifier
3682
3683       return
3684          not Dump_Original_Only or else not More_Ids (Node);
3685
3686    end Write_Identifiers;
3687
3688    ------------------------
3689    -- Write_Implicit_Def --
3690    ------------------------
3691
3692    procedure Write_Implicit_Def (E : Entity_Id) is
3693       Ind : Node_Id;
3694
3695    begin
3696       case Ekind (E) is
3697          when E_Array_Subtype =>
3698             Write_Str_With_Col_Check ("subtype ");
3699             Write_Id (E);
3700             Write_Str_With_Col_Check (" is ");
3701             Write_Id (Base_Type (E));
3702             Write_Str_With_Col_Check (" (");
3703
3704             Ind := First_Index (E);
3705             while Present (Ind) loop
3706                Sprint_Node (Ind);
3707                Next_Index (Ind);
3708
3709                if Present (Ind) then
3710                   Write_Str (", ");
3711                end if;
3712             end loop;
3713
3714             Write_Str (");");
3715
3716          when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
3717             Write_Str_With_Col_Check ("subtype ");
3718             Write_Id (E);
3719             Write_Str (" is ");
3720             Write_Id (Etype (E));
3721             Write_Str_With_Col_Check (" range ");
3722             Sprint_Node (Scalar_Range (E));
3723             Write_Str (";");
3724
3725          when others =>
3726             Write_Str_With_Col_Check ("type ");
3727             Write_Id (E);
3728             Write_Str_With_Col_Check (" is <");
3729             Write_Ekind (E);
3730             Write_Str (">;");
3731       end case;
3732
3733    end Write_Implicit_Def;
3734
3735    ------------------
3736    -- Write_Indent --
3737    ------------------
3738
3739    procedure Write_Indent is
3740       Loc : constant Source_Ptr := Sloc (Dump_Node);
3741
3742    begin
3743       if Indent_Annull_Flag then
3744          Indent_Annull_Flag := False;
3745       else
3746          --  Deal with Dump_Source_Text output. Note that we ignore implicit
3747          --  label declarations, since they typically have the sloc of the
3748          --  corresponding label, which really messes up the -gnatL output.
3749
3750          if Dump_Source_Text
3751            and then Loc > No_Location
3752            and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration
3753          then
3754             if Get_Source_File_Index (Loc) = Current_Source_File then
3755                Write_Source_Lines
3756                  (Get_Physical_Line_Number (Sloc (Dump_Node)));
3757             end if;
3758          end if;
3759
3760          Write_Eol;
3761
3762          for J in 1 .. Indent loop
3763             Write_Char (' ');
3764          end loop;
3765       end if;
3766    end Write_Indent;
3767
3768    ------------------------------
3769    -- Write_Indent_Identifiers --
3770    ------------------------------
3771
3772    function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
3773    begin
3774       --  We need to start a new line for every node, except in the case
3775       --  where we are printing the original tree and this is not the first
3776       --  defining identifier in the list.
3777
3778       if not Dump_Original_Only or else not Prev_Ids (Node) then
3779          Write_Indent;
3780
3781       --  If printing original tree and this is not the first defining
3782       --  identifier in the list, then the previous call to this procedure
3783       --  printed only the name, and we add a comma to separate the names.
3784
3785       else
3786          Write_Str (", ");
3787       end if;
3788
3789       Sprint_Node (Defining_Identifier (Node));
3790
3791       --  The remainder of the declaration must be printed unless we are
3792       --  printing the original tree and this is not the last identifier
3793
3794       return
3795          not Dump_Original_Only or else not More_Ids (Node);
3796    end Write_Indent_Identifiers;
3797
3798    -----------------------------------
3799    -- Write_Indent_Identifiers_Sloc --
3800    -----------------------------------
3801
3802    function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
3803    begin
3804       --  We need to start a new line for every node, except in the case
3805       --  where we are printing the original tree and this is not the first
3806       --  defining identifier in the list.
3807
3808       if not Dump_Original_Only or else not Prev_Ids (Node) then
3809          Write_Indent;
3810
3811       --  If printing original tree and this is not the first defining
3812       --  identifier in the list, then the previous call to this procedure
3813       --  printed only the name, and we add a comma to separate the names.
3814
3815       else
3816          Write_Str (", ");
3817       end if;
3818
3819       Set_Debug_Sloc;
3820       Sprint_Node (Defining_Identifier (Node));
3821
3822       --  The remainder of the declaration must be printed unless we are
3823       --  printing the original tree and this is not the last identifier
3824
3825       return not Dump_Original_Only or else not More_Ids (Node);
3826    end Write_Indent_Identifiers_Sloc;
3827
3828    ----------------------
3829    -- Write_Indent_Str --
3830    ----------------------
3831
3832    procedure Write_Indent_Str (S : String) is
3833    begin
3834       Write_Corresponding_Source (S);
3835       Write_Indent;
3836       Write_Str (S);
3837    end Write_Indent_Str;
3838
3839    ---------------------------
3840    -- Write_Indent_Str_Sloc --
3841    ---------------------------
3842
3843    procedure Write_Indent_Str_Sloc (S : String) is
3844    begin
3845       Write_Corresponding_Source (S);
3846       Write_Indent;
3847       Write_Str_Sloc (S);
3848    end Write_Indent_Str_Sloc;
3849
3850    -----------------
3851    -- Write_Itype --
3852    -----------------
3853
3854    procedure Write_Itype (Typ : Entity_Id) is
3855
3856       procedure Write_Header (T : Boolean := True);
3857       --  Write type if T is True, subtype if T is false
3858
3859       ------------------
3860       -- Write_Header --
3861       ------------------
3862
3863       procedure Write_Header (T : Boolean := True) is
3864       begin
3865          if T then
3866             Write_Str ("[type ");
3867          else
3868             Write_Str ("[subtype ");
3869          end if;
3870
3871          Write_Name_With_Col_Check (Chars (Typ));
3872          Write_Str (" is ");
3873       end Write_Header;
3874
3875    --  Start of processing for Write_Itype
3876
3877    begin
3878       if Nkind (Typ) in N_Entity
3879         and then Is_Itype (Typ)
3880         and then not Itype_Printed (Typ)
3881       then
3882          --  Itype to be printed
3883
3884          declare
3885             B : constant Node_Id := Etype (Typ);
3886             X : Node_Id;
3887             P : constant Node_Id := Parent (Typ);
3888
3889             S : constant Saved_Output_Buffer := Save_Output_Buffer;
3890             --  Save current output buffer
3891
3892             Old_Sloc : Source_Ptr;
3893             --  Save sloc of related node, so it is not modified when
3894             --  printing with -gnatD.
3895
3896          begin
3897             --  Write indentation at start of line
3898
3899             for J in 1 .. Indent loop
3900                Write_Char (' ');
3901             end loop;
3902
3903             --  If we have a constructed declaration for the itype, print it
3904
3905             if Present (P)
3906               and then Nkind (P) in N_Declaration
3907               and then Defining_Entity (P) = Typ
3908             then
3909                --  We must set Itype_Printed true before the recursive call to
3910                --  print the node, otherwise we get an infinite recursion!
3911
3912                Set_Itype_Printed (Typ, True);
3913
3914                --  Write the declaration enclosed in [], avoiding new line
3915                --  at start of declaration, and semicolon at end.
3916
3917                --  Note: The itype may be imported from another unit, in which
3918                --  case we do not want to modify the Sloc of the declaration.
3919                --  Otherwise the itype may appear to be in the current unit,
3920                --  and the back-end will reject a reference out of scope.
3921
3922                Write_Char ('[');
3923                Indent_Annull_Flag := True;
3924                Old_Sloc := Sloc (P);
3925                Sprint_Node (P);
3926                Set_Sloc (P, Old_Sloc);
3927                Write_Erase_Char (';');
3928
3929             --  If no constructed declaration, then we have to concoct the
3930             --  source corresponding to the type entity that we have at hand.
3931
3932             else
3933                case Ekind (Typ) is
3934
3935                   --  Access types and subtypes
3936
3937                   when Access_Kind =>
3938                      Write_Header (Ekind (Typ) = E_Access_Type);
3939
3940                      if Can_Never_Be_Null (Typ) then
3941                         Write_Str ("not null ");
3942                      end if;
3943
3944                      Write_Str ("access ");
3945
3946                      if Is_Access_Constant (Typ) then
3947                         Write_Str ("constant ");
3948                      end if;
3949
3950                      Write_Id (Directly_Designated_Type (Typ));
3951
3952                   --  Array types and string types
3953
3954                   when E_Array_Type | E_String_Type =>
3955                      Write_Header;
3956                      Write_Str ("array (");
3957
3958                      X := First_Index (Typ);
3959                      loop
3960                         Sprint_Node (X);
3961
3962                         if not Is_Constrained (Typ) then
3963                            Write_Str (" range <>");
3964                         end if;
3965
3966                         Next_Index (X);
3967                         exit when No (X);
3968                         Write_Str (", ");
3969                      end loop;
3970
3971                      Write_Str (") of ");
3972                      X := Component_Type (Typ);
3973
3974                      --  Preserve sloc of component type, which is defined
3975                      --  elsewhere than the itype (see comment above).
3976
3977                      Old_Sloc := Sloc (X);
3978                      Sprint_Node (X);
3979                      Set_Sloc (X, Old_Sloc);
3980
3981                      --  Array subtypes and string subtypes.
3982                      --  Preserve Sloc of index subtypes, as above.
3983
3984                   when E_Array_Subtype | E_String_Subtype =>
3985                      Write_Header (False);
3986                      Write_Id (Etype (Typ));
3987                      Write_Str (" (");
3988
3989                      X := First_Index (Typ);
3990                      loop
3991                         Old_Sloc := Sloc (X);
3992                         Sprint_Node (X);
3993                         Set_Sloc (X, Old_Sloc);
3994                         Next_Index (X);
3995                         exit when No (X);
3996                         Write_Str (", ");
3997                      end loop;
3998
3999                      Write_Char (')');
4000
4001                   --  Signed integer types, and modular integer subtypes,
4002                   --  and also enumeration subtypes.
4003
4004                   when E_Signed_Integer_Type     |
4005                        E_Signed_Integer_Subtype  |
4006                        E_Modular_Integer_Subtype |
4007                        E_Enumeration_Subtype     =>
4008
4009                      Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
4010
4011                      if Ekind (Typ) = E_Signed_Integer_Type then
4012                         Write_Str ("new ");
4013                      end if;
4014
4015                      Write_Id (B);
4016
4017                      --  Print bounds if different from base type
4018
4019                      declare
4020                         L  : constant Node_Id := Type_Low_Bound (Typ);
4021                         H  : constant Node_Id := Type_High_Bound (Typ);
4022                         LE : Node_Id;
4023                         HE : Node_Id;
4024
4025                      begin
4026                         --  B can either be a scalar type, in which case the
4027                         --  declaration of Typ may constrain it with different
4028                         --  bounds, or a private type, in which case we know
4029                         --  that the declaration of Typ cannot have a scalar
4030                         --  constraint.
4031
4032                         if Is_Scalar_Type (B) then
4033                            LE := Type_Low_Bound (B);
4034                            HE := Type_High_Bound (B);
4035                         else
4036                            LE := Empty;
4037                            HE := Empty;
4038                         end if;
4039
4040                         if No (LE)
4041                           or else (True
4042                             and then Nkind (L) = N_Integer_Literal
4043                             and then Nkind (H) = N_Integer_Literal
4044                             and then Nkind (LE) = N_Integer_Literal
4045                             and then Nkind (HE) = N_Integer_Literal
4046                             and then UI_Eq (Intval (L), Intval (LE))
4047                             and then UI_Eq (Intval (H), Intval (HE)))
4048                         then
4049                            null;
4050
4051                         else
4052                            Write_Str (" range ");
4053                            Sprint_Node (Type_Low_Bound (Typ));
4054                            Write_Str (" .. ");
4055                            Sprint_Node (Type_High_Bound (Typ));
4056                         end if;
4057                      end;
4058
4059                   --  Modular integer types
4060
4061                   when E_Modular_Integer_Type =>
4062                      Write_Header;
4063                      Write_Str (" mod ");
4064                      Write_Uint_With_Col_Check (Modulus (Typ), Auto);
4065
4066                   --  Floating point types and subtypes
4067
4068                   when E_Floating_Point_Type    |
4069                        E_Floating_Point_Subtype =>
4070
4071                      Write_Header (Ekind (Typ) = E_Floating_Point_Type);
4072
4073                      if Ekind (Typ) = E_Floating_Point_Type then
4074                         Write_Str ("new ");
4075                      end if;
4076
4077                      Write_Id (Etype (Typ));
4078
4079                      if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
4080                         Write_Str (" digits ");
4081                         Write_Uint_With_Col_Check
4082                           (Digits_Value (Typ), Decimal);
4083                      end if;
4084
4085                      --  Print bounds if not different from base type
4086
4087                      declare
4088                         L  : constant Node_Id := Type_Low_Bound (Typ);
4089                         H  : constant Node_Id := Type_High_Bound (Typ);
4090                         LE : constant Node_Id := Type_Low_Bound (B);
4091                         HE : constant Node_Id := Type_High_Bound (B);
4092
4093                      begin
4094                         if Nkind (L) = N_Real_Literal
4095                           and then Nkind (H) = N_Real_Literal
4096                           and then Nkind (LE) = N_Real_Literal
4097                           and then Nkind (HE) = N_Real_Literal
4098                           and then UR_Eq (Realval (L), Realval (LE))
4099                           and then UR_Eq (Realval (H), Realval (HE))
4100                         then
4101                            null;
4102
4103                         else
4104                            Write_Str (" range ");
4105                            Sprint_Node (Type_Low_Bound (Typ));
4106                            Write_Str (" .. ");
4107                            Sprint_Node (Type_High_Bound (Typ));
4108                         end if;
4109                      end;
4110
4111                   --  Record subtypes
4112
4113                   when E_Record_Subtype =>
4114                      Write_Header (False);
4115                      Write_Str ("record");
4116                      Indent_Begin;
4117
4118                      declare
4119                         C : Entity_Id;
4120                      begin
4121                         C := First_Entity (Typ);
4122                         while Present (C) loop
4123                            Write_Indent;
4124                            Write_Id (C);
4125                            Write_Str (" : ");
4126                            Write_Id (Etype (C));
4127                            Next_Entity (C);
4128                         end loop;
4129                      end;
4130
4131                      Indent_End;
4132                      Write_Indent_Str (" end record");
4133
4134                   --  Class-Wide types
4135
4136                   when E_Class_Wide_Type    |
4137                        E_Class_Wide_Subtype =>
4138                      Write_Header;
4139                      Write_Name_With_Col_Check (Chars (Etype (Typ)));
4140                      Write_Str ("'Class");
4141
4142                   --  Subprogram types
4143
4144                   when E_Subprogram_Type =>
4145                      Write_Header;
4146
4147                      if Etype (Typ) = Standard_Void_Type then
4148                         Write_Str ("procedure");
4149                      else
4150                         Write_Str ("function");
4151                      end if;
4152
4153                      if Present (First_Entity (Typ)) then
4154                         Write_Str (" (");
4155
4156                         declare
4157                            Param : Entity_Id;
4158
4159                         begin
4160                            Param := First_Entity (Typ);
4161                            loop
4162                               Write_Id (Param);
4163                               Write_Str (" : ");
4164
4165                               if Ekind (Param) = E_In_Out_Parameter then
4166                                  Write_Str ("in out ");
4167                               elsif Ekind (Param) = E_Out_Parameter then
4168                                  Write_Str ("out ");
4169                               end if;
4170
4171                               Write_Id (Etype (Param));
4172                               Next_Entity (Param);
4173                               exit when No (Param);
4174                               Write_Str (", ");
4175                            end loop;
4176
4177                            Write_Char (')');
4178                         end;
4179                      end if;
4180
4181                      if Etype (Typ) /= Standard_Void_Type then
4182                         Write_Str (" return ");
4183                         Write_Id (Etype (Typ));
4184                      end if;
4185
4186                   when E_String_Literal_Subtype =>
4187                      declare
4188                         LB  : constant Uint :=
4189                                 Expr_Value (String_Literal_Low_Bound (Typ));
4190                         Len : constant Uint :=
4191                                 String_Literal_Length (Typ);
4192                      begin
4193                         Write_Str ("String (");
4194                         Write_Int (UI_To_Int (LB));
4195                         Write_Str (" .. ");
4196                         Write_Int (UI_To_Int (LB + Len) - 1);
4197                         Write_Str (");");
4198                      end;
4199
4200                   --  For all other Itypes, print ??? (fill in later)
4201
4202                   when others =>
4203                      Write_Header (True);
4204                      Write_Str ("???");
4205
4206                end case;
4207             end if;
4208
4209             --  Add terminating bracket and restore output buffer
4210
4211             Write_Char (']');
4212             Write_Eol;
4213             Restore_Output_Buffer (S);
4214          end;
4215
4216          Set_Itype_Printed (Typ);
4217       end if;
4218    end Write_Itype;
4219
4220    -------------------------------
4221    -- Write_Name_With_Col_Check --
4222    -------------------------------
4223
4224    procedure Write_Name_With_Col_Check (N : Name_Id) is
4225       J : Natural;
4226       K : Natural;
4227       L : Natural;
4228
4229    begin
4230       Get_Name_String (N);
4231
4232       --  Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4233       --  upper case letter, nnn is one or more digits and b is a lower case
4234       --  letter by C...b, so that listings do not depend on serial numbers.
4235
4236       if Debug_Flag_II then
4237          J := 1;
4238          while J < Name_Len - 1 loop
4239             if Name_Buffer (J) in 'A' .. 'Z'
4240               and then Name_Buffer (J + 1) in '0' .. '9'
4241             then
4242                K := J + 1;
4243                while K < Name_Len loop
4244                   exit when Name_Buffer (K) not in '0' .. '9';
4245                   K := K + 1;
4246                end loop;
4247
4248                if Name_Buffer (K) in 'a' .. 'z' then
4249                   L := Name_Len - K + 1;
4250
4251                   Name_Buffer (J + 4 .. J + L + 3) :=
4252                     Name_Buffer (K .. Name_Len);
4253                   Name_Buffer (J + 1 .. J + 3) := "...";
4254                   Name_Len := J + L + 3;
4255                   J := J + 5;
4256
4257                else
4258                   J := K;
4259                end if;
4260
4261             else
4262                J := J + 1;
4263             end if;
4264          end loop;
4265       end if;
4266
4267       --  Fall through for normal case
4268
4269       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
4270    end Write_Name_With_Col_Check;
4271
4272    ------------------------------------
4273    -- Write_Name_With_Col_Check_Sloc --
4274    ------------------------------------
4275
4276    procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
4277    begin
4278       Get_Name_String (N);
4279       Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
4280    end Write_Name_With_Col_Check_Sloc;
4281
4282    --------------------
4283    -- Write_Operator --
4284    --------------------
4285
4286    procedure Write_Operator (N : Node_Id; S : String) is
4287       F : Natural := S'First;
4288       T : Natural := S'Last;
4289
4290    begin
4291       --  If no overflow check, just write string out, and we are done
4292
4293       if not Do_Overflow_Check (N) then
4294          Write_Str_Sloc (S);
4295
4296       --  If overflow check, we want to surround the operator with curly
4297       --  brackets, but not include spaces within the brackets.
4298
4299       else
4300          if S (F) = ' ' then
4301             Write_Char (' ');
4302             F := F + 1;
4303          end if;
4304
4305          if S (T) = ' ' then
4306             T := T - 1;
4307          end if;
4308
4309          Write_Char ('{');
4310          Write_Str_Sloc (S (F .. T));
4311          Write_Char ('}');
4312
4313          if S (S'Last) = ' ' then
4314             Write_Char (' ');
4315          end if;
4316       end if;
4317    end Write_Operator;
4318
4319    -----------------------
4320    -- Write_Param_Specs --
4321    -----------------------
4322
4323    procedure Write_Param_Specs (N : Node_Id) is
4324       Specs  : List_Id;
4325       Spec   : Node_Id;
4326       Formal : Node_Id;
4327
4328    begin
4329       Specs := Parameter_Specifications (N);
4330
4331       if Is_Non_Empty_List (Specs) then
4332          Write_Str_With_Col_Check (" (");
4333          Spec := First (Specs);
4334
4335          loop
4336             Sprint_Node (Spec);
4337             Formal := Defining_Identifier (Spec);
4338             Next (Spec);
4339             exit when Spec = Empty;
4340
4341             --  Add semicolon, unless we are printing original tree and the
4342             --  next specification is part of a list (but not the first element
4343             --  of that list).
4344
4345             if not Dump_Original_Only or else not Prev_Ids (Spec) then
4346                Write_Str ("; ");
4347             end if;
4348          end loop;
4349
4350          --  Write out any extra formals
4351
4352          while Present (Extra_Formal (Formal)) loop
4353             Formal := Extra_Formal (Formal);
4354             Write_Str ("; ");
4355             Write_Name_With_Col_Check (Chars (Formal));
4356             Write_Str (" : ");
4357             Write_Name_With_Col_Check (Chars (Etype (Formal)));
4358          end loop;
4359
4360          Write_Char (')');
4361       end if;
4362    end Write_Param_Specs;
4363
4364    -----------------------
4365    -- Write_Rewrite_Str --
4366    -----------------------
4367
4368    procedure Write_Rewrite_Str (S : String) is
4369    begin
4370       if not Dump_Generated_Only then
4371          if S'Length = 3 and then S = ">>>" then
4372             Write_Str (">>>");
4373          else
4374             Write_Str_With_Col_Check (S);
4375          end if;
4376       end if;
4377    end Write_Rewrite_Str;
4378
4379    -----------------------
4380    -- Write_Source_Line --
4381    -----------------------
4382
4383    procedure Write_Source_Line (L : Physical_Line_Number) is
4384       Loc : Source_Ptr;
4385       Src : Source_Buffer_Ptr;
4386       Scn : Source_Ptr;
4387
4388    begin
4389       if Dump_Source_Text then
4390          Src := Source_Text (Current_Source_File);
4391          Loc := Line_Start (L, Current_Source_File);
4392          Write_Eol;
4393
4394          --  See if line is a comment line, if not, and if not line one,
4395          --  precede with blank line.
4396
4397          Scn := Loc;
4398          while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
4399             Scn := Scn + 1;
4400          end loop;
4401
4402          if (Src (Scn) in Line_Terminator
4403               or else Src (Scn .. Scn + 1) /= "--")
4404            and then L /= 1
4405          then
4406             Write_Eol;
4407          end if;
4408
4409          --  Now write the source text of the line
4410
4411          Write_Str ("-- ");
4412          Write_Int (Int (L));
4413          Write_Str (": ");
4414
4415          while Src (Loc) not in Line_Terminator loop
4416             Write_Char (Src (Loc));
4417             Loc := Loc + 1;
4418          end loop;
4419       end if;
4420    end Write_Source_Line;
4421
4422    ------------------------
4423    -- Write_Source_Lines --
4424    ------------------------
4425
4426    procedure Write_Source_Lines (L : Physical_Line_Number) is
4427    begin
4428       while Last_Line_Printed < L loop
4429          Last_Line_Printed := Last_Line_Printed + 1;
4430          Write_Source_Line (Last_Line_Printed);
4431       end loop;
4432    end Write_Source_Lines;
4433
4434    --------------------
4435    -- Write_Str_Sloc --
4436    --------------------
4437
4438    procedure Write_Str_Sloc (S : String) is
4439    begin
4440       for J in S'Range loop
4441          Write_Char_Sloc (S (J));
4442       end loop;
4443    end Write_Str_Sloc;
4444
4445    ------------------------------
4446    -- Write_Str_With_Col_Check --
4447    ------------------------------
4448
4449    procedure Write_Str_With_Col_Check (S : String) is
4450    begin
4451       if Int (S'Last) + Column > Sprint_Line_Limit then
4452          Write_Indent_Str ("  ");
4453
4454          if S (S'First) = ' ' then
4455             Write_Str (S (S'First + 1 .. S'Last));
4456          else
4457             Write_Str (S);
4458          end if;
4459
4460       else
4461          Write_Str (S);
4462       end if;
4463    end Write_Str_With_Col_Check;
4464
4465    -----------------------------------
4466    -- Write_Str_With_Col_Check_Sloc --
4467    -----------------------------------
4468
4469    procedure Write_Str_With_Col_Check_Sloc (S : String) is
4470    begin
4471       if Int (S'Last) + Column > Sprint_Line_Limit then
4472          Write_Indent_Str ("  ");
4473
4474          if S (S'First) = ' ' then
4475             Write_Str_Sloc (S (S'First + 1 .. S'Last));
4476          else
4477             Write_Str_Sloc (S);
4478          end if;
4479
4480       else
4481          Write_Str_Sloc (S);
4482       end if;
4483    end Write_Str_With_Col_Check_Sloc;
4484
4485    ---------------------------
4486    -- Write_Subprogram_Name --
4487    ---------------------------
4488
4489    procedure Write_Subprogram_Name (N : Node_Id) is
4490    begin
4491       if not Comes_From_Source (N)
4492         and then Is_Entity_Name (N)
4493       then
4494          declare
4495             Ent : constant Entity_Id := Entity (N);
4496          begin
4497             if not In_Extended_Main_Source_Unit (Ent)
4498               and then
4499                 Is_Predefined_File_Name
4500                   (Unit_File_Name (Get_Source_Unit (Ent)))
4501             then
4502                --  Run-time routine name, output name with a preceding dollar
4503                --  making sure that we do not get a line split between them.
4504
4505                Col_Check (Length_Of_Name (Chars (Ent)) + 1);
4506                Write_Char ('$');
4507                Write_Name (Chars (Ent));
4508                return;
4509             end if;
4510          end;
4511       end if;
4512
4513       --  Normal case, not a run-time routine name
4514
4515       Sprint_Node (N);
4516    end Write_Subprogram_Name;
4517
4518    -------------------------------
4519    -- Write_Uint_With_Col_Check --
4520    -------------------------------
4521
4522    procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is
4523    begin
4524       Col_Check (UI_Decimal_Digits_Hi (U));
4525       UI_Write (U, Format);
4526    end Write_Uint_With_Col_Check;
4527
4528    ------------------------------------
4529    -- Write_Uint_With_Col_Check_Sloc --
4530    ------------------------------------
4531
4532    procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
4533    begin
4534       Col_Check (UI_Decimal_Digits_Hi (U));
4535       Set_Debug_Sloc;
4536       UI_Write (U, Format);
4537    end Write_Uint_With_Col_Check_Sloc;
4538
4539    -------------------------------------
4540    -- Write_Ureal_With_Col_Check_Sloc --
4541    -------------------------------------
4542
4543    procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
4544       D : constant Uint := Denominator (U);
4545       N : constant Uint := Numerator (U);
4546    begin
4547       Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
4548       Set_Debug_Sloc;
4549       UR_Write (U, Brackets => True);
4550    end Write_Ureal_With_Col_Check_Sloc;
4551
4552 end Sprint;