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                Has_Parens : constant Boolean := Paren_Count (Node) > 0;
1163                Alt        : Node_Id;
1164
1165             begin
1166                --  The syntax for case_expression does not include parentheses,
1167                --  but sometimes parentheses are required, so unconditionally
1168                --  generate them here unless already present.
1169
1170                if not Has_Parens then
1171                   Write_Char ('(');
1172                end if;
1173
1174                Write_Str_With_Col_Check_Sloc ("case ");
1175                Sprint_Node (Expression (Node));
1176                Write_Str_With_Col_Check (" is");
1177
1178                Alt := First (Alternatives (Node));
1179                loop
1180                   Sprint_Node (Alt);
1181                   Next (Alt);
1182                   exit when No (Alt);
1183                   Write_Char (',');
1184                end loop;
1185
1186                if not Has_Parens then
1187                   Write_Char (')');
1188                end if;
1189             end;
1190
1191          when N_Case_Expression_Alternative =>
1192             Write_Str_With_Col_Check (" when ");
1193             Sprint_Bar_List (Discrete_Choices (Node));
1194             Write_Str (" => ");
1195             Sprint_Node (Expression (Node));
1196
1197          when N_Case_Statement =>
1198             Write_Indent_Str_Sloc ("case ");
1199             Sprint_Node (Expression (Node));
1200             Write_Str (" is");
1201             Sprint_Indented_List (Alternatives (Node));
1202             Write_Indent_Str ("end case;");
1203
1204          when N_Case_Statement_Alternative =>
1205             Write_Indent_Str_Sloc ("when ");
1206             Sprint_Bar_List (Discrete_Choices (Node));
1207             Write_Str (" => ");
1208             Sprint_Indented_List (Statements (Node));
1209
1210          when N_Character_Literal =>
1211             if Column > Sprint_Line_Limit - 2 then
1212                Write_Indent_Str ("  ");
1213             end if;
1214
1215             Write_Char_Sloc (''');
1216             Write_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
1217             Write_Char (''');
1218
1219          when N_Code_Statement =>
1220             Write_Indent;
1221             Set_Debug_Sloc;
1222             Sprint_Node (Expression (Node));
1223             Write_Char (';');
1224
1225          when N_Compilation_Unit =>
1226             Sprint_Node_List (Context_Items (Node));
1227             Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
1228
1229             if Private_Present (Node) then
1230                Write_Indent_Str ("private ");
1231                Indent_Annull;
1232             end if;
1233
1234             Sprint_Node_Sloc (Unit (Node));
1235
1236             if Present (Actions (Aux_Decls_Node (Node)))
1237                  or else
1238                Present (Pragmas_After (Aux_Decls_Node (Node)))
1239             then
1240                Write_Indent;
1241             end if;
1242
1243             Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
1244             Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
1245
1246          when N_Compilation_Unit_Aux =>
1247             null; -- nothing to do, never used, see above
1248
1249          when N_Component_Association =>
1250             Set_Debug_Sloc;
1251             Sprint_Bar_List (Choices (Node));
1252             Write_Str (" => ");
1253
1254             --  Ada 2005 (AI-287): Print the box if present
1255
1256             if Box_Present (Node) then
1257                Write_Str_With_Col_Check ("<>");
1258             else
1259                Sprint_Node (Expression (Node));
1260             end if;
1261
1262          when N_Component_Clause =>
1263             Write_Indent;
1264             Sprint_Node (Component_Name (Node));
1265             Write_Str_Sloc (" at ");
1266             Sprint_Node (Position (Node));
1267             Write_Char (' ');
1268             Write_Str_With_Col_Check ("range ");
1269             Sprint_Node (First_Bit (Node));
1270             Write_Str (" .. ");
1271             Sprint_Node (Last_Bit (Node));
1272             Write_Char (';');
1273
1274          when N_Component_Definition =>
1275             Set_Debug_Sloc;
1276
1277             --  Ada 2005 (AI-230): Access definition components
1278
1279             if Present (Access_Definition (Node)) then
1280                Sprint_Node (Access_Definition (Node));
1281
1282             elsif Present (Subtype_Indication (Node)) then
1283                if Aliased_Present (Node) then
1284                   Write_Str_With_Col_Check ("aliased ");
1285                end if;
1286
1287                --  Ada 2005 (AI-231)
1288
1289                if Null_Exclusion_Present (Node) then
1290                   Write_Str (" not null ");
1291                end if;
1292
1293                Sprint_Node (Subtype_Indication (Node));
1294
1295             else
1296                Write_Str (" ??? ");
1297             end if;
1298
1299          when N_Component_Declaration =>
1300             if Write_Indent_Identifiers_Sloc (Node) then
1301                Write_Str (" : ");
1302                Sprint_Node (Component_Definition (Node));
1303
1304                if Present (Expression (Node)) then
1305                   Write_Str (" := ");
1306                   Sprint_Node (Expression (Node));
1307                end if;
1308
1309                Write_Char (';');
1310             end if;
1311
1312          when N_Component_List =>
1313             if Null_Present (Node) then
1314                Indent_Begin;
1315                Write_Indent_Str_Sloc ("null");
1316                Write_Char (';');
1317                Indent_End;
1318
1319             else
1320                Set_Debug_Sloc;
1321                Sprint_Indented_List (Component_Items (Node));
1322                Sprint_Node (Variant_Part (Node));
1323             end if;
1324
1325          when N_Conditional_Entry_Call =>
1326             Write_Indent_Str_Sloc ("select");
1327             Indent_Begin;
1328             Sprint_Node (Entry_Call_Alternative (Node));
1329             Indent_End;
1330             Write_Indent_Str ("else");
1331             Sprint_Indented_List (Else_Statements (Node));
1332             Write_Indent_Str ("end select;");
1333
1334          when N_Constrained_Array_Definition =>
1335             Write_Str_With_Col_Check_Sloc ("array ");
1336             Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
1337             Write_Str (" of ");
1338
1339             Sprint_Node (Component_Definition (Node));
1340
1341          --  A contract node should not appear in the tree. It is a semantic
1342          --  node attached to entry and [generic] subprogram entities.
1343
1344          when N_Contract =>
1345             raise Program_Error;
1346
1347          when N_Decimal_Fixed_Point_Definition =>
1348             Write_Str_With_Col_Check_Sloc (" delta ");
1349             Sprint_Node (Delta_Expression (Node));
1350             Write_Str_With_Col_Check ("digits ");
1351             Sprint_Node (Digits_Expression (Node));
1352             Sprint_Opt_Node (Real_Range_Specification (Node));
1353
1354          when N_Defining_Character_Literal =>
1355             Write_Name_With_Col_Check_Sloc (Chars (Node));
1356
1357          when N_Defining_Identifier =>
1358             Set_Debug_Sloc;
1359             Write_Id (Node);
1360
1361          when N_Defining_Operator_Symbol =>
1362             Write_Name_With_Col_Check_Sloc (Chars (Node));
1363
1364          when N_Defining_Program_Unit_Name =>
1365             Set_Debug_Sloc;
1366             Sprint_Node (Name (Node));
1367             Write_Char ('.');
1368             Write_Id (Defining_Identifier (Node));
1369
1370          when N_Delay_Alternative =>
1371             Sprint_Node_List (Pragmas_Before (Node));
1372
1373             if Present (Condition (Node)) then
1374                Write_Indent;
1375                Write_Str_With_Col_Check ("when ");
1376                Sprint_Node (Condition (Node));
1377                Write_Str (" => ");
1378                Indent_Annull;
1379             end if;
1380
1381             Sprint_Node_Sloc (Delay_Statement (Node));
1382             Sprint_Node_List (Statements (Node));
1383
1384          when N_Delay_Relative_Statement =>
1385             Write_Indent_Str_Sloc ("delay ");
1386             Sprint_Node (Expression (Node));
1387             Write_Char (';');
1388
1389          when N_Delay_Until_Statement =>
1390             Write_Indent_Str_Sloc ("delay until ");
1391             Sprint_Node (Expression (Node));
1392             Write_Char (';');
1393
1394          when N_Delta_Constraint =>
1395             Write_Str_With_Col_Check_Sloc ("delta ");
1396             Sprint_Node (Delta_Expression (Node));
1397             Sprint_Opt_Node (Range_Constraint (Node));
1398
1399          when N_Derived_Type_Definition =>
1400             if Abstract_Present (Node) then
1401                Write_Str_With_Col_Check ("abstract ");
1402             end if;
1403
1404             Write_Str_With_Col_Check ("new ");
1405
1406             --  Ada 2005 (AI-231)
1407
1408             if Null_Exclusion_Present (Node) then
1409                Write_Str_With_Col_Check ("not null ");
1410             end if;
1411
1412             Sprint_Node (Subtype_Indication (Node));
1413
1414             if Present (Interface_List (Node)) then
1415                Write_Str_With_Col_Check (" and ");
1416                Sprint_And_List (Interface_List (Node));
1417                Write_Str_With_Col_Check (" with ");
1418             end if;
1419
1420             if Present (Record_Extension_Part (Node)) then
1421                if No (Interface_List (Node)) then
1422                   Write_Str_With_Col_Check (" with ");
1423                end if;
1424
1425                Sprint_Node (Record_Extension_Part (Node));
1426             end if;
1427
1428          when N_Designator =>
1429             Sprint_Node (Name (Node));
1430             Write_Char_Sloc ('.');
1431             Write_Id (Identifier (Node));
1432
1433          when N_Digits_Constraint =>
1434             Write_Str_With_Col_Check_Sloc ("digits ");
1435             Sprint_Node (Digits_Expression (Node));
1436             Sprint_Opt_Node (Range_Constraint (Node));
1437
1438          when N_Discriminant_Association =>
1439             Set_Debug_Sloc;
1440
1441             if Present (Selector_Names (Node)) then
1442                Sprint_Bar_List (Selector_Names (Node));
1443                Write_Str (" => ");
1444             end if;
1445
1446             Set_Debug_Sloc;
1447             Sprint_Node (Expression (Node));
1448
1449          when N_Discriminant_Specification =>
1450             Set_Debug_Sloc;
1451
1452             if Write_Identifiers (Node) then
1453                Write_Str (" : ");
1454
1455                if Null_Exclusion_Present (Node) then
1456                   Write_Str ("not null ");
1457                end if;
1458
1459                Sprint_Node (Discriminant_Type (Node));
1460
1461                if Present (Expression (Node)) then
1462                   Write_Str (" := ");
1463                   Sprint_Node (Expression (Node));
1464                end if;
1465             else
1466                Write_Str (", ");
1467             end if;
1468
1469          when N_Elsif_Part =>
1470             Write_Indent_Str_Sloc ("elsif ");
1471             Sprint_Node (Condition (Node));
1472             Write_Str_With_Col_Check (" then");
1473             Sprint_Indented_List (Then_Statements (Node));
1474
1475          when N_Empty =>
1476             null;
1477
1478          when N_Entry_Body =>
1479             Write_Indent_Str_Sloc ("entry ");
1480             Write_Id (Defining_Identifier (Node));
1481             Sprint_Node (Entry_Body_Formal_Part (Node));
1482             Write_Str_With_Col_Check (" is");
1483             Sprint_Indented_List (Declarations (Node));
1484             Write_Indent_Str ("begin");
1485             Sprint_Node (Handled_Statement_Sequence (Node));
1486             Write_Indent_Str ("end ");
1487             Write_Id (Defining_Identifier (Node));
1488             Write_Char (';');
1489
1490          when N_Entry_Body_Formal_Part =>
1491             if Present (Entry_Index_Specification (Node)) then
1492                Write_Str_With_Col_Check_Sloc (" (");
1493                Sprint_Node (Entry_Index_Specification (Node));
1494                Write_Char (')');
1495             end if;
1496
1497             Write_Param_Specs (Node);
1498             Write_Str_With_Col_Check_Sloc (" when ");
1499             Sprint_Node (Condition (Node));
1500
1501          when N_Entry_Call_Alternative =>
1502             Sprint_Node_List (Pragmas_Before (Node));
1503             Sprint_Node_Sloc (Entry_Call_Statement (Node));
1504             Sprint_Node_List (Statements (Node));
1505
1506          when N_Entry_Call_Statement =>
1507             Write_Indent;
1508             Sprint_Node_Sloc (Name (Node));
1509             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1510             Write_Char (';');
1511
1512          when N_Entry_Declaration =>
1513             Write_Indent_Str_Sloc ("entry ");
1514             Write_Id (Defining_Identifier (Node));
1515
1516             if Present (Discrete_Subtype_Definition (Node)) then
1517                Write_Str_With_Col_Check (" (");
1518                Sprint_Node (Discrete_Subtype_Definition (Node));
1519                Write_Char (')');
1520             end if;
1521
1522             Write_Param_Specs (Node);
1523             Write_Char (';');
1524
1525          when N_Entry_Index_Specification =>
1526             Write_Str_With_Col_Check_Sloc ("for ");
1527             Write_Id (Defining_Identifier (Node));
1528             Write_Str_With_Col_Check (" in ");
1529             Sprint_Node (Discrete_Subtype_Definition (Node));
1530
1531          when N_Enumeration_Representation_Clause =>
1532             Write_Indent_Str_Sloc ("for ");
1533             Write_Id (Identifier (Node));
1534             Write_Str_With_Col_Check (" use ");
1535             Sprint_Node (Array_Aggregate (Node));
1536             Write_Char (';');
1537
1538          when N_Enumeration_Type_Definition =>
1539             Set_Debug_Sloc;
1540
1541             --  Skip attempt to print Literals field if it's not there and
1542             --  we are in package Standard (case of Character, which is
1543             --  handled specially (without an explicit literals list).
1544
1545             if Sloc (Node) > Standard_Location
1546               or else Present (Literals (Node))
1547             then
1548                Sprint_Paren_Comma_List (Literals (Node));
1549             end if;
1550
1551          when N_Error =>
1552             Write_Str_With_Col_Check_Sloc ("<error>");
1553
1554          when N_Exception_Declaration =>
1555             if Write_Indent_Identifiers (Node) then
1556                Write_Str_With_Col_Check (" : ");
1557
1558                if Is_Statically_Allocated (Defining_Identifier (Node)) then
1559                   Write_Str_With_Col_Check ("static ");
1560                end if;
1561
1562                Write_Str_Sloc ("exception");
1563
1564                if Present (Expression (Node)) then
1565                   Write_Str (" := ");
1566                   Sprint_Node (Expression (Node));
1567                end if;
1568
1569                Write_Char (';');
1570             end if;
1571
1572          when N_Exception_Handler =>
1573             Write_Indent_Str_Sloc ("when ");
1574
1575             if Present (Choice_Parameter (Node)) then
1576                Sprint_Node (Choice_Parameter (Node));
1577                Write_Str (" : ");
1578             end if;
1579
1580             Sprint_Bar_List (Exception_Choices (Node));
1581             Write_Str (" => ");
1582             Sprint_Indented_List (Statements (Node));
1583
1584          when N_Exception_Renaming_Declaration =>
1585             Write_Indent;
1586             Set_Debug_Sloc;
1587             Sprint_Node (Defining_Identifier (Node));
1588             Write_Str_With_Col_Check (" : exception renames ");
1589             Sprint_Node (Name (Node));
1590             Write_Char (';');
1591
1592          when N_Exit_Statement =>
1593             Write_Indent_Str_Sloc ("exit");
1594             Sprint_Opt_Node (Name (Node));
1595
1596             if Present (Condition (Node)) then
1597                Write_Str_With_Col_Check (" when ");
1598                Sprint_Node (Condition (Node));
1599             end if;
1600
1601             Write_Char (';');
1602
1603          when N_Expanded_Name =>
1604             Sprint_Node (Prefix (Node));
1605             Write_Char_Sloc ('.');
1606             Sprint_Node (Selector_Name (Node));
1607
1608          when N_Explicit_Dereference =>
1609             Sprint_Node (Prefix (Node));
1610             Write_Char_Sloc ('.');
1611             Write_Str_Sloc ("all");
1612
1613          when N_Expression_With_Actions =>
1614             Indent_Begin;
1615             Write_Indent_Str_Sloc ("do ");
1616             Indent_Begin;
1617             Sprint_Node_List (Actions (Node));
1618             Indent_End;
1619             Write_Indent;
1620             Write_Str_With_Col_Check_Sloc ("in ");
1621             Sprint_Node (Expression (Node));
1622             Write_Str_With_Col_Check (" end");
1623             Indent_End;
1624             Write_Indent;
1625
1626          when N_Expression_Function =>
1627             Write_Indent;
1628             Sprint_Node_Sloc (Specification (Node));
1629             Write_Str (" is");
1630             Indent_Begin;
1631             Write_Indent;
1632             Sprint_Node (Expression (Node));
1633             Write_Char (';');
1634             Indent_End;
1635
1636          when N_Extended_Return_Statement =>
1637             Write_Indent_Str_Sloc ("return ");
1638             Sprint_Node_List (Return_Object_Declarations (Node));
1639
1640             if Present (Handled_Statement_Sequence (Node)) then
1641                Write_Str_With_Col_Check (" do");
1642                Sprint_Node (Handled_Statement_Sequence (Node));
1643                Write_Indent_Str ("end return;");
1644             else
1645                Write_Indent_Str (";");
1646             end if;
1647
1648          when N_Extension_Aggregate =>
1649             Write_Str_With_Col_Check_Sloc ("(");
1650             Sprint_Node (Ancestor_Part (Node));
1651             Write_Str_With_Col_Check (" with ");
1652
1653             if Null_Record_Present (Node) then
1654                Write_Str_With_Col_Check ("null record");
1655             else
1656                if Present (Expressions (Node)) then
1657                   Sprint_Comma_List (Expressions (Node));
1658
1659                   if Present (Component_Associations (Node)) then
1660                      Write_Str (", ");
1661                   end if;
1662                end if;
1663
1664                if Present (Component_Associations (Node)) then
1665                   Sprint_Comma_List (Component_Associations (Node));
1666                end if;
1667             end if;
1668
1669             Write_Char (')');
1670
1671          when N_Floating_Point_Definition =>
1672             Write_Str_With_Col_Check_Sloc ("digits ");
1673             Sprint_Node (Digits_Expression (Node));
1674             Sprint_Opt_Node (Real_Range_Specification (Node));
1675
1676          when N_Formal_Decimal_Fixed_Point_Definition =>
1677             Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
1678
1679          when N_Formal_Derived_Type_Definition =>
1680             Write_Str_With_Col_Check_Sloc ("new ");
1681             Sprint_Node (Subtype_Mark (Node));
1682
1683             if Present (Interface_List (Node)) then
1684                Write_Str_With_Col_Check (" and ");
1685                Sprint_And_List (Interface_List (Node));
1686             end if;
1687
1688             if Private_Present (Node) then
1689                Write_Str_With_Col_Check (" with private");
1690             end if;
1691
1692          when N_Formal_Abstract_Subprogram_Declaration =>
1693             Write_Indent_Str_Sloc ("with ");
1694             Sprint_Node (Specification (Node));
1695
1696             Write_Str_With_Col_Check (" is abstract");
1697
1698             if Box_Present (Node) then
1699                Write_Str_With_Col_Check (" <>");
1700             elsif Present (Default_Name (Node)) then
1701                Write_Str_With_Col_Check (" ");
1702                Sprint_Node (Default_Name (Node));
1703             end if;
1704
1705             Write_Char (';');
1706
1707          when N_Formal_Concrete_Subprogram_Declaration =>
1708             Write_Indent_Str_Sloc ("with ");
1709             Sprint_Node (Specification (Node));
1710
1711             if Box_Present (Node) then
1712                Write_Str_With_Col_Check (" is <>");
1713             elsif Present (Default_Name (Node)) then
1714                Write_Str_With_Col_Check (" is ");
1715                Sprint_Node (Default_Name (Node));
1716             end if;
1717
1718             Write_Char (';');
1719
1720          when N_Formal_Discrete_Type_Definition =>
1721             Write_Str_With_Col_Check_Sloc ("<>");
1722
1723          when N_Formal_Floating_Point_Definition =>
1724             Write_Str_With_Col_Check_Sloc ("digits <>");
1725
1726          when N_Formal_Modular_Type_Definition =>
1727             Write_Str_With_Col_Check_Sloc ("mod <>");
1728
1729          when N_Formal_Object_Declaration =>
1730             Set_Debug_Sloc;
1731
1732             if Write_Indent_Identifiers (Node) then
1733                Write_Str (" : ");
1734
1735                if In_Present (Node) then
1736                   Write_Str_With_Col_Check ("in ");
1737                end if;
1738
1739                if Out_Present (Node) then
1740                   Write_Str_With_Col_Check ("out ");
1741                end if;
1742
1743                if Present (Subtype_Mark (Node)) then
1744
1745                   --  Ada 2005 (AI-423): Formal object with null exclusion
1746
1747                   if Null_Exclusion_Present (Node) then
1748                      Write_Str ("not null ");
1749                   end if;
1750
1751                   Sprint_Node (Subtype_Mark (Node));
1752
1753                --  Ada 2005 (AI-423): Formal object with access definition
1754
1755                else
1756                   pragma Assert (Present (Access_Definition (Node)));
1757
1758                   Sprint_Node (Access_Definition (Node));
1759                end if;
1760
1761                if Present (Default_Expression (Node)) then
1762                   Write_Str (" := ");
1763                   Sprint_Node (Default_Expression (Node));
1764                end if;
1765
1766                Write_Char (';');
1767             end if;
1768
1769          when N_Formal_Ordinary_Fixed_Point_Definition =>
1770             Write_Str_With_Col_Check_Sloc ("delta <>");
1771
1772          when N_Formal_Package_Declaration =>
1773             Write_Indent_Str_Sloc ("with package ");
1774             Write_Id (Defining_Identifier (Node));
1775             Write_Str_With_Col_Check (" is new ");
1776             Sprint_Node (Name (Node));
1777             Write_Str_With_Col_Check (" (<>);");
1778
1779          when N_Formal_Private_Type_Definition =>
1780             if Abstract_Present (Node) then
1781                Write_Str_With_Col_Check ("abstract ");
1782             end if;
1783
1784             if Tagged_Present (Node) then
1785                Write_Str_With_Col_Check ("tagged ");
1786             end if;
1787
1788             if Limited_Present (Node) then
1789                Write_Str_With_Col_Check ("limited ");
1790             end if;
1791
1792             Write_Str_With_Col_Check_Sloc ("private");
1793
1794          when N_Formal_Incomplete_Type_Definition =>
1795             if Tagged_Present (Node) then
1796                Write_Str_With_Col_Check ("is tagged ");
1797             end if;
1798
1799          when N_Formal_Signed_Integer_Type_Definition =>
1800             Write_Str_With_Col_Check_Sloc ("range <>");
1801
1802          when N_Formal_Type_Declaration =>
1803             Write_Indent_Str_Sloc ("type ");
1804             Write_Id (Defining_Identifier (Node));
1805
1806             if Present (Discriminant_Specifications (Node)) then
1807                Write_Discr_Specs (Node);
1808             elsif Unknown_Discriminants_Present (Node) then
1809                Write_Str_With_Col_Check ("(<>)");
1810             end if;
1811
1812             if Nkind (Formal_Type_Definition (Node)) /=
1813                 N_Formal_Incomplete_Type_Definition
1814             then
1815                Write_Str_With_Col_Check (" is ");
1816             end if;
1817
1818             Sprint_Node (Formal_Type_Definition (Node));
1819             Write_Char (';');
1820
1821          when N_Free_Statement =>
1822             Write_Indent_Str_Sloc ("free ");
1823             Sprint_Node (Expression (Node));
1824             Write_Char (';');
1825
1826          when N_Freeze_Entity =>
1827             if Dump_Original_Only then
1828                null;
1829
1830             elsif Present (Actions (Node)) or else Dump_Freeze_Null then
1831                Write_Indent;
1832                Write_Rewrite_Str ("<<<");
1833                Write_Str_With_Col_Check_Sloc ("freeze ");
1834                Write_Id (Entity (Node));
1835                Write_Str (" [");
1836
1837                if No (Actions (Node)) then
1838                   Write_Char (']');
1839
1840                else
1841                   --  Output freeze actions. We increment Freeze_Indent during
1842                   --  this output to avoid generating extra blank lines before
1843                   --  any procedures included in the freeze actions.
1844
1845                   Freeze_Indent := Freeze_Indent + 1;
1846                   Sprint_Indented_List (Actions (Node));
1847                   Freeze_Indent := Freeze_Indent - 1;
1848                   Write_Indent_Str ("]");
1849                end if;
1850
1851                Write_Rewrite_Str (">>>");
1852             end if;
1853
1854          when N_Full_Type_Declaration =>
1855             Write_Indent_Str_Sloc ("type ");
1856             Sprint_Node (Defining_Identifier (Node));
1857             Write_Discr_Specs (Node);
1858             Write_Str_With_Col_Check (" is ");
1859             Sprint_Node (Type_Definition (Node));
1860             Write_Char (';');
1861
1862          when N_Function_Call =>
1863             Set_Debug_Sloc;
1864             Write_Subprogram_Name (Name (Node));
1865             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1866
1867          when N_Function_Instantiation =>
1868             Write_Indent_Str_Sloc ("function ");
1869             Sprint_Node (Defining_Unit_Name (Node));
1870             Write_Str_With_Col_Check (" is new ");
1871             Sprint_Node (Name (Node));
1872             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
1873             Write_Char (';');
1874
1875          when N_Function_Specification =>
1876             Write_Str_With_Col_Check_Sloc ("function ");
1877             Sprint_Node (Defining_Unit_Name (Node));
1878             Write_Param_Specs (Node);
1879             Write_Str_With_Col_Check (" return ");
1880
1881             --  Ada 2005 (AI-231)
1882
1883             if Nkind (Result_Definition (Node)) /= N_Access_Definition
1884               and then Null_Exclusion_Present (Node)
1885             then
1886                Write_Str (" not null ");
1887             end if;
1888
1889             Sprint_Node (Result_Definition (Node));
1890
1891          when N_Generic_Association =>
1892             Set_Debug_Sloc;
1893
1894             if Present (Selector_Name (Node)) then
1895                Sprint_Node (Selector_Name (Node));
1896                Write_Str (" => ");
1897             end if;
1898
1899             Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
1900
1901          when N_Generic_Function_Renaming_Declaration =>
1902             Write_Indent_Str_Sloc ("generic function ");
1903             Sprint_Node (Defining_Unit_Name (Node));
1904             Write_Str_With_Col_Check (" renames ");
1905             Sprint_Node (Name (Node));
1906             Write_Char (';');
1907
1908          when N_Generic_Package_Declaration =>
1909             Extra_Blank_Line;
1910             Write_Indent_Str_Sloc ("generic ");
1911             Sprint_Indented_List (Generic_Formal_Declarations (Node));
1912             Write_Indent;
1913             Sprint_Node (Specification (Node));
1914             Write_Char (';');
1915
1916          when N_Generic_Package_Renaming_Declaration =>
1917             Write_Indent_Str_Sloc ("generic package ");
1918             Sprint_Node (Defining_Unit_Name (Node));
1919             Write_Str_With_Col_Check (" renames ");
1920             Sprint_Node (Name (Node));
1921             Write_Char (';');
1922
1923          when N_Generic_Procedure_Renaming_Declaration =>
1924             Write_Indent_Str_Sloc ("generic procedure ");
1925             Sprint_Node (Defining_Unit_Name (Node));
1926             Write_Str_With_Col_Check (" renames ");
1927             Sprint_Node (Name (Node));
1928             Write_Char (';');
1929
1930          when N_Generic_Subprogram_Declaration =>
1931             Extra_Blank_Line;
1932             Write_Indent_Str_Sloc ("generic ");
1933             Sprint_Indented_List (Generic_Formal_Declarations (Node));
1934             Write_Indent;
1935             Sprint_Node (Specification (Node));
1936             Write_Char (';');
1937
1938          when N_Goto_Statement =>
1939             Write_Indent_Str_Sloc ("goto ");
1940             Sprint_Node (Name (Node));
1941             Write_Char (';');
1942
1943             if Nkind (Next (Node)) = N_Label then
1944                Write_Indent;
1945             end if;
1946
1947          when N_Handled_Sequence_Of_Statements =>
1948             Set_Debug_Sloc;
1949             Sprint_Indented_List (Statements (Node));
1950
1951             if Present (Exception_Handlers (Node)) then
1952                Write_Indent_Str ("exception");
1953                Indent_Begin;
1954                Sprint_Node_List (Exception_Handlers (Node));
1955                Indent_End;
1956             end if;
1957
1958             if Present (At_End_Proc (Node)) then
1959                Write_Indent_Str ("at end");
1960                Indent_Begin;
1961                Write_Indent;
1962                Sprint_Node (At_End_Proc (Node));
1963                Write_Char (';');
1964                Indent_End;
1965             end if;
1966
1967          when N_Identifier =>
1968             Set_Debug_Sloc;
1969             Write_Id (Node);
1970
1971          when N_If_Expression =>
1972             declare
1973                Has_Parens : constant Boolean := Paren_Count (Node) > 0;
1974                Condition  : constant Node_Id := First (Expressions (Node));
1975                Then_Expr  : constant Node_Id := Next (Condition);
1976
1977             begin
1978                --  The syntax for if_expression does not include parentheses,
1979                --  but sometimes parentheses are required, so unconditionally
1980                --  generate them here unless already present.
1981
1982                if not Has_Parens then
1983                   Write_Char ('(');
1984                end if;
1985                Write_Str_With_Col_Check_Sloc ("if ");
1986                Sprint_Node (Condition);
1987                Write_Str_With_Col_Check (" then ");
1988
1989                --  Defense against junk here!
1990
1991                if Present (Then_Expr) then
1992                   Sprint_Node (Then_Expr);
1993
1994                   if Present (Next (Then_Expr)) then
1995                      Write_Str_With_Col_Check (" else ");
1996                      Sprint_Node (Next (Then_Expr));
1997                   end if;
1998                end if;
1999
2000                if not Has_Parens then
2001                   Write_Char (')');
2002                end if;
2003             end;
2004
2005          when N_If_Statement =>
2006             Write_Indent_Str_Sloc ("if ");
2007             Sprint_Node (Condition (Node));
2008             Write_Str_With_Col_Check (" then");
2009             Sprint_Indented_List (Then_Statements (Node));
2010             Sprint_Opt_Node_List (Elsif_Parts (Node));
2011
2012             if Present (Else_Statements (Node)) then
2013                Write_Indent_Str ("else");
2014                Sprint_Indented_List (Else_Statements (Node));
2015             end if;
2016
2017             Write_Indent_Str ("end if;");
2018
2019          when N_Implicit_Label_Declaration =>
2020             if not Dump_Original_Only then
2021                Write_Indent;
2022                Write_Rewrite_Str ("<<<");
2023                Set_Debug_Sloc;
2024                Write_Id (Defining_Identifier (Node));
2025                Write_Str (" : ");
2026                Write_Str_With_Col_Check ("label");
2027                Write_Rewrite_Str (">>>");
2028             end if;
2029
2030          when N_In =>
2031             Sprint_Left_Opnd (Node);
2032             Write_Str_Sloc (" in ");
2033
2034             if Present (Right_Opnd (Node)) then
2035                Sprint_Right_Opnd (Node);
2036             else
2037                Sprint_Bar_List (Alternatives (Node));
2038             end if;
2039
2040          when N_Incomplete_Type_Declaration =>
2041             Write_Indent_Str_Sloc ("type ");
2042             Write_Id (Defining_Identifier (Node));
2043
2044             if Present (Discriminant_Specifications (Node)) then
2045                Write_Discr_Specs (Node);
2046             elsif Unknown_Discriminants_Present (Node) then
2047                Write_Str_With_Col_Check ("(<>)");
2048             end if;
2049
2050             Write_Char (';');
2051
2052          when N_Index_Or_Discriminant_Constraint =>
2053             Set_Debug_Sloc;
2054             Sprint_Paren_Comma_List (Constraints (Node));
2055
2056          when N_Indexed_Component =>
2057             Sprint_Node_Sloc (Prefix (Node));
2058             Sprint_Opt_Paren_Comma_List (Expressions (Node));
2059
2060          when N_Integer_Literal =>
2061             if Print_In_Hex (Node) then
2062                Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
2063             else
2064                Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
2065             end if;
2066
2067          when N_Iteration_Scheme =>
2068             if Present (Condition (Node)) then
2069                Write_Str_With_Col_Check_Sloc ("while ");
2070                Sprint_Node (Condition (Node));
2071             else
2072                Write_Str_With_Col_Check_Sloc ("for ");
2073
2074                if Present (Iterator_Specification (Node)) then
2075                   Sprint_Node (Iterator_Specification (Node));
2076                else
2077                   Sprint_Node (Loop_Parameter_Specification (Node));
2078                end if;
2079             end if;
2080
2081             Write_Char (' ');
2082
2083          when N_Iterator_Specification =>
2084             Set_Debug_Sloc;
2085             Write_Id (Defining_Identifier (Node));
2086
2087             if Present (Subtype_Indication (Node)) then
2088                Write_Str_With_Col_Check (" : ");
2089                Sprint_Node (Subtype_Indication (Node));
2090             end if;
2091
2092             if Of_Present (Node) then
2093                Write_Str_With_Col_Check (" of ");
2094             else
2095                Write_Str_With_Col_Check (" in ");
2096             end if;
2097
2098             if Reverse_Present (Node) then
2099                Write_Str_With_Col_Check ("reverse ");
2100             end if;
2101
2102             Sprint_Node (Name (Node));
2103
2104          when N_Itype_Reference =>
2105             Write_Indent_Str_Sloc ("reference ");
2106             Write_Id (Itype (Node));
2107
2108          when N_Label =>
2109             Write_Indent_Str_Sloc ("<<");
2110             Write_Id (Identifier (Node));
2111             Write_Str (">>");
2112
2113          when N_Loop_Parameter_Specification =>
2114             Set_Debug_Sloc;
2115             Write_Id (Defining_Identifier (Node));
2116             Write_Str_With_Col_Check (" in ");
2117
2118             if Reverse_Present (Node) then
2119                Write_Str_With_Col_Check ("reverse ");
2120             end if;
2121
2122             Sprint_Node (Discrete_Subtype_Definition (Node));
2123
2124          when N_Loop_Statement =>
2125             Write_Indent;
2126
2127             if Present (Identifier (Node))
2128               and then (not Has_Created_Identifier (Node)
2129                           or else not Dump_Original_Only)
2130             then
2131                Write_Rewrite_Str ("<<<");
2132                Write_Id (Identifier (Node));
2133                Write_Str (" : ");
2134                Write_Rewrite_Str (">>>");
2135                Sprint_Node (Iteration_Scheme (Node));
2136                Write_Str_With_Col_Check_Sloc ("loop");
2137                Sprint_Indented_List (Statements (Node));
2138                Write_Indent_Str ("end loop ");
2139                Write_Rewrite_Str ("<<<");
2140                Write_Id (Identifier (Node));
2141                Write_Rewrite_Str (">>>");
2142                Write_Char (';');
2143
2144             else
2145                Sprint_Node (Iteration_Scheme (Node));
2146                Write_Str_With_Col_Check_Sloc ("loop");
2147                Sprint_Indented_List (Statements (Node));
2148                Write_Indent_Str ("end loop;");
2149             end if;
2150
2151          when N_Mod_Clause =>
2152             Sprint_Node_List (Pragmas_Before (Node));
2153             Write_Str_With_Col_Check_Sloc ("at mod ");
2154             Sprint_Node (Expression (Node));
2155
2156          when N_Modular_Type_Definition =>
2157             Write_Str_With_Col_Check_Sloc ("mod ");
2158             Sprint_Node (Expression (Node));
2159
2160          when N_Not_In =>
2161             Sprint_Left_Opnd (Node);
2162             Write_Str_Sloc (" not in ");
2163
2164             if Present (Right_Opnd (Node)) then
2165                Sprint_Right_Opnd (Node);
2166             else
2167                Sprint_Bar_List (Alternatives (Node));
2168             end if;
2169
2170          when N_Null =>
2171             Write_Str_With_Col_Check_Sloc ("null");
2172
2173          when N_Null_Statement =>
2174             if Comes_From_Source (Node)
2175               or else Dump_Freeze_Null
2176               or else not Is_List_Member (Node)
2177               or else (No (Prev (Node)) and then No (Next (Node)))
2178             then
2179                Write_Indent_Str_Sloc ("null;");
2180             end if;
2181
2182          when N_Number_Declaration =>
2183             Set_Debug_Sloc;
2184
2185             if Write_Indent_Identifiers (Node) then
2186                Write_Str_With_Col_Check (" : constant ");
2187                Write_Str (" := ");
2188                Sprint_Node (Expression (Node));
2189                Write_Char (';');
2190             end if;
2191
2192          when N_Object_Declaration =>
2193             Set_Debug_Sloc;
2194
2195             if Write_Indent_Identifiers (Node) then
2196                declare
2197                   Def_Id : constant Entity_Id := Defining_Identifier (Node);
2198
2199                begin
2200                   Write_Str_With_Col_Check (" : ");
2201
2202                   if Is_Statically_Allocated (Def_Id) then
2203                      Write_Str_With_Col_Check ("static ");
2204                   end if;
2205
2206                   if Aliased_Present (Node) then
2207                      Write_Str_With_Col_Check ("aliased ");
2208                   end if;
2209
2210                   if Constant_Present (Node) then
2211                      Write_Str_With_Col_Check ("constant ");
2212                   end if;
2213
2214                   --  Ada 2005 (AI-231)
2215
2216                   if Null_Exclusion_Present (Node) then
2217                      Write_Str_With_Col_Check ("not null ");
2218                   end if;
2219
2220                   Sprint_Node (Object_Definition (Node));
2221
2222                   if Present (Expression (Node)) then
2223                      Write_Str (" := ");
2224                      Sprint_Node (Expression (Node));
2225                   end if;
2226
2227                   Write_Char (';');
2228
2229                   --  Handle implicit importation and implicit exportation of
2230                   --  object declarations:
2231                   --    $pragma import (Convention_Id, Def_Id, "...");
2232                   --    $pragma export (Convention_Id, Def_Id, "...");
2233
2234                   if Is_Internal (Def_Id)
2235                     and then Present (Interface_Name (Def_Id))
2236                   then
2237                      Write_Indent_Str_Sloc ("$pragma ");
2238
2239                      if Is_Imported (Def_Id) then
2240                         Write_Str ("import (");
2241
2242                      else pragma Assert (Is_Exported (Def_Id));
2243                         Write_Str ("export (");
2244                      end if;
2245
2246                      declare
2247                         Prefix : constant String  := "Convention_";
2248                         S      : constant String  := Convention (Def_Id)'Img;
2249
2250                      begin
2251                         Name_Len := S'Last - Prefix'Last;
2252                         Name_Buffer (1 .. Name_Len) :=
2253                           S (Prefix'Last + 1 .. S'Last);
2254                         Set_Casing (All_Lower_Case);
2255                         Write_Str (Name_Buffer (1 .. Name_Len));
2256                      end;
2257
2258                      Write_Str (", ");
2259                      Write_Id  (Def_Id);
2260                      Write_Str (", ");
2261                      Write_String_Table_Entry
2262                        (Strval (Interface_Name (Def_Id)));
2263                      Write_Str (");");
2264                   end if;
2265                end;
2266             end if;
2267
2268          when N_Object_Renaming_Declaration =>
2269             Write_Indent;
2270             Set_Debug_Sloc;
2271             Sprint_Node (Defining_Identifier (Node));
2272             Write_Str (" : ");
2273
2274             --  Ada 2005 (AI-230): Access renamings
2275
2276             if Present (Access_Definition (Node)) then
2277                Sprint_Node (Access_Definition (Node));
2278
2279             elsif Present (Subtype_Mark (Node)) then
2280
2281                --  Ada 2005 (AI-423): Object renaming with a null exclusion
2282
2283                if Null_Exclusion_Present (Node) then
2284                   Write_Str ("not null ");
2285                end if;
2286
2287                Sprint_Node (Subtype_Mark (Node));
2288
2289             else
2290                Write_Str (" ??? ");
2291             end if;
2292
2293             Write_Str_With_Col_Check (" renames ");
2294             Sprint_Node (Name (Node));
2295             Write_Char (';');
2296
2297          when N_Op_Abs =>
2298             Write_Operator (Node, "abs ");
2299             Sprint_Right_Opnd (Node);
2300
2301          when N_Op_Add =>
2302             Sprint_Left_Opnd (Node);
2303             Write_Operator (Node, " + ");
2304             Sprint_Right_Opnd (Node);
2305
2306          when N_Op_And =>
2307             Sprint_Left_Opnd (Node);
2308             Write_Operator (Node, " and ");
2309             Sprint_Right_Opnd (Node);
2310
2311          when N_Op_Concat =>
2312             Sprint_Left_Opnd (Node);
2313             Write_Operator (Node, " & ");
2314             Sprint_Right_Opnd (Node);
2315
2316          when N_Op_Divide =>
2317             Sprint_Left_Opnd (Node);
2318             Write_Char (' ');
2319             Process_TFAI_RR_Flags (Node);
2320             Write_Operator (Node, "/ ");
2321             Sprint_Right_Opnd (Node);
2322
2323          when N_Op_Eq =>
2324             Sprint_Left_Opnd (Node);
2325             Write_Operator (Node, " = ");
2326             Sprint_Right_Opnd (Node);
2327
2328          when N_Op_Expon =>
2329             Sprint_Left_Opnd (Node);
2330             Write_Operator (Node, " ** ");
2331             Sprint_Right_Opnd (Node);
2332
2333          when N_Op_Ge =>
2334             Sprint_Left_Opnd (Node);
2335             Write_Operator (Node, " >= ");
2336             Sprint_Right_Opnd (Node);
2337
2338          when N_Op_Gt =>
2339             Sprint_Left_Opnd (Node);
2340             Write_Operator (Node, " > ");
2341             Sprint_Right_Opnd (Node);
2342
2343          when N_Op_Le =>
2344             Sprint_Left_Opnd (Node);
2345             Write_Operator (Node, " <= ");
2346             Sprint_Right_Opnd (Node);
2347
2348          when N_Op_Lt =>
2349             Sprint_Left_Opnd (Node);
2350             Write_Operator (Node, " < ");
2351             Sprint_Right_Opnd (Node);
2352
2353          when N_Op_Minus =>
2354             Write_Operator (Node, "-");
2355             Sprint_Right_Opnd (Node);
2356
2357          when N_Op_Mod =>
2358             Sprint_Left_Opnd (Node);
2359
2360             if Treat_Fixed_As_Integer (Node) then
2361                Write_Str (" #");
2362             end if;
2363
2364             Write_Operator (Node, " mod ");
2365             Sprint_Right_Opnd (Node);
2366
2367          when N_Op_Multiply =>
2368             Sprint_Left_Opnd (Node);
2369             Write_Char (' ');
2370             Process_TFAI_RR_Flags (Node);
2371             Write_Operator (Node, "* ");
2372             Sprint_Right_Opnd (Node);
2373
2374          when N_Op_Ne =>
2375             Sprint_Left_Opnd (Node);
2376             Write_Operator (Node, " /= ");
2377             Sprint_Right_Opnd (Node);
2378
2379          when N_Op_Not =>
2380             Write_Operator (Node, "not ");
2381             Sprint_Right_Opnd (Node);
2382
2383          when N_Op_Or =>
2384             Sprint_Left_Opnd (Node);
2385             Write_Operator (Node, " or ");
2386             Sprint_Right_Opnd (Node);
2387
2388          when N_Op_Plus =>
2389             Write_Operator (Node, "+");
2390             Sprint_Right_Opnd (Node);
2391
2392          when N_Op_Rem =>
2393             Sprint_Left_Opnd (Node);
2394
2395             if Treat_Fixed_As_Integer (Node) then
2396                Write_Str (" #");
2397             end if;
2398
2399             Write_Operator (Node, " rem ");
2400             Sprint_Right_Opnd (Node);
2401
2402          when N_Op_Shift =>
2403             Set_Debug_Sloc;
2404             Write_Id (Node);
2405             Write_Char ('!');
2406             Write_Str_With_Col_Check ("(");
2407             Sprint_Node (Left_Opnd (Node));
2408             Write_Str (", ");
2409             Sprint_Node (Right_Opnd (Node));
2410             Write_Char (')');
2411
2412          when N_Op_Subtract =>
2413             Sprint_Left_Opnd (Node);
2414             Write_Operator (Node, " - ");
2415             Sprint_Right_Opnd (Node);
2416
2417          when N_Op_Xor =>
2418             Sprint_Left_Opnd (Node);
2419             Write_Operator (Node, " xor ");
2420             Sprint_Right_Opnd (Node);
2421
2422          when N_Operator_Symbol =>
2423             Write_Name_With_Col_Check_Sloc (Chars (Node));
2424
2425          when N_Ordinary_Fixed_Point_Definition =>
2426             Write_Str_With_Col_Check_Sloc ("delta ");
2427             Sprint_Node (Delta_Expression (Node));
2428             Sprint_Opt_Node (Real_Range_Specification (Node));
2429
2430          when N_Or_Else =>
2431             Sprint_Left_Opnd (Node);
2432             Write_Str_Sloc (" or else ");
2433             Sprint_Right_Opnd (Node);
2434
2435          when N_Others_Choice =>
2436             if All_Others (Node) then
2437                Write_Str_With_Col_Check ("all ");
2438             end if;
2439
2440             Write_Str_With_Col_Check_Sloc ("others");
2441
2442          when N_Package_Body =>
2443             Extra_Blank_Line;
2444             Write_Indent_Str_Sloc ("package body ");
2445             Sprint_Node (Defining_Unit_Name (Node));
2446             Write_Str (" is");
2447             Sprint_Indented_List (Declarations (Node));
2448
2449             if Present (Handled_Statement_Sequence (Node)) then
2450                Write_Indent_Str ("begin");
2451                Sprint_Node (Handled_Statement_Sequence (Node));
2452             end if;
2453
2454             Write_Indent_Str ("end ");
2455             Sprint_End_Label
2456               (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
2457             Write_Char (';');
2458
2459          when N_Package_Body_Stub =>
2460             Write_Indent_Str_Sloc ("package body ");
2461             Sprint_Node (Defining_Identifier (Node));
2462             Write_Str_With_Col_Check (" is separate;");
2463
2464          when N_Package_Declaration =>
2465             Extra_Blank_Line;
2466             Write_Indent;
2467             Sprint_Node_Sloc (Specification (Node));
2468             Write_Char (';');
2469
2470          when N_Package_Instantiation =>
2471             Extra_Blank_Line;
2472             Write_Indent_Str_Sloc ("package ");
2473             Sprint_Node (Defining_Unit_Name (Node));
2474             Write_Str (" is new ");
2475             Sprint_Node (Name (Node));
2476             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2477             Write_Char (';');
2478
2479          when N_Package_Renaming_Declaration =>
2480             Write_Indent_Str_Sloc ("package ");
2481             Sprint_Node (Defining_Unit_Name (Node));
2482             Write_Str_With_Col_Check (" renames ");
2483             Sprint_Node (Name (Node));
2484             Write_Char (';');
2485
2486          when N_Package_Specification =>
2487             Write_Str_With_Col_Check_Sloc ("package ");
2488             Sprint_Node (Defining_Unit_Name (Node));
2489
2490             if Nkind (Parent (Node)) = N_Package_Declaration
2491               and then Has_Aspects (Parent (Node))
2492             then
2493                Sprint_Aspect_Specifications
2494                  (Parent (Node), Semicolon => False);
2495             end if;
2496
2497             Write_Str (" is");
2498             Sprint_Indented_List (Visible_Declarations (Node));
2499
2500             if Present (Private_Declarations (Node)) then
2501                Write_Indent_Str ("private");
2502                Sprint_Indented_List (Private_Declarations (Node));
2503             end if;
2504
2505             Write_Indent_Str ("end ");
2506             Sprint_Node (Defining_Unit_Name (Node));
2507
2508          when N_Parameter_Association =>
2509             Sprint_Node_Sloc (Selector_Name (Node));
2510             Write_Str (" => ");
2511             Sprint_Node (Explicit_Actual_Parameter (Node));
2512
2513          when N_Parameter_Specification =>
2514             Set_Debug_Sloc;
2515
2516             if Write_Identifiers (Node) then
2517                Write_Str (" : ");
2518
2519                if In_Present (Node) then
2520                   Write_Str_With_Col_Check ("in ");
2521                end if;
2522
2523                if Out_Present (Node) then
2524                   Write_Str_With_Col_Check ("out ");
2525                end if;
2526
2527                --  Ada 2005 (AI-231): Parameter specification may carry null
2528                --  exclusion. Do not print it now if this is an access formal,
2529                --  it is emitted when the access definition is displayed.
2530
2531                if Null_Exclusion_Present (Node)
2532                  and then Nkind (Parameter_Type (Node))
2533                    /= N_Access_Definition
2534                then
2535                   Write_Str ("not null ");
2536                end if;
2537
2538                Sprint_Node (Parameter_Type (Node));
2539
2540                if Present (Expression (Node)) then
2541                   Write_Str (" := ");
2542                   Sprint_Node (Expression (Node));
2543                end if;
2544             else
2545                Write_Str (", ");
2546             end if;
2547
2548          when N_Pop_Constraint_Error_Label =>
2549             Write_Indent_Str ("%pop_constraint_error_label");
2550
2551          when N_Pop_Program_Error_Label =>
2552             Write_Indent_Str ("%pop_program_error_label");
2553
2554          when N_Pop_Storage_Error_Label =>
2555             Write_Indent_Str ("%pop_storage_error_label");
2556
2557          when N_Private_Extension_Declaration =>
2558             Write_Indent_Str_Sloc ("type ");
2559             Write_Id (Defining_Identifier (Node));
2560
2561             if Present (Discriminant_Specifications (Node)) then
2562                Write_Discr_Specs (Node);
2563             elsif Unknown_Discriminants_Present (Node) then
2564                Write_Str_With_Col_Check ("(<>)");
2565             end if;
2566
2567             Write_Str_With_Col_Check (" is new ");
2568             Sprint_Node (Subtype_Indication (Node));
2569
2570             if Present (Interface_List (Node)) then
2571                Write_Str_With_Col_Check (" and ");
2572                Sprint_And_List (Interface_List (Node));
2573             end if;
2574
2575             Write_Str_With_Col_Check (" with private;");
2576
2577          when N_Private_Type_Declaration =>
2578             Write_Indent_Str_Sloc ("type ");
2579             Write_Id (Defining_Identifier (Node));
2580
2581             if Present (Discriminant_Specifications (Node)) then
2582                Write_Discr_Specs (Node);
2583             elsif Unknown_Discriminants_Present (Node) then
2584                Write_Str_With_Col_Check ("(<>)");
2585             end if;
2586
2587             Write_Str (" is ");
2588
2589             if Tagged_Present (Node) then
2590                Write_Str_With_Col_Check ("tagged ");
2591             end if;
2592
2593             if Limited_Present (Node) then
2594                Write_Str_With_Col_Check ("limited ");
2595             end if;
2596
2597             Write_Str_With_Col_Check ("private;");
2598
2599          when N_Push_Constraint_Error_Label =>
2600             Write_Indent_Str ("%push_constraint_error_label (");
2601
2602             if Present (Exception_Label (Node)) then
2603                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2604             end if;
2605
2606             Write_Str (")");
2607
2608          when N_Push_Program_Error_Label =>
2609             Write_Indent_Str ("%push_program_error_label (");
2610
2611             if Present (Exception_Label (Node)) then
2612                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2613             end if;
2614
2615             Write_Str (")");
2616
2617          when N_Push_Storage_Error_Label =>
2618             Write_Indent_Str ("%push_storage_error_label (");
2619
2620             if Present (Exception_Label (Node)) then
2621                Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2622             end if;
2623
2624             Write_Str (")");
2625
2626          when N_Pragma =>
2627             Write_Indent_Str_Sloc ("pragma ");
2628             Write_Name_With_Col_Check (Pragma_Name (Node));
2629
2630             if Present (Pragma_Argument_Associations (Node)) then
2631                Sprint_Opt_Paren_Comma_List
2632                  (Pragma_Argument_Associations (Node));
2633             end if;
2634
2635             Write_Char (';');
2636
2637          when N_Pragma_Argument_Association =>
2638             Set_Debug_Sloc;
2639
2640             if Chars (Node) /= No_Name then
2641                Write_Name_With_Col_Check (Chars (Node));
2642                Write_Str (" => ");
2643             end if;
2644
2645             Sprint_Node (Expression (Node));
2646
2647          when N_Procedure_Call_Statement =>
2648             Write_Indent;
2649             Set_Debug_Sloc;
2650             Write_Subprogram_Name (Name (Node));
2651             Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
2652             Write_Char (';');
2653
2654          when N_Procedure_Instantiation =>
2655             Write_Indent_Str_Sloc ("procedure ");
2656             Sprint_Node (Defining_Unit_Name (Node));
2657             Write_Str_With_Col_Check (" is new ");
2658             Sprint_Node (Name (Node));
2659             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2660             Write_Char (';');
2661
2662          when N_Procedure_Specification =>
2663             Write_Str_With_Col_Check_Sloc ("procedure ");
2664             Sprint_Node (Defining_Unit_Name (Node));
2665             Write_Param_Specs (Node);
2666
2667          when N_Protected_Body =>
2668             Write_Indent_Str_Sloc ("protected body ");
2669             Write_Id (Defining_Identifier (Node));
2670             Write_Str (" is");
2671             Sprint_Indented_List (Declarations (Node));
2672             Write_Indent_Str ("end ");
2673             Write_Id (Defining_Identifier (Node));
2674             Write_Char (';');
2675
2676          when N_Protected_Body_Stub =>
2677             Write_Indent_Str_Sloc ("protected body ");
2678             Write_Id (Defining_Identifier (Node));
2679             Write_Str_With_Col_Check (" is separate;");
2680
2681          when N_Protected_Definition =>
2682             Set_Debug_Sloc;
2683             Sprint_Indented_List (Visible_Declarations (Node));
2684
2685             if Present (Private_Declarations (Node)) then
2686                Write_Indent_Str ("private");
2687                Sprint_Indented_List (Private_Declarations (Node));
2688             end if;
2689
2690             Write_Indent_Str ("end ");
2691
2692          when N_Protected_Type_Declaration =>
2693             Write_Indent_Str_Sloc ("protected type ");
2694             Sprint_Node (Defining_Identifier (Node));
2695             Write_Discr_Specs (Node);
2696
2697             if Present (Interface_List (Node)) then
2698                Write_Str (" is new ");
2699                Sprint_And_List (Interface_List (Node));
2700                Write_Str (" with ");
2701             else
2702                Write_Str (" is");
2703             end if;
2704
2705             Sprint_Node (Protected_Definition (Node));
2706             Write_Id (Defining_Identifier (Node));
2707             Write_Char (';');
2708
2709          when N_Qualified_Expression =>
2710             Sprint_Node (Subtype_Mark (Node));
2711             Write_Char_Sloc (''');
2712
2713             --  Print expression, make sure we have at least one level of
2714             --  parentheses around the expression. For cases of qualified
2715             --  expressions in the source, this is always the case, but
2716             --  for generated qualifications, there may be no explicit
2717             --  parentheses present.
2718
2719             if Paren_Count (Expression (Node)) /= 0 then
2720                Sprint_Node (Expression (Node));
2721
2722             else
2723                Write_Char ('(');
2724                Sprint_Node (Expression (Node));
2725
2726                --  Odd case, for the qualified expressions used in machine
2727                --  code the argument may be a procedure call, resulting in
2728                --  a junk semicolon before the right parent, get rid of it.
2729
2730                Write_Erase_Char (';');
2731
2732                --  Now we can add the terminating right paren
2733
2734                Write_Char (')');
2735             end if;
2736
2737          when N_Quantified_Expression =>
2738             Write_Str (" for");
2739
2740             if All_Present (Node) then
2741                Write_Str (" all ");
2742             else
2743                Write_Str (" some ");
2744             end if;
2745
2746             if Present (Iterator_Specification (Node)) then
2747                Sprint_Node (Iterator_Specification (Node));
2748             else
2749                Sprint_Node (Loop_Parameter_Specification (Node));
2750             end if;
2751
2752             Write_Str (" => ");
2753             Sprint_Node (Condition (Node));
2754
2755          when N_Raise_Constraint_Error =>
2756
2757             --  This node can be used either as a subexpression or as a
2758             --  statement form. The following test is a reasonably reliable
2759             --  way to distinguish the two cases.
2760
2761             if Is_List_Member (Node)
2762               and then Nkind (Parent (Node)) not in N_Subexpr
2763             then
2764                Write_Indent;
2765             end if;
2766
2767             Write_Str_With_Col_Check_Sloc ("[constraint_error");
2768             Write_Condition_And_Reason (Node);
2769
2770          when N_Raise_Program_Error =>
2771
2772             --  This node can be used either as a subexpression or as a
2773             --  statement form. The following test is a reasonably reliable
2774             --  way to distinguish the two cases.
2775
2776             if Is_List_Member (Node)
2777               and then Nkind (Parent (Node)) not in N_Subexpr
2778             then
2779                Write_Indent;
2780             end if;
2781
2782             Write_Str_With_Col_Check_Sloc ("[program_error");
2783             Write_Condition_And_Reason (Node);
2784
2785          when N_Raise_Storage_Error =>
2786
2787             --  This node can be used either as a subexpression or as a
2788             --  statement form. The following test is a reasonably reliable
2789             --  way to distinguish the two cases.
2790
2791             if Is_List_Member (Node)
2792               and then Nkind (Parent (Node)) not in N_Subexpr
2793             then
2794                Write_Indent;
2795             end if;
2796
2797             Write_Str_With_Col_Check_Sloc ("[storage_error");
2798             Write_Condition_And_Reason (Node);
2799
2800          when N_Raise_Statement =>
2801             Write_Indent_Str_Sloc ("raise ");
2802             Sprint_Node (Name (Node));
2803             Write_Char (';');
2804
2805          when N_Range =>
2806             Sprint_Node (Low_Bound (Node));
2807             Write_Str_Sloc (" .. ");
2808             Sprint_Node (High_Bound (Node));
2809             Update_Itype (Node);
2810
2811          when N_Range_Constraint =>
2812             Write_Str_With_Col_Check_Sloc ("range ");
2813             Sprint_Node (Range_Expression (Node));
2814
2815          when N_Real_Literal =>
2816             Write_Ureal_With_Col_Check_Sloc (Realval (Node));
2817
2818          when N_Real_Range_Specification =>
2819             Write_Str_With_Col_Check_Sloc ("range ");
2820             Sprint_Node (Low_Bound (Node));
2821             Write_Str (" .. ");
2822             Sprint_Node (High_Bound (Node));
2823
2824          when N_Record_Definition =>
2825             if Abstract_Present (Node) then
2826                Write_Str_With_Col_Check ("abstract ");
2827             end if;
2828
2829             if Tagged_Present (Node) then
2830                Write_Str_With_Col_Check ("tagged ");
2831             end if;
2832
2833             if Limited_Present (Node) then
2834                Write_Str_With_Col_Check ("limited ");
2835             end if;
2836
2837             if Null_Present (Node) then
2838                Write_Str_With_Col_Check_Sloc ("null record");
2839
2840             else
2841                Write_Str_With_Col_Check_Sloc ("record");
2842                Sprint_Node (Component_List (Node));
2843                Write_Indent_Str ("end record");
2844             end if;
2845
2846          when N_Record_Representation_Clause =>
2847             Write_Indent_Str_Sloc ("for ");
2848             Sprint_Node (Identifier (Node));
2849             Write_Str_With_Col_Check (" use record ");
2850
2851             if Present (Mod_Clause (Node)) then
2852                Sprint_Node (Mod_Clause (Node));
2853             end if;
2854
2855             Sprint_Indented_List (Component_Clauses (Node));
2856             Write_Indent_Str ("end record;");
2857
2858          when N_Reference =>
2859             Sprint_Node (Prefix (Node));
2860             Write_Str_With_Col_Check_Sloc ("'reference");
2861
2862          when N_Requeue_Statement =>
2863             Write_Indent_Str_Sloc ("requeue ");
2864             Sprint_Node (Name (Node));
2865
2866             if Abort_Present (Node) then
2867                Write_Str_With_Col_Check (" with abort");
2868             end if;
2869
2870             Write_Char (';');
2871
2872          --  Don't we want to print more detail???
2873
2874          --  Doc of this extended syntax belongs in sinfo.ads and/or
2875          --  sprint.ads ???
2876
2877          when N_SCIL_Dispatch_Table_Tag_Init =>
2878             Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
2879
2880          when N_SCIL_Dispatching_Call =>
2881             Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
2882
2883          when N_SCIL_Membership_Test =>
2884             Write_Indent_Str ("[N_SCIL_Membership_Test]");
2885
2886          when N_Simple_Return_Statement =>
2887             if Present (Expression (Node)) then
2888                Write_Indent_Str_Sloc ("return ");
2889                Sprint_Node (Expression (Node));
2890                Write_Char (';');
2891             else
2892                Write_Indent_Str_Sloc ("return;");
2893             end if;
2894
2895          when N_Selective_Accept =>
2896             Write_Indent_Str_Sloc ("select");
2897
2898             declare
2899                Alt_Node : Node_Id;
2900             begin
2901                Alt_Node := First (Select_Alternatives (Node));
2902                loop
2903                   Indent_Begin;
2904                   Sprint_Node (Alt_Node);
2905                   Indent_End;
2906                   Next (Alt_Node);
2907                   exit when No (Alt_Node);
2908                   Write_Indent_Str ("or");
2909                end loop;
2910             end;
2911
2912             if Present (Else_Statements (Node)) then
2913                Write_Indent_Str ("else");
2914                Sprint_Indented_List (Else_Statements (Node));
2915             end if;
2916
2917             Write_Indent_Str ("end select;");
2918
2919          when N_Signed_Integer_Type_Definition =>
2920             Write_Str_With_Col_Check_Sloc ("range ");
2921             Sprint_Node (Low_Bound (Node));
2922             Write_Str (" .. ");
2923             Sprint_Node (High_Bound (Node));
2924
2925          when N_Single_Protected_Declaration =>
2926             Write_Indent_Str_Sloc ("protected ");
2927             Write_Id (Defining_Identifier (Node));
2928             Write_Str (" is");
2929             Sprint_Node (Protected_Definition (Node));
2930             Write_Id (Defining_Identifier (Node));
2931             Write_Char (';');
2932
2933          when N_Single_Task_Declaration =>
2934             Write_Indent_Str_Sloc ("task ");
2935             Sprint_Node (Defining_Identifier (Node));
2936
2937             if Present (Task_Definition (Node)) then
2938                Write_Str (" is");
2939                Sprint_Node (Task_Definition (Node));
2940             end if;
2941
2942             Write_Char (';');
2943
2944          when N_Selected_Component =>
2945             Sprint_Node (Prefix (Node));
2946             Write_Char_Sloc ('.');
2947             Sprint_Node (Selector_Name (Node));
2948
2949          when N_Slice =>
2950             Set_Debug_Sloc;
2951             Sprint_Node (Prefix (Node));
2952             Write_Str_With_Col_Check (" (");
2953             Sprint_Node (Discrete_Range (Node));
2954             Write_Char (')');
2955
2956          when N_String_Literal =>
2957             if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then
2958                Write_Indent_Str ("  ");
2959             end if;
2960
2961             Set_Debug_Sloc;
2962             Write_String_Table_Entry (Strval (Node));
2963
2964          when N_Subprogram_Body =>
2965
2966             --  Output extra blank line unless we are in freeze actions
2967
2968             if Freeze_Indent = 0 then
2969                Extra_Blank_Line;
2970             end if;
2971
2972             Write_Indent;
2973
2974             if Present (Corresponding_Spec (Node)) then
2975                Sprint_Node_Sloc (Parent (Corresponding_Spec (Node)));
2976             else
2977                Sprint_Node_Sloc (Specification (Node));
2978             end if;
2979
2980             Write_Str (" is");
2981
2982             Sprint_Indented_List (Declarations (Node));
2983             Write_Indent_Str ("begin");
2984             Sprint_Node (Handled_Statement_Sequence (Node));
2985
2986             Write_Indent_Str ("end ");
2987
2988             Sprint_End_Label
2989               (Handled_Statement_Sequence (Node),
2990                  Defining_Unit_Name (Specification (Node)));
2991             Write_Char (';');
2992
2993             if Is_List_Member (Node)
2994               and then Present (Next (Node))
2995               and then Nkind (Next (Node)) /= N_Subprogram_Body
2996             then
2997                Write_Indent;
2998             end if;
2999
3000          when N_Subprogram_Body_Stub =>
3001             Write_Indent;
3002             Sprint_Node_Sloc (Specification (Node));
3003             Write_Str_With_Col_Check (" is separate;");
3004
3005          when N_Subprogram_Declaration =>
3006             Write_Indent;
3007             Sprint_Node_Sloc (Specification (Node));
3008
3009             if Nkind (Specification (Node)) = N_Procedure_Specification
3010               and then Null_Present (Specification (Node))
3011             then
3012                Write_Str_With_Col_Check (" is null");
3013             end if;
3014
3015             Write_Char (';');
3016
3017          when N_Subprogram_Info =>
3018             Sprint_Node (Identifier (Node));
3019             Write_Str_With_Col_Check_Sloc ("'subprogram_info");
3020
3021          when N_Subprogram_Renaming_Declaration =>
3022             Write_Indent;
3023             Sprint_Node (Specification (Node));
3024             Write_Str_With_Col_Check_Sloc (" renames ");
3025             Sprint_Node (Name (Node));
3026             Write_Char (';');
3027
3028          when N_Subtype_Declaration =>
3029             Write_Indent_Str_Sloc ("subtype ");
3030             Sprint_Node (Defining_Identifier (Node));
3031             Write_Str (" is ");
3032
3033             --  Ada 2005 (AI-231)
3034
3035             if Null_Exclusion_Present (Node) then
3036                Write_Str ("not null ");
3037             end if;
3038
3039             Sprint_Node (Subtype_Indication (Node));
3040             Write_Char (';');
3041
3042          when N_Subtype_Indication =>
3043             Sprint_Node_Sloc (Subtype_Mark (Node));
3044             Write_Char (' ');
3045             Sprint_Node (Constraint (Node));
3046
3047          when N_Subunit =>
3048             Write_Indent_Str_Sloc ("separate (");
3049             Sprint_Node (Name (Node));
3050             Write_Char (')');
3051             Extra_Blank_Line;
3052             Sprint_Node (Proper_Body (Node));
3053
3054          when N_Task_Body =>
3055             Write_Indent_Str_Sloc ("task body ");
3056             Write_Id (Defining_Identifier (Node));
3057             Write_Str (" is");
3058             Sprint_Indented_List (Declarations (Node));
3059             Write_Indent_Str ("begin");
3060             Sprint_Node (Handled_Statement_Sequence (Node));
3061             Write_Indent_Str ("end ");
3062             Sprint_End_Label
3063               (Handled_Statement_Sequence (Node), Defining_Identifier (Node));
3064             Write_Char (';');
3065
3066          when N_Task_Body_Stub =>
3067             Write_Indent_Str_Sloc ("task body ");
3068             Write_Id (Defining_Identifier (Node));
3069             Write_Str_With_Col_Check (" is separate;");
3070
3071          when N_Task_Definition =>
3072             Set_Debug_Sloc;
3073             Sprint_Indented_List (Visible_Declarations (Node));
3074
3075             if Present (Private_Declarations (Node)) then
3076                Write_Indent_Str ("private");
3077                Sprint_Indented_List (Private_Declarations (Node));
3078             end if;
3079
3080             Write_Indent_Str ("end ");
3081             Sprint_End_Label (Node, Defining_Identifier (Parent (Node)));
3082
3083          when N_Task_Type_Declaration =>
3084             Write_Indent_Str_Sloc ("task type ");
3085             Sprint_Node (Defining_Identifier (Node));
3086             Write_Discr_Specs (Node);
3087
3088             if Present (Interface_List (Node)) then
3089                Write_Str (" is new ");
3090                Sprint_And_List (Interface_List (Node));
3091             end if;
3092
3093             if Present (Task_Definition (Node)) then
3094                if No (Interface_List (Node)) then
3095                   Write_Str (" is");
3096                else
3097                   Write_Str (" with ");
3098                end if;
3099
3100                Sprint_Node (Task_Definition (Node));
3101             end if;
3102
3103             Write_Char (';');
3104
3105          when N_Terminate_Alternative =>
3106             Sprint_Node_List (Pragmas_Before (Node));
3107             Write_Indent;
3108
3109             if Present (Condition (Node)) then
3110                Write_Str_With_Col_Check ("when ");
3111                Sprint_Node (Condition (Node));
3112                Write_Str (" => ");
3113             end if;
3114
3115             Write_Str_With_Col_Check_Sloc ("terminate;");
3116             Sprint_Node_List (Pragmas_After (Node));
3117
3118          when N_Timed_Entry_Call =>
3119             Write_Indent_Str_Sloc ("select");
3120             Indent_Begin;
3121             Sprint_Node (Entry_Call_Alternative (Node));
3122             Indent_End;
3123             Write_Indent_Str ("or");
3124             Indent_Begin;
3125             Sprint_Node (Delay_Alternative (Node));
3126             Indent_End;
3127             Write_Indent_Str ("end select;");
3128
3129          when N_Triggering_Alternative =>
3130             Sprint_Node_List (Pragmas_Before (Node));
3131             Sprint_Node_Sloc (Triggering_Statement (Node));
3132             Sprint_Node_List (Statements (Node));
3133
3134          when N_Type_Conversion =>
3135             Set_Debug_Sloc;
3136             Sprint_Node (Subtype_Mark (Node));
3137             Col_Check (4);
3138
3139             if Conversion_OK (Node) then
3140                Write_Char ('?');
3141             end if;
3142
3143             if Float_Truncate (Node) then
3144                Write_Char ('^');
3145             end if;
3146
3147             if Rounded_Result (Node) then
3148                Write_Char ('@');
3149             end if;
3150
3151             Write_Char ('(');
3152             Sprint_Node (Expression (Node));
3153             Write_Char (')');
3154
3155          when N_Unchecked_Expression =>
3156             Col_Check (10);
3157             Write_Str ("`(");
3158             Sprint_Node_Sloc (Expression (Node));
3159             Write_Char (')');
3160
3161          when N_Unchecked_Type_Conversion =>
3162             Sprint_Node (Subtype_Mark (Node));
3163             Write_Char ('!');
3164             Write_Str_With_Col_Check ("(");
3165             Sprint_Node_Sloc (Expression (Node));
3166             Write_Char (')');
3167
3168          when N_Unconstrained_Array_Definition =>
3169             Write_Str_With_Col_Check_Sloc ("array (");
3170
3171             declare
3172                Node1 : Node_Id;
3173             begin
3174                Node1 := First (Subtype_Marks (Node));
3175                loop
3176                   Sprint_Node (Node1);
3177                   Write_Str_With_Col_Check (" range <>");
3178                   Next (Node1);
3179                   exit when Node1 = Empty;
3180                   Write_Str (", ");
3181                end loop;
3182             end;
3183
3184             Write_Str (") of ");
3185             Sprint_Node (Component_Definition (Node));
3186
3187          when N_Unused_At_Start | N_Unused_At_End =>
3188             Write_Indent_Str ("***** Error, unused node encountered *****");
3189             Write_Eol;
3190
3191          when N_Use_Package_Clause =>
3192             Write_Indent_Str_Sloc ("use ");
3193             Sprint_Comma_List (Names (Node));
3194             Write_Char (';');
3195
3196          when N_Use_Type_Clause =>
3197             Write_Indent_Str_Sloc ("use type ");
3198             Sprint_Comma_List (Subtype_Marks (Node));
3199             Write_Char (';');
3200
3201          when N_Validate_Unchecked_Conversion =>
3202             Write_Indent_Str_Sloc ("validate unchecked_conversion (");
3203             Sprint_Node (Source_Type (Node));
3204             Write_Str (", ");
3205             Sprint_Node (Target_Type (Node));
3206             Write_Str (");");
3207
3208          when N_Variant =>
3209             Write_Indent_Str_Sloc ("when ");
3210             Sprint_Bar_List (Discrete_Choices (Node));
3211             Write_Str (" => ");
3212             Sprint_Node (Component_List (Node));
3213
3214          when N_Variant_Part =>
3215             Indent_Begin;
3216             Write_Indent_Str_Sloc ("case ");
3217             Sprint_Node (Name (Node));
3218             Write_Str (" is ");
3219             Sprint_Indented_List (Variants (Node));
3220             Write_Indent_Str ("end case");
3221             Indent_End;
3222
3223          when N_With_Clause =>
3224
3225             --  Special test, if we are dumping the original tree only,
3226             --  then we want to eliminate the bogus with clauses that
3227             --  correspond to the non-existent children of Text_IO.
3228
3229             if Dump_Original_Only
3230               and then Is_Text_IO_Kludge_Unit (Name (Node))
3231             then
3232                null;
3233
3234             --  Normal case, output the with clause
3235
3236             else
3237                if First_Name (Node) or else not Dump_Original_Only then
3238
3239                   --  Ada 2005 (AI-50217): Print limited with_clauses
3240
3241                   if Private_Present (Node) and Limited_Present (Node) then
3242                      Write_Indent_Str ("limited private with ");
3243
3244                   elsif Private_Present (Node) then
3245                      Write_Indent_Str ("private with ");
3246
3247                   elsif Limited_Present (Node) then
3248                      Write_Indent_Str ("limited with ");
3249
3250                   else
3251                      Write_Indent_Str ("with ");
3252                   end if;
3253
3254                else
3255                   Write_Str (", ");
3256                end if;
3257
3258                Sprint_Node_Sloc (Name (Node));
3259
3260                if Last_Name (Node) or else not Dump_Original_Only then
3261                   Write_Char (';');
3262                end if;
3263             end if;
3264       end case;
3265
3266       --  Print aspects, except for special case of package declaration,
3267       --  where the aspects are printed inside the package specification.
3268
3269       if Has_Aspects (Node) and Nkind (Node) /= N_Package_Declaration then
3270          Sprint_Aspect_Specifications (Node, Semicolon => True);
3271       end if;
3272
3273       if Nkind (Node) in N_Subexpr
3274         and then Do_Range_Check (Node)
3275       then
3276          Write_Str ("}");
3277       end if;
3278
3279       for J in 1 .. Paren_Count (Node) loop
3280          Write_Char (')');
3281       end loop;
3282
3283       Dump_Node := Save_Dump_Node;
3284    end Sprint_Node_Actual;
3285
3286    ----------------------
3287    -- Sprint_Node_List --
3288    ----------------------
3289
3290    procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is
3291       Node : Node_Id;
3292
3293    begin
3294       if Is_Non_Empty_List (List) then
3295          Node := First (List);
3296
3297          loop
3298             Sprint_Node (Node);
3299             Next (Node);
3300             exit when Node = Empty;
3301          end loop;
3302       end if;
3303
3304       if New_Lines and then Column /= 1 then
3305          Write_Eol;
3306       end if;
3307    end Sprint_Node_List;
3308
3309    ----------------------
3310    -- Sprint_Node_Sloc --
3311    ----------------------
3312
3313    procedure Sprint_Node_Sloc (Node : Node_Id) is
3314    begin
3315       Sprint_Node (Node);
3316
3317       if Debug_Generated_Code and then Present (Dump_Node) then
3318          Set_Sloc (Dump_Node, Sloc (Node));
3319          Dump_Node := Empty;
3320       end if;
3321    end Sprint_Node_Sloc;
3322
3323    ---------------------
3324    -- Sprint_Opt_Node --
3325    ---------------------
3326
3327    procedure Sprint_Opt_Node (Node : Node_Id) is
3328    begin
3329       if Present (Node) then
3330          Write_Char (' ');
3331          Sprint_Node (Node);
3332       end if;
3333    end Sprint_Opt_Node;
3334
3335    --------------------------
3336    -- Sprint_Opt_Node_List --
3337    --------------------------
3338
3339    procedure Sprint_Opt_Node_List (List : List_Id) is
3340    begin
3341       if Present (List) then
3342          Sprint_Node_List (List);
3343       end if;
3344    end Sprint_Opt_Node_List;
3345
3346    ---------------------------------
3347    -- Sprint_Opt_Paren_Comma_List --
3348    ---------------------------------
3349
3350    procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
3351    begin
3352       if Is_Non_Empty_List (List) then
3353          Write_Char (' ');
3354          Sprint_Paren_Comma_List (List);
3355       end if;
3356    end Sprint_Opt_Paren_Comma_List;
3357
3358    -----------------------------
3359    -- Sprint_Paren_Comma_List --
3360    -----------------------------
3361
3362    procedure Sprint_Paren_Comma_List (List : List_Id) is
3363       N           : Node_Id;
3364       Node_Exists : Boolean := False;
3365
3366    begin
3367
3368       if Is_Non_Empty_List (List) then
3369
3370          if Dump_Original_Only then
3371             N := First (List);
3372             while Present (N) loop
3373                if not Is_Rewrite_Insertion (N) then
3374                   Node_Exists := True;
3375                   exit;
3376                end if;
3377
3378                Next (N);
3379             end loop;
3380
3381             if not Node_Exists then
3382                return;
3383             end if;
3384          end if;
3385
3386          Write_Str_With_Col_Check ("(");
3387          Sprint_Comma_List (List);
3388          Write_Char (')');
3389       end if;
3390    end Sprint_Paren_Comma_List;
3391
3392    ----------------------
3393    -- Sprint_Right_Opnd --
3394    ----------------------
3395
3396    procedure Sprint_Right_Opnd (N : Node_Id) is
3397       Opnd : constant Node_Id := Right_Opnd (N);
3398
3399    begin
3400       if Paren_Count (Opnd) /= 0
3401         or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N))
3402       then
3403          Sprint_Node (Opnd);
3404
3405       else
3406          Write_Char ('(');
3407          Sprint_Node (Opnd);
3408          Write_Char (')');
3409       end if;
3410    end Sprint_Right_Opnd;
3411
3412    ------------------
3413    -- Update_Itype --
3414    ------------------
3415
3416    procedure Update_Itype (Node : Node_Id) is
3417    begin
3418       if Present (Etype (Node))
3419         and then Is_Itype (Etype (Node))
3420         and then Debug_Generated_Code
3421       then
3422          Set_Sloc (Etype (Node), Sloc (Node));
3423       end if;
3424    end Update_Itype;
3425
3426    ---------------------
3427    -- Write_Char_Sloc --
3428    ---------------------
3429
3430    procedure Write_Char_Sloc (C : Character) is
3431    begin
3432       if Debug_Generated_Code and then C /= ' ' then
3433          Set_Debug_Sloc;
3434       end if;
3435
3436       Write_Char (C);
3437    end Write_Char_Sloc;
3438
3439    --------------------------------
3440    -- Write_Condition_And_Reason --
3441    --------------------------------
3442
3443    procedure Write_Condition_And_Reason (Node : Node_Id) is
3444       Cond  : constant Node_Id := Condition (Node);
3445       Image : constant String  := RT_Exception_Code'Image
3446                                     (RT_Exception_Code'Val
3447                                        (UI_To_Int (Reason (Node))));
3448
3449    begin
3450       if Present (Cond) then
3451
3452          --  If condition is a single entity, or NOT with a single entity,
3453          --  output all on one line, since it will likely fit just fine.
3454
3455          if Is_Entity_Name (Cond)
3456            or else (Nkind (Cond) = N_Op_Not
3457                      and then Is_Entity_Name (Right_Opnd (Cond)))
3458          then
3459             Write_Str_With_Col_Check (" when ");
3460             Sprint_Node (Cond);
3461             Write_Char (' ');
3462
3463             --  Otherwise for more complex condition, multiple lines
3464
3465          else
3466             Write_Str_With_Col_Check (" when");
3467             Indent := Indent + 2;
3468             Write_Indent;
3469             Sprint_Node (Cond);
3470             Write_Indent;
3471             Indent := Indent - 2;
3472          end if;
3473
3474       --  If no condition, just need a space (all on one line)
3475
3476       else
3477          Write_Char (' ');
3478       end if;
3479
3480       --  Write the reason
3481
3482       Write_Char ('"');
3483
3484       for J in 4 .. Image'Last loop
3485          if Image (J) = '_' then
3486             Write_Char (' ');
3487          else
3488             Write_Char (Fold_Lower (Image (J)));
3489          end if;
3490       end loop;
3491
3492       Write_Str ("""]");
3493    end Write_Condition_And_Reason;
3494
3495    --------------------------------
3496    -- Write_Corresponding_Source --
3497    --------------------------------
3498
3499    procedure Write_Corresponding_Source (S : String) is
3500       Loc : Source_Ptr;
3501       Src : Source_Buffer_Ptr;
3502
3503    begin
3504       --  Ignore if not in dump source text mode, or if in freeze actions
3505
3506       if Dump_Source_Text and then Freeze_Indent = 0 then
3507
3508          --  Ignore null string
3509
3510          if S = "" then
3511             return;
3512          end if;
3513
3514          --  Ignore space or semicolon at end of given string
3515
3516          if S (S'Last) = ' ' or else S (S'Last) = ';' then
3517             Write_Corresponding_Source (S (S'First .. S'Last - 1));
3518             return;
3519          end if;
3520
3521          --  Loop to look at next lines not yet printed in source file
3522
3523          for L in
3524            Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File)
3525          loop
3526             Src := Source_Text (Current_Source_File);
3527             Loc := Line_Start (L, Current_Source_File);
3528
3529             --  If comment, keep looking
3530
3531             if Src (Loc .. Loc + 1) = "--" then
3532                null;
3533
3534             --  Search to first non-blank
3535
3536             else
3537                while Src (Loc) not in Line_Terminator loop
3538
3539                   --  Non-blank found
3540
3541                   if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then
3542
3543                      --  Loop through characters in string to see if we match
3544
3545                      for J in S'Range loop
3546
3547                         --  If mismatch, then not the case we are looking for
3548
3549                         if Src (Loc) /= S (J) then
3550                            return;
3551                         end if;
3552
3553                         Loc := Loc + 1;
3554                      end loop;
3555
3556                      --  If we fall through, string matched, if white space or
3557                      --  semicolon after the matched string, this is the case
3558                      --  we are looking for.
3559
3560                      if Src (Loc) in Line_Terminator
3561                        or else Src (Loc) = ' '
3562                        or else Src (Loc) = ASCII.HT
3563                        or else Src (Loc) = ';'
3564                      then
3565                         --  So output source lines up to and including this one
3566
3567                         Write_Source_Lines (L);
3568                         return;
3569                      end if;
3570                   end if;
3571
3572                   Loc := Loc + 1;
3573                end loop;
3574             end if;
3575
3576          --  Line was all blanks, or a comment line, keep looking
3577
3578          end loop;
3579       end if;
3580    end Write_Corresponding_Source;
3581
3582    -----------------------
3583    -- Write_Discr_Specs --
3584    -----------------------
3585
3586    procedure Write_Discr_Specs (N : Node_Id) is
3587       Specs : List_Id;
3588       Spec  : Node_Id;
3589
3590    begin
3591       Specs := Discriminant_Specifications (N);
3592
3593       if Present (Specs) then
3594          Write_Str_With_Col_Check (" (");
3595          Spec := First (Specs);
3596
3597          loop
3598             Sprint_Node (Spec);
3599             Next (Spec);
3600             exit when Spec = Empty;
3601
3602             --  Add semicolon, unless we are printing original tree and the
3603             --  next specification is part of a list (but not the first
3604             --  element of that list)
3605
3606             if not Dump_Original_Only or else not Prev_Ids (Spec) then
3607                Write_Str ("; ");
3608             end if;
3609          end loop;
3610
3611          Write_Char (')');
3612       end if;
3613    end Write_Discr_Specs;
3614
3615    -----------------
3616    -- Write_Ekind --
3617    -----------------
3618
3619    procedure Write_Ekind (E : Entity_Id) is
3620       S : constant String := Entity_Kind'Image (Ekind (E));
3621
3622    begin
3623       Name_Len := S'Length;
3624       Name_Buffer (1 .. Name_Len) := S;
3625       Set_Casing (Mixed_Case);
3626       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3627    end Write_Ekind;
3628
3629    --------------
3630    -- Write_Id --
3631    --------------
3632
3633    procedure Write_Id (N : Node_Id) is
3634    begin
3635       --  Deal with outputting Itype
3636
3637       --  Note: if we are printing the full tree with -gnatds, then we may
3638       --  end up picking up the Associated_Node link from a generic template
3639       --  here which overlaps the Entity field, but as documented, Write_Itype
3640       --  is defended against junk calls.
3641
3642       if Nkind (N) in N_Entity then
3643          Write_Itype (N);
3644       elsif Nkind (N) in N_Has_Entity then
3645          Write_Itype (Entity (N));
3646       end if;
3647
3648       --  Case of a defining identifier
3649
3650       if Nkind (N) = N_Defining_Identifier then
3651
3652          --  If defining identifier has an interface name (and no
3653          --  address clause), then we output the interface name.
3654
3655          if (Is_Imported (N) or else Is_Exported (N))
3656            and then Present (Interface_Name (N))
3657            and then No (Address_Clause (N))
3658          then
3659             String_To_Name_Buffer (Strval (Interface_Name (N)));
3660             Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3661
3662          --  If no interface name (or inactive because there was
3663          --  an address clause), then just output the Chars name.
3664
3665          else
3666             Write_Name_With_Col_Check (Chars (N));
3667          end if;
3668
3669       --  Case of selector of an expanded name where the expanded name
3670       --  has an associated entity, output this entity. Check that the
3671       --  entity or associated node is of the right kind, see above.
3672
3673       elsif Nkind (Parent (N)) = N_Expanded_Name
3674         and then Selector_Name (Parent (N)) = N
3675         and then Present (Entity_Or_Associated_Node (Parent (N)))
3676         and then Nkind (Entity (Parent (N))) in N_Entity
3677       then
3678          Write_Id (Entity (Parent (N)));
3679
3680       --  For any other node with an associated entity, output it
3681
3682       elsif Nkind (N) in N_Has_Entity
3683         and then Present (Entity_Or_Associated_Node (N))
3684         and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
3685       then
3686          Write_Id (Entity (N));
3687
3688       --  All other cases, we just print the Chars field
3689
3690       else
3691          Write_Name_With_Col_Check (Chars (N));
3692       end if;
3693    end Write_Id;
3694
3695    -----------------------
3696    -- Write_Identifiers --
3697    -----------------------
3698
3699    function Write_Identifiers (Node : Node_Id) return Boolean is
3700    begin
3701       Sprint_Node (Defining_Identifier (Node));
3702       Update_Itype (Defining_Identifier (Node));
3703
3704       --  The remainder of the declaration must be printed unless we are
3705       --  printing the original tree and this is not the last identifier
3706
3707       return
3708          not Dump_Original_Only or else not More_Ids (Node);
3709
3710    end Write_Identifiers;
3711
3712    ------------------------
3713    -- Write_Implicit_Def --
3714    ------------------------
3715
3716    procedure Write_Implicit_Def (E : Entity_Id) is
3717       Ind : Node_Id;
3718
3719    begin
3720       case Ekind (E) is
3721          when E_Array_Subtype =>
3722             Write_Str_With_Col_Check ("subtype ");
3723             Write_Id (E);
3724             Write_Str_With_Col_Check (" is ");
3725             Write_Id (Base_Type (E));
3726             Write_Str_With_Col_Check (" (");
3727
3728             Ind := First_Index (E);
3729             while Present (Ind) loop
3730                Sprint_Node (Ind);
3731                Next_Index (Ind);
3732
3733                if Present (Ind) then
3734                   Write_Str (", ");
3735                end if;
3736             end loop;
3737
3738             Write_Str (");");
3739
3740          when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
3741             Write_Str_With_Col_Check ("subtype ");
3742             Write_Id (E);
3743             Write_Str (" is ");
3744             Write_Id (Etype (E));
3745             Write_Str_With_Col_Check (" range ");
3746             Sprint_Node (Scalar_Range (E));
3747             Write_Str (";");
3748
3749          when others =>
3750             Write_Str_With_Col_Check ("type ");
3751             Write_Id (E);
3752             Write_Str_With_Col_Check (" is <");
3753             Write_Ekind (E);
3754             Write_Str (">;");
3755       end case;
3756
3757    end Write_Implicit_Def;
3758
3759    ------------------
3760    -- Write_Indent --
3761    ------------------
3762
3763    procedure Write_Indent is
3764       Loc : constant Source_Ptr := Sloc (Dump_Node);
3765
3766    begin
3767       if Indent_Annull_Flag then
3768          Indent_Annull_Flag := False;
3769       else
3770          --  Deal with Dump_Source_Text output. Note that we ignore implicit
3771          --  label declarations, since they typically have the sloc of the
3772          --  corresponding label, which really messes up the -gnatL output.
3773
3774          if Dump_Source_Text
3775            and then Loc > No_Location
3776            and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration
3777          then
3778             if Get_Source_File_Index (Loc) = Current_Source_File then
3779                Write_Source_Lines
3780                  (Get_Physical_Line_Number (Sloc (Dump_Node)));
3781             end if;
3782          end if;
3783
3784          Write_Eol;
3785
3786          for J in 1 .. Indent loop
3787             Write_Char (' ');
3788          end loop;
3789       end if;
3790    end Write_Indent;
3791
3792    ------------------------------
3793    -- Write_Indent_Identifiers --
3794    ------------------------------
3795
3796    function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
3797    begin
3798       --  We need to start a new line for every node, except in the case
3799       --  where we are printing the original tree and this is not the first
3800       --  defining identifier in the list.
3801
3802       if not Dump_Original_Only or else not Prev_Ids (Node) then
3803          Write_Indent;
3804
3805       --  If printing original tree and this is not the first defining
3806       --  identifier in the list, then the previous call to this procedure
3807       --  printed only the name, and we add a comma to separate the names.
3808
3809       else
3810          Write_Str (", ");
3811       end if;
3812
3813       Sprint_Node (Defining_Identifier (Node));
3814
3815       --  The remainder of the declaration must be printed unless we are
3816       --  printing the original tree and this is not the last identifier
3817
3818       return
3819          not Dump_Original_Only or else not More_Ids (Node);
3820    end Write_Indent_Identifiers;
3821
3822    -----------------------------------
3823    -- Write_Indent_Identifiers_Sloc --
3824    -----------------------------------
3825
3826    function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
3827    begin
3828       --  We need to start a new line for every node, except in the case
3829       --  where we are printing the original tree and this is not the first
3830       --  defining identifier in the list.
3831
3832       if not Dump_Original_Only or else not Prev_Ids (Node) then
3833          Write_Indent;
3834
3835       --  If printing original tree and this is not the first defining
3836       --  identifier in the list, then the previous call to this procedure
3837       --  printed only the name, and we add a comma to separate the names.
3838
3839       else
3840          Write_Str (", ");
3841       end if;
3842
3843       Set_Debug_Sloc;
3844       Sprint_Node (Defining_Identifier (Node));
3845
3846       --  The remainder of the declaration must be printed unless we are
3847       --  printing the original tree and this is not the last identifier
3848
3849       return not Dump_Original_Only or else not More_Ids (Node);
3850    end Write_Indent_Identifiers_Sloc;
3851
3852    ----------------------
3853    -- Write_Indent_Str --
3854    ----------------------
3855
3856    procedure Write_Indent_Str (S : String) is
3857    begin
3858       Write_Corresponding_Source (S);
3859       Write_Indent;
3860       Write_Str (S);
3861    end Write_Indent_Str;
3862
3863    ---------------------------
3864    -- Write_Indent_Str_Sloc --
3865    ---------------------------
3866
3867    procedure Write_Indent_Str_Sloc (S : String) is
3868    begin
3869       Write_Corresponding_Source (S);
3870       Write_Indent;
3871       Write_Str_Sloc (S);
3872    end Write_Indent_Str_Sloc;
3873
3874    -----------------
3875    -- Write_Itype --
3876    -----------------
3877
3878    procedure Write_Itype (Typ : Entity_Id) is
3879
3880       procedure Write_Header (T : Boolean := True);
3881       --  Write type if T is True, subtype if T is false
3882
3883       ------------------
3884       -- Write_Header --
3885       ------------------
3886
3887       procedure Write_Header (T : Boolean := True) is
3888       begin
3889          if T then
3890             Write_Str ("[type ");
3891          else
3892             Write_Str ("[subtype ");
3893          end if;
3894
3895          Write_Name_With_Col_Check (Chars (Typ));
3896          Write_Str (" is ");
3897       end Write_Header;
3898
3899    --  Start of processing for Write_Itype
3900
3901    begin
3902       if Nkind (Typ) in N_Entity
3903         and then Is_Itype (Typ)
3904         and then not Itype_Printed (Typ)
3905       then
3906          --  Itype to be printed
3907
3908          declare
3909             B : constant Node_Id := Etype (Typ);
3910             X : Node_Id;
3911             P : constant Node_Id := Parent (Typ);
3912
3913             S : constant Saved_Output_Buffer := Save_Output_Buffer;
3914             --  Save current output buffer
3915
3916             Old_Sloc : Source_Ptr;
3917             --  Save sloc of related node, so it is not modified when
3918             --  printing with -gnatD.
3919
3920          begin
3921             --  Write indentation at start of line
3922
3923             for J in 1 .. Indent loop
3924                Write_Char (' ');
3925             end loop;
3926
3927             --  If we have a constructed declaration for the itype, print it
3928
3929             if Present (P)
3930               and then Nkind (P) in N_Declaration
3931               and then Defining_Entity (P) = Typ
3932             then
3933                --  We must set Itype_Printed true before the recursive call to
3934                --  print the node, otherwise we get an infinite recursion!
3935
3936                Set_Itype_Printed (Typ, True);
3937
3938                --  Write the declaration enclosed in [], avoiding new line
3939                --  at start of declaration, and semicolon at end.
3940
3941                --  Note: The itype may be imported from another unit, in which
3942                --  case we do not want to modify the Sloc of the declaration.
3943                --  Otherwise the itype may appear to be in the current unit,
3944                --  and the back-end will reject a reference out of scope.
3945
3946                Write_Char ('[');
3947                Indent_Annull_Flag := True;
3948                Old_Sloc := Sloc (P);
3949                Sprint_Node (P);
3950                Set_Sloc (P, Old_Sloc);
3951                Write_Erase_Char (';');
3952
3953             --  If no constructed declaration, then we have to concoct the
3954             --  source corresponding to the type entity that we have at hand.
3955
3956             else
3957                case Ekind (Typ) is
3958
3959                   --  Access types and subtypes
3960
3961                   when Access_Kind =>
3962                      Write_Header (Ekind (Typ) = E_Access_Type);
3963
3964                      if Can_Never_Be_Null (Typ) then
3965                         Write_Str ("not null ");
3966                      end if;
3967
3968                      Write_Str ("access ");
3969
3970                      if Is_Access_Constant (Typ) then
3971                         Write_Str ("constant ");
3972                      end if;
3973
3974                      Write_Id (Directly_Designated_Type (Typ));
3975
3976                   --  Array types and string types
3977
3978                   when E_Array_Type | E_String_Type =>
3979                      Write_Header;
3980                      Write_Str ("array (");
3981
3982                      X := First_Index (Typ);
3983                      loop
3984                         Sprint_Node (X);
3985
3986                         if not Is_Constrained (Typ) then
3987                            Write_Str (" range <>");
3988                         end if;
3989
3990                         Next_Index (X);
3991                         exit when No (X);
3992                         Write_Str (", ");
3993                      end loop;
3994
3995                      Write_Str (") of ");
3996                      X := Component_Type (Typ);
3997
3998                      --  Preserve sloc of component type, which is defined
3999                      --  elsewhere than the itype (see comment above).
4000
4001                      Old_Sloc := Sloc (X);
4002                      Sprint_Node (X);
4003                      Set_Sloc (X, Old_Sloc);
4004
4005                      --  Array subtypes and string subtypes.
4006                      --  Preserve Sloc of index subtypes, as above.
4007
4008                   when E_Array_Subtype | E_String_Subtype =>
4009                      Write_Header (False);
4010                      Write_Id (Etype (Typ));
4011                      Write_Str (" (");
4012
4013                      X := First_Index (Typ);
4014                      loop
4015                         Old_Sloc := Sloc (X);
4016                         Sprint_Node (X);
4017                         Set_Sloc (X, Old_Sloc);
4018                         Next_Index (X);
4019                         exit when No (X);
4020                         Write_Str (", ");
4021                      end loop;
4022
4023                      Write_Char (')');
4024
4025                   --  Signed integer types, and modular integer subtypes,
4026                   --  and also enumeration subtypes.
4027
4028                   when E_Signed_Integer_Type     |
4029                        E_Signed_Integer_Subtype  |
4030                        E_Modular_Integer_Subtype |
4031                        E_Enumeration_Subtype     =>
4032
4033                      Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
4034
4035                      if Ekind (Typ) = E_Signed_Integer_Type then
4036                         Write_Str ("new ");
4037                      end if;
4038
4039                      Write_Id (B);
4040
4041                      --  Print bounds if different from base type
4042
4043                      declare
4044                         L  : constant Node_Id := Type_Low_Bound (Typ);
4045                         H  : constant Node_Id := Type_High_Bound (Typ);
4046                         LE : Node_Id;
4047                         HE : Node_Id;
4048
4049                      begin
4050                         --  B can either be a scalar type, in which case the
4051                         --  declaration of Typ may constrain it with different
4052                         --  bounds, or a private type, in which case we know
4053                         --  that the declaration of Typ cannot have a scalar
4054                         --  constraint.
4055
4056                         if Is_Scalar_Type (B) then
4057                            LE := Type_Low_Bound (B);
4058                            HE := Type_High_Bound (B);
4059                         else
4060                            LE := Empty;
4061                            HE := Empty;
4062                         end if;
4063
4064                         if No (LE)
4065                           or else (True
4066                             and then Nkind (L) = N_Integer_Literal
4067                             and then Nkind (H) = N_Integer_Literal
4068                             and then Nkind (LE) = N_Integer_Literal
4069                             and then Nkind (HE) = N_Integer_Literal
4070                             and then UI_Eq (Intval (L), Intval (LE))
4071                             and then UI_Eq (Intval (H), Intval (HE)))
4072                         then
4073                            null;
4074
4075                         else
4076                            Write_Str (" range ");
4077                            Sprint_Node (Type_Low_Bound (Typ));
4078                            Write_Str (" .. ");
4079                            Sprint_Node (Type_High_Bound (Typ));
4080                         end if;
4081                      end;
4082
4083                   --  Modular integer types
4084
4085                   when E_Modular_Integer_Type =>
4086                      Write_Header;
4087                      Write_Str (" mod ");
4088                      Write_Uint_With_Col_Check (Modulus (Typ), Auto);
4089
4090                   --  Floating point types and subtypes
4091
4092                   when E_Floating_Point_Type    |
4093                        E_Floating_Point_Subtype =>
4094
4095                      Write_Header (Ekind (Typ) = E_Floating_Point_Type);
4096
4097                      if Ekind (Typ) = E_Floating_Point_Type then
4098                         Write_Str ("new ");
4099                      end if;
4100
4101                      Write_Id (Etype (Typ));
4102
4103                      if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
4104                         Write_Str (" digits ");
4105                         Write_Uint_With_Col_Check
4106                           (Digits_Value (Typ), Decimal);
4107                      end if;
4108
4109                      --  Print bounds if not different from base type
4110
4111                      declare
4112                         L  : constant Node_Id := Type_Low_Bound (Typ);
4113                         H  : constant Node_Id := Type_High_Bound (Typ);
4114                         LE : constant Node_Id := Type_Low_Bound (B);
4115                         HE : constant Node_Id := Type_High_Bound (B);
4116
4117                      begin
4118                         if Nkind (L) = N_Real_Literal
4119                           and then Nkind (H) = N_Real_Literal
4120                           and then Nkind (LE) = N_Real_Literal
4121                           and then Nkind (HE) = N_Real_Literal
4122                           and then UR_Eq (Realval (L), Realval (LE))
4123                           and then UR_Eq (Realval (H), Realval (HE))
4124                         then
4125                            null;
4126
4127                         else
4128                            Write_Str (" range ");
4129                            Sprint_Node (Type_Low_Bound (Typ));
4130                            Write_Str (" .. ");
4131                            Sprint_Node (Type_High_Bound (Typ));
4132                         end if;
4133                      end;
4134
4135                   --  Record subtypes
4136
4137                   when E_Record_Subtype =>
4138                      Write_Header (False);
4139                      Write_Str ("record");
4140                      Indent_Begin;
4141
4142                      declare
4143                         C : Entity_Id;
4144                      begin
4145                         C := First_Entity (Typ);
4146                         while Present (C) loop
4147                            Write_Indent;
4148                            Write_Id (C);
4149                            Write_Str (" : ");
4150                            Write_Id (Etype (C));
4151                            Next_Entity (C);
4152                         end loop;
4153                      end;
4154
4155                      Indent_End;
4156                      Write_Indent_Str (" end record");
4157
4158                   --  Class-Wide types
4159
4160                   when E_Class_Wide_Type    |
4161                        E_Class_Wide_Subtype =>
4162                      Write_Header;
4163                      Write_Name_With_Col_Check (Chars (Etype (Typ)));
4164                      Write_Str ("'Class");
4165
4166                   --  Subprogram types
4167
4168                   when E_Subprogram_Type =>
4169                      Write_Header;
4170
4171                      if Etype (Typ) = Standard_Void_Type then
4172                         Write_Str ("procedure");
4173                      else
4174                         Write_Str ("function");
4175                      end if;
4176
4177                      if Present (First_Entity (Typ)) then
4178                         Write_Str (" (");
4179
4180                         declare
4181                            Param : Entity_Id;
4182
4183                         begin
4184                            Param := First_Entity (Typ);
4185                            loop
4186                               Write_Id (Param);
4187                               Write_Str (" : ");
4188
4189                               if Ekind (Param) = E_In_Out_Parameter then
4190                                  Write_Str ("in out ");
4191                               elsif Ekind (Param) = E_Out_Parameter then
4192                                  Write_Str ("out ");
4193                               end if;
4194
4195                               Write_Id (Etype (Param));
4196                               Next_Entity (Param);
4197                               exit when No (Param);
4198                               Write_Str (", ");
4199                            end loop;
4200
4201                            Write_Char (')');
4202                         end;
4203                      end if;
4204
4205                      if Etype (Typ) /= Standard_Void_Type then
4206                         Write_Str (" return ");
4207                         Write_Id (Etype (Typ));
4208                      end if;
4209
4210                   when E_String_Literal_Subtype =>
4211                      declare
4212                         LB  : constant Uint :=
4213                                 Expr_Value (String_Literal_Low_Bound (Typ));
4214                         Len : constant Uint :=
4215                                 String_Literal_Length (Typ);
4216                      begin
4217                         Write_Str ("String (");
4218                         Write_Int (UI_To_Int (LB));
4219                         Write_Str (" .. ");
4220                         Write_Int (UI_To_Int (LB + Len) - 1);
4221                         Write_Str (");");
4222                      end;
4223
4224                   --  For all other Itypes, print ??? (fill in later)
4225
4226                   when others =>
4227                      Write_Header (True);
4228                      Write_Str ("???");
4229
4230                end case;
4231             end if;
4232
4233             --  Add terminating bracket and restore output buffer
4234
4235             Write_Char (']');
4236             Write_Eol;
4237             Restore_Output_Buffer (S);
4238          end;
4239
4240          Set_Itype_Printed (Typ);
4241       end if;
4242    end Write_Itype;
4243
4244    -------------------------------
4245    -- Write_Name_With_Col_Check --
4246    -------------------------------
4247
4248    procedure Write_Name_With_Col_Check (N : Name_Id) is
4249       J : Natural;
4250       K : Natural;
4251       L : Natural;
4252
4253    begin
4254       Get_Name_String (N);
4255
4256       --  Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4257       --  upper case letter, nnn is one or more digits and b is a lower case
4258       --  letter by C...b, so that listings do not depend on serial numbers.
4259
4260       if Debug_Flag_II then
4261          J := 1;
4262          while J < Name_Len - 1 loop
4263             if Name_Buffer (J) in 'A' .. 'Z'
4264               and then Name_Buffer (J + 1) in '0' .. '9'
4265             then
4266                K := J + 1;
4267                while K < Name_Len loop
4268                   exit when Name_Buffer (K) not in '0' .. '9';
4269                   K := K + 1;
4270                end loop;
4271
4272                if Name_Buffer (K) in 'a' .. 'z' then
4273                   L := Name_Len - K + 1;
4274
4275                   Name_Buffer (J + 4 .. J + L + 3) :=
4276                     Name_Buffer (K .. Name_Len);
4277                   Name_Buffer (J + 1 .. J + 3) := "...";
4278                   Name_Len := J + L + 3;
4279                   J := J + 5;
4280
4281                else
4282                   J := K;
4283                end if;
4284
4285             else
4286                J := J + 1;
4287             end if;
4288          end loop;
4289       end if;
4290
4291       --  Fall through for normal case
4292
4293       Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
4294    end Write_Name_With_Col_Check;
4295
4296    ------------------------------------
4297    -- Write_Name_With_Col_Check_Sloc --
4298    ------------------------------------
4299
4300    procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
4301    begin
4302       Get_Name_String (N);
4303       Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
4304    end Write_Name_With_Col_Check_Sloc;
4305
4306    --------------------
4307    -- Write_Operator --
4308    --------------------
4309
4310    procedure Write_Operator (N : Node_Id; S : String) is
4311       F : Natural := S'First;
4312       T : Natural := S'Last;
4313
4314    begin
4315       --  If no overflow check, just write string out, and we are done
4316
4317       if not Do_Overflow_Check (N) then
4318          Write_Str_Sloc (S);
4319
4320       --  If overflow check, we want to surround the operator with curly
4321       --  brackets, but not include spaces within the brackets.
4322
4323       else
4324          if S (F) = ' ' then
4325             Write_Char (' ');
4326             F := F + 1;
4327          end if;
4328
4329          if S (T) = ' ' then
4330             T := T - 1;
4331          end if;
4332
4333          Write_Char ('{');
4334          Write_Str_Sloc (S (F .. T));
4335          Write_Char ('}');
4336
4337          if S (S'Last) = ' ' then
4338             Write_Char (' ');
4339          end if;
4340       end if;
4341    end Write_Operator;
4342
4343    -----------------------
4344    -- Write_Param_Specs --
4345    -----------------------
4346
4347    procedure Write_Param_Specs (N : Node_Id) is
4348       Specs  : List_Id;
4349       Spec   : Node_Id;
4350       Formal : Node_Id;
4351
4352    begin
4353       Specs := Parameter_Specifications (N);
4354
4355       if Is_Non_Empty_List (Specs) then
4356          Write_Str_With_Col_Check (" (");
4357          Spec := First (Specs);
4358
4359          loop
4360             Sprint_Node (Spec);
4361             Formal := Defining_Identifier (Spec);
4362             Next (Spec);
4363             exit when Spec = Empty;
4364
4365             --  Add semicolon, unless we are printing original tree and the
4366             --  next specification is part of a list (but not the first element
4367             --  of that list).
4368
4369             if not Dump_Original_Only or else not Prev_Ids (Spec) then
4370                Write_Str ("; ");
4371             end if;
4372          end loop;
4373
4374          --  Write out any extra formals
4375
4376          while Present (Extra_Formal (Formal)) loop
4377             Formal := Extra_Formal (Formal);
4378             Write_Str ("; ");
4379             Write_Name_With_Col_Check (Chars (Formal));
4380             Write_Str (" : ");
4381             Write_Name_With_Col_Check (Chars (Etype (Formal)));
4382          end loop;
4383
4384          Write_Char (')');
4385       end if;
4386    end Write_Param_Specs;
4387
4388    -----------------------
4389    -- Write_Rewrite_Str --
4390    -----------------------
4391
4392    procedure Write_Rewrite_Str (S : String) is
4393    begin
4394       if not Dump_Generated_Only then
4395          if S'Length = 3 and then S = ">>>" then
4396             Write_Str (">>>");
4397          else
4398             Write_Str_With_Col_Check (S);
4399          end if;
4400       end if;
4401    end Write_Rewrite_Str;
4402
4403    -----------------------
4404    -- Write_Source_Line --
4405    -----------------------
4406
4407    procedure Write_Source_Line (L : Physical_Line_Number) is
4408       Loc : Source_Ptr;
4409       Src : Source_Buffer_Ptr;
4410       Scn : Source_Ptr;
4411
4412    begin
4413       if Dump_Source_Text then
4414          Src := Source_Text (Current_Source_File);
4415          Loc := Line_Start (L, Current_Source_File);
4416          Write_Eol;
4417
4418          --  See if line is a comment line, if not, and if not line one,
4419          --  precede with blank line.
4420
4421          Scn := Loc;
4422          while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
4423             Scn := Scn + 1;
4424          end loop;
4425
4426          if (Src (Scn) in Line_Terminator
4427               or else Src (Scn .. Scn + 1) /= "--")
4428            and then L /= 1
4429          then
4430             Write_Eol;
4431          end if;
4432
4433          --  Now write the source text of the line
4434
4435          Write_Str ("-- ");
4436          Write_Int (Int (L));
4437          Write_Str (": ");
4438
4439          while Src (Loc) not in Line_Terminator loop
4440             Write_Char (Src (Loc));
4441             Loc := Loc + 1;
4442          end loop;
4443       end if;
4444    end Write_Source_Line;
4445
4446    ------------------------
4447    -- Write_Source_Lines --
4448    ------------------------
4449
4450    procedure Write_Source_Lines (L : Physical_Line_Number) is
4451    begin
4452       while Last_Line_Printed < L loop
4453          Last_Line_Printed := Last_Line_Printed + 1;
4454          Write_Source_Line (Last_Line_Printed);
4455       end loop;
4456    end Write_Source_Lines;
4457
4458    --------------------
4459    -- Write_Str_Sloc --
4460    --------------------
4461
4462    procedure Write_Str_Sloc (S : String) is
4463    begin
4464       for J in S'Range loop
4465          Write_Char_Sloc (S (J));
4466       end loop;
4467    end Write_Str_Sloc;
4468
4469    ------------------------------
4470    -- Write_Str_With_Col_Check --
4471    ------------------------------
4472
4473    procedure Write_Str_With_Col_Check (S : String) is
4474    begin
4475       if Int (S'Last) + Column > Sprint_Line_Limit then
4476          Write_Indent_Str ("  ");
4477
4478          if S (S'First) = ' ' then
4479             Write_Str (S (S'First + 1 .. S'Last));
4480          else
4481             Write_Str (S);
4482          end if;
4483
4484       else
4485          Write_Str (S);
4486       end if;
4487    end Write_Str_With_Col_Check;
4488
4489    -----------------------------------
4490    -- Write_Str_With_Col_Check_Sloc --
4491    -----------------------------------
4492
4493    procedure Write_Str_With_Col_Check_Sloc (S : String) is
4494    begin
4495       if Int (S'Last) + Column > Sprint_Line_Limit then
4496          Write_Indent_Str ("  ");
4497
4498          if S (S'First) = ' ' then
4499             Write_Str_Sloc (S (S'First + 1 .. S'Last));
4500          else
4501             Write_Str_Sloc (S);
4502          end if;
4503
4504       else
4505          Write_Str_Sloc (S);
4506       end if;
4507    end Write_Str_With_Col_Check_Sloc;
4508
4509    ---------------------------
4510    -- Write_Subprogram_Name --
4511    ---------------------------
4512
4513    procedure Write_Subprogram_Name (N : Node_Id) is
4514    begin
4515       if not Comes_From_Source (N)
4516         and then Is_Entity_Name (N)
4517       then
4518          declare
4519             Ent : constant Entity_Id := Entity (N);
4520          begin
4521             if not In_Extended_Main_Source_Unit (Ent)
4522               and then
4523                 Is_Predefined_File_Name
4524                   (Unit_File_Name (Get_Source_Unit (Ent)))
4525             then
4526                --  Run-time routine name, output name with a preceding dollar
4527                --  making sure that we do not get a line split between them.
4528
4529                Col_Check (Length_Of_Name (Chars (Ent)) + 1);
4530                Write_Char ('$');
4531                Write_Name (Chars (Ent));
4532                return;
4533             end if;
4534          end;
4535       end if;
4536
4537       --  Normal case, not a run-time routine name
4538
4539       Sprint_Node (N);
4540    end Write_Subprogram_Name;
4541
4542    -------------------------------
4543    -- Write_Uint_With_Col_Check --
4544    -------------------------------
4545
4546    procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is
4547    begin
4548       Col_Check (UI_Decimal_Digits_Hi (U));
4549       UI_Write (U, Format);
4550    end Write_Uint_With_Col_Check;
4551
4552    ------------------------------------
4553    -- Write_Uint_With_Col_Check_Sloc --
4554    ------------------------------------
4555
4556    procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
4557    begin
4558       Col_Check (UI_Decimal_Digits_Hi (U));
4559       Set_Debug_Sloc;
4560       UI_Write (U, Format);
4561    end Write_Uint_With_Col_Check_Sloc;
4562
4563    -------------------------------------
4564    -- Write_Ureal_With_Col_Check_Sloc --
4565    -------------------------------------
4566
4567    procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
4568       D : constant Uint := Denominator (U);
4569       N : constant Uint := Numerator (U);
4570    begin
4571       Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
4572       Set_Debug_Sloc;
4573       UR_Write (U, Brackets => True);
4574    end Write_Ureal_With_Col_Check_Sloc;
4575
4576 end Sprint;