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