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