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