gcc/ada/sprint.adb

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