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