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