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