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