[arm][2/2] Remove support for -march=armv3 and older
[official-gcc.git] / gcc / ada / sprint.adb
blobce5721b1a286169ffbde7a15376deec6d3b6ff76
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-2018, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Csets; use Csets;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Lib; use Lib;
33 with Namet; use Namet;
34 with Nlists; use Nlists;
35 with Opt; use Opt;
36 with Output; use Output;
37 with Rtsfind; use Rtsfind;
38 with Sem_Eval; use Sem_Eval;
39 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo;
41 with Sinput; use Sinput;
42 with Sinput.D; use Sinput.D;
43 with Snames; use Snames;
44 with Stand; use Stand;
45 with Stringt; use Stringt;
46 with Uintp; use Uintp;
47 with Uname; use Uname;
48 with Urealp; use Urealp;
50 package body Sprint is
51 Current_Source_File : Source_File_Index;
52 -- Index of source file whose generated code is being dumped
54 Dump_Node : Node_Id := Empty;
55 -- This is set to the current node, used for printing line numbers. In
56 -- Debug_Generated_Code mode, Dump_Node is set to the current node
57 -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
58 -- value. The call clears it back to Empty.
60 First_Debug_Sloc : Source_Ptr;
61 -- Sloc of first byte of the current output file if we are generating a
62 -- source debug file.
64 Debug_Sloc : Source_Ptr;
65 -- Sloc of first byte of line currently being written if we are
66 -- generating a source debug file.
68 Dump_Original_Only : Boolean;
69 -- Set True if the -gnatdo (dump original tree) flag is set
71 Dump_Generated_Only : Boolean;
72 -- Set True if the -gnatdG (dump generated tree) debug flag is set
73 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
75 Dump_Freeze_Null : Boolean;
76 -- Set True if empty freeze nodes and non-source null statements output.
77 -- Note that freeze nodes containing freeze actions are always output,
78 -- as are freeze nodes for itypes, which in general have the effect of
79 -- causing elaboration of the itype.
81 Freeze_Indent : Int := 0;
82 -- Keep track of freeze indent level (controls output of blank lines before
83 -- procedures within expression freeze actions). Relevant only if we are
84 -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
85 -- output these blank lines in any case.
87 Indent : Int := 0;
88 -- Number of columns for current line output indentation
90 Indent_Annull_Flag : Boolean := False;
91 -- Set True if subsequent Write_Indent call to be ignored, gets reset
92 -- by this call, so it is only active to suppress a single indent call.
94 Last_Line_Printed : Physical_Line_Number;
95 -- This keeps track of the physical line number of the last source line
96 -- that has been output. The value is only valid in Dump_Source_Text mode.
98 -------------------------------
99 -- Operator Precedence Table --
100 -------------------------------
102 -- This table is used to decide whether a subexpression needs to be
103 -- parenthesized. The rule is that if an operand of an operator (which
104 -- for this purpose includes AND THEN and OR ELSE) is itself an operator
105 -- with a lower precedence than the operator (or equal precedence if
106 -- appearing as the right operand), then parentheses are required.
108 Op_Prec : constant array (N_Subexpr) of Short_Short_Integer :=
109 (N_Op_And => 1,
110 N_Op_Or => 1,
111 N_Op_Xor => 1,
112 N_And_Then => 1,
113 N_Or_Else => 1,
115 N_In => 2,
116 N_Not_In => 2,
117 N_Op_Eq => 2,
118 N_Op_Ge => 2,
119 N_Op_Gt => 2,
120 N_Op_Le => 2,
121 N_Op_Lt => 2,
122 N_Op_Ne => 2,
124 N_Op_Add => 3,
125 N_Op_Concat => 3,
126 N_Op_Subtract => 3,
127 N_Op_Plus => 3,
128 N_Op_Minus => 3,
130 N_Op_Divide => 4,
131 N_Op_Mod => 4,
132 N_Op_Rem => 4,
133 N_Op_Multiply => 4,
135 N_Op_Expon => 5,
136 N_Op_Abs => 5,
137 N_Op_Not => 5,
139 others => 6);
141 procedure Sprint_Left_Opnd (N : Node_Id);
142 -- Print left operand of operator, parenthesizing if necessary
144 procedure Sprint_Right_Opnd (N : Node_Id);
145 -- Print right operand of operator, parenthesizing if necessary
147 -----------------------
148 -- Local Subprograms --
149 -----------------------
151 procedure Col_Check (N : Nat);
152 -- Check that at least N characters remain on current line, and if not,
153 -- then start an extra line with two characters extra indentation for
154 -- continuing text on the next line.
156 procedure Extra_Blank_Line;
157 -- In some situations we write extra blank lines to separate the generated
158 -- code to make it more readable. However, these extra blank lines are not
159 -- generated in Dump_Source_Text mode, since there the source text lines
160 -- output with preceding blank lines are quite sufficient as separators.
161 -- This procedure writes a blank line if Dump_Source_Text is False.
163 procedure Indent_Annull;
164 -- Causes following call to Write_Indent to be ignored. This is used when
165 -- a higher level node wants to stop a lower level node from starting a
166 -- new line, when it would otherwise be inclined to do so (e.g. the case
167 -- of an accept statement called from an accept alternative with a guard)
169 procedure Indent_Begin;
170 -- Increase indentation level
172 procedure Indent_End;
173 -- Decrease indentation level
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).
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 @).
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.
189 procedure Sprint_And_List (List : List_Id);
190 -- Print the given list with items separated by vertical "and"
192 procedure Sprint_Aspect_Specifications
193 (Node : Node_Id;
194 Semicolon : Boolean);
195 -- Node is a declaration node that has aspect specifications (Has_Aspects
196 -- flag set True). It outputs the aspect specifications. For the case
197 -- of Semicolon = True, it is called after outputting the terminating
198 -- semicolon for the related node. The effect is to remove the semicolon
199 -- and print the aspect specifications followed by a terminating semicolon.
200 -- For the case of Semicolon False, no semicolon is removed or output, and
201 -- all the aspects are printed on a single line.
203 procedure Sprint_Bar_List (List : List_Id);
204 -- Print the given list with items separated by vertical bars
206 procedure Sprint_End_Label
207 (Node : Node_Id;
208 Default : Node_Id);
209 -- Print the end label for a Handled_Sequence_Of_Statements in a body.
210 -- If there is no end label, use the defining identifier of the enclosing
211 -- construct. If the end label is present, treat it as a reference to the
212 -- defining entity of the construct: this guarantees that it carries the
213 -- proper sloc information for debugging purposes.
215 procedure Sprint_Node_Actual (Node : Node_Id);
216 -- This routine prints its node argument. It is a lower level routine than
217 -- Sprint_Node, in that it does not bother about rewritten trees.
219 procedure Sprint_Node_Sloc (Node : Node_Id);
220 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
221 -- sets the Sloc of the current debug node to be a copy of the Sloc
222 -- of the sprinted node Node. Note that this is done after printing
223 -- Node, so that the Sloc is the proper updated value for the debug file.
225 procedure Update_Itype (Node : Node_Id);
226 -- Update the Sloc of an itype that is not attached to the tree, when
227 -- debugging expanded code. This routine is called from nodes whose
228 -- type can be an Itype, such as defining_identifiers that may be of
229 -- an anonymous access type, or ranges in slices.
231 procedure Write_Char_Sloc (C : Character);
232 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
233 -- called to ensure that the current node has a proper Sloc set.
235 procedure Write_Condition_And_Reason (Node : Node_Id);
236 -- Write Condition and Reason codes of Raise_xxx_Error node
238 procedure Write_Corresponding_Source (S : String);
239 -- If S is a string with a single keyword (possibly followed by a space),
240 -- and if the next non-comment non-blank source line matches this keyword,
241 -- then output all source lines up to this matching line.
243 procedure Write_Discr_Specs (N : Node_Id);
244 -- Output discriminant specification for node, which is any of the type
245 -- declarations that can have discriminants.
247 procedure Write_Ekind (E : Entity_Id);
248 -- Write the String corresponding to the Ekind without "E_"
250 procedure Write_Id (N : Node_Id);
251 -- N is a node with a Chars field. This procedure writes the name that
252 -- will be used in the generated code associated with the name. For a
253 -- node with no associated entity, this is simply the Chars field. For
254 -- the case where there is an entity associated with the node, we print
255 -- the name associated with the entity (since it may have been encoded).
256 -- One other special case is that an entity has an active external name
257 -- (i.e. an external name present with no address clause), then this
258 -- external name is output. This procedure also deals with outputting
259 -- declarations of referenced itypes, if not output earlier.
261 function Write_Identifiers (Node : Node_Id) return Boolean;
262 -- Handle node where the grammar has a list of defining identifiers, but
263 -- the tree has a separate declaration for each identifier. Handles the
264 -- printing of the defining identifier, and returns True if the type and
265 -- initialization information is to be printed, False if it is to be
266 -- skipped (the latter case happens when printing defining identifiers
267 -- other than the first in the original tree output case).
269 procedure Write_Implicit_Def (E : Entity_Id);
270 pragma Warnings (Off, Write_Implicit_Def);
271 -- Write the definition of the implicit type E according to its Ekind
272 -- For now a debugging procedure, but might be used in the future.
274 procedure Write_Indent;
275 -- Start a new line and write indentation spacing
277 function Write_Indent_Identifiers (Node : Node_Id) return Boolean;
278 -- Like Write_Identifiers except that each new printed declaration
279 -- is at the start of a new line.
281 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean;
282 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
283 -- mode, the Sloc of the current debug node is set to point to the
284 -- first output identifier.
286 procedure Write_Indent_Str (S : String);
287 -- Start a new line and write indent spacing followed by given string
289 procedure Write_Indent_Str_Sloc (S : String);
290 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
291 -- the Sloc of the current node is set to the first non-blank character
292 -- in the string S.
294 procedure Write_Itype (Typ : Entity_Id);
295 -- If Typ is an Itype that has not been written yet, write it. If Typ is
296 -- any other kind of entity or tree node, the call is ignored.
298 procedure Write_Name_With_Col_Check (N : Name_Id);
299 -- Write name (using Write_Name) with initial column check, and possible
300 -- initial Write_Indent (to get new line) if current line is too full.
302 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id);
303 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
304 -- mode, sets Sloc of current debug node to first character of name.
306 procedure Write_Operator (N : Node_Id; S : String);
307 -- Like Write_Str_Sloc, used for operators, encloses the string in
308 -- characters {} if the Do_Overflow flag is set on the node N.
310 procedure Write_Param_Specs (N : Node_Id);
311 -- Output parameter specifications for node N (which is a subprogram, or
312 -- entry or entry family or access-subprogram-definition, all of which
313 -- have a Parameter_Specificatioons field).
315 procedure Write_Rewrite_Str (S : String);
316 -- Writes out a string (typically containing <<< or >>>}) for a node
317 -- created by rewriting the tree. Suppressed if we are outputting the
318 -- generated code only, since in this case we don't specially mark nodes
319 -- created by rewriting).
321 procedure Write_Source_Line (L : Physical_Line_Number);
322 -- If writing of interspersed source lines is enabled, then write the given
323 -- line from the source file, preceded by Eol, then an extra blank line if
324 -- the line has at least one blank, is not a comment and is not line one,
325 -- then "--" and the line number followed by period followed by text of the
326 -- source line (without terminating Eol). If interspersed source line
327 -- output not enabled, then the call has no effect.
329 procedure Write_Source_Lines (L : Physical_Line_Number);
330 -- If writing of interspersed source lines is enabled, then writes source
331 -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
332 -- interspersed source line output not enabled, then call has no effect.
334 procedure Write_Str_Sloc (S : String);
335 -- Like Write_Str, but sets debug Sloc of current debug node to first
336 -- non-blank character if a current debug node is active.
338 procedure Write_Str_With_Col_Check (S : String);
339 -- Write string (using Write_Str) with initial column check, and possible
340 -- initial Write_Indent (to get new line) if current line is too full.
342 procedure Write_Str_With_Col_Check_Sloc (S : String);
343 -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug
344 -- node to first non-blank character if a current debug node is active.
346 procedure Write_Subprogram_Name (N : Node_Id);
347 -- N is the Name field of a function call or procedure statement call.
348 -- The effect of the call is to output the name, preceded by a $ if the
349 -- call is identified as an implicit call to a run time routine.
351 procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format);
352 -- Write Uint (using UI_Write) with initial column check, and possible
353 -- initial Write_Indent (to get new line) if current line is too full.
354 -- The format parameter determines the output format (see UI_Write).
356 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
357 -- Write Uint (using UI_Write) with initial column check, and possible
358 -- initial Write_Indent (to get new line) if current line is too full.
359 -- The format parameter determines the output format (see UI_Write).
360 -- In addition, in Debug_Generated_Code mode, sets the current node
361 -- Sloc to the first character of the output value.
363 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal);
364 -- Write Ureal (using same output format as UR_Write) with column checks
365 -- and a possible initial Write_Indent (to get new line) if current line
366 -- is too full. In addition, in Debug_Generated_Code mode, sets the
367 -- current node Sloc to the first character of the output value.
369 ---------------
370 -- Col_Check --
371 ---------------
373 procedure Col_Check (N : Nat) is
374 begin
375 if N + Column > Sprint_Line_Limit then
376 Write_Indent_Str (" ");
377 end if;
378 end Col_Check;
380 ----------------------
381 -- Extra_Blank_Line --
382 ----------------------
384 procedure Extra_Blank_Line is
385 begin
386 if not Dump_Source_Text then
387 Write_Indent;
388 end if;
389 end Extra_Blank_Line;
391 -------------------
392 -- Indent_Annull --
393 -------------------
395 procedure Indent_Annull is
396 begin
397 Indent_Annull_Flag := True;
398 end Indent_Annull;
400 ------------------
401 -- Indent_Begin --
402 ------------------
404 procedure Indent_Begin is
405 begin
406 Indent := Indent + 3;
407 end Indent_Begin;
409 ----------------
410 -- Indent_End --
411 ----------------
413 procedure Indent_End is
414 begin
415 Indent := Indent - 3;
416 end Indent_End;
418 --------
419 -- pg --
420 --------
422 procedure pg (Arg : Union_Id) is
423 begin
424 Dump_Generated_Only := True;
425 Dump_Original_Only := False;
426 Dump_Freeze_Null := True;
427 Current_Source_File := No_Source_File;
429 if Arg in List_Range then
430 Sprint_Node_List (List_Id (Arg), New_Lines => True);
432 elsif Arg in Node_Range then
433 Sprint_Node (Node_Id (Arg));
435 else
436 null;
437 end if;
439 Write_Eol;
440 end pg;
442 --------
443 -- po --
444 --------
446 procedure po (Arg : Union_Id) is
447 begin
448 Dump_Generated_Only := False;
449 Dump_Original_Only := True;
450 Current_Source_File := No_Source_File;
452 if Arg in List_Range then
453 Sprint_Node_List (List_Id (Arg), New_Lines => True);
455 elsif Arg in Node_Range then
456 Sprint_Node (Node_Id (Arg));
458 else
459 null;
460 end if;
462 Write_Eol;
463 end po;
465 ----------------------
466 -- Print_Debug_Line --
467 ----------------------
469 procedure Print_Debug_Line (S : String) is
470 begin
471 Write_Debug_Line (S, Debug_Sloc);
472 end Print_Debug_Line;
474 ---------------------------
475 -- Process_TFAI_RR_Flags --
476 ---------------------------
478 procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
479 begin
480 if Treat_Fixed_As_Integer (Nod) then
481 Write_Char ('#');
482 end if;
484 if Rounded_Result (Nod) then
485 Write_Char ('@');
486 end if;
487 end Process_TFAI_RR_Flags;
489 --------
490 -- ps --
491 --------
493 procedure ps (Arg : Union_Id) is
494 begin
495 Dump_Generated_Only := False;
496 Dump_Original_Only := False;
497 Current_Source_File := No_Source_File;
499 if Arg in List_Range then
500 Sprint_Node_List (List_Id (Arg), New_Lines => True);
502 elsif Arg in Node_Range then
503 Sprint_Node (Node_Id (Arg));
505 else
506 null;
507 end if;
509 Write_Eol;
510 end ps;
512 --------------------
513 -- Set_Debug_Sloc --
514 --------------------
516 procedure Set_Debug_Sloc is
517 begin
518 if Debug_Generated_Code and then Present (Dump_Node) then
519 declare
520 Loc : constant Source_Ptr := Sloc (Dump_Node);
522 begin
523 -- Do not change the location of nodes defined in package Standard
524 -- and nodes of pragmas scanned by Targparm.
526 if Loc <= Standard_Location then
527 null;
529 -- Update the location of a node which is part of the current .dg
530 -- output. This situation occurs in comma separated parameter
531 -- declarations since each parameter references the same parameter
532 -- type node (ie. obj1, obj2 : <param-type>).
534 -- Note: This case is needed here since we cannot use the routine
535 -- In_Extended_Main_Code_Unit with nodes whose location is a .dg
536 -- file.
538 elsif Loc >= First_Debug_Sloc then
539 Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
541 -- Do not change the location of nodes which are not part of the
542 -- generated code
544 elsif not In_Extended_Main_Code_Unit (Loc) then
545 null;
547 else
548 Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
549 end if;
550 end;
552 -- We do not know the actual end location in the generated code and
553 -- it could be much closer than in the source code, so play safe.
555 if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then
556 Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
557 end if;
559 Dump_Node := Empty;
560 end if;
561 end Set_Debug_Sloc;
563 -----------------
564 -- Source_Dump --
565 -----------------
567 procedure Source_Dump is
569 procedure Underline;
570 -- Put underline under string we just printed
572 ---------------
573 -- Underline --
574 ---------------
576 procedure Underline is
577 Col : constant Int := Column;
579 begin
580 Write_Eol;
582 while Col > Column loop
583 Write_Char ('-');
584 end loop;
586 Write_Eol;
587 end Underline;
589 -- Start of processing for Source_Dump
591 begin
592 Dump_Generated_Only := Debug_Flag_G or
593 Print_Generated_Code or
594 Debug_Generated_Code;
595 Dump_Original_Only := Debug_Flag_O;
596 Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G;
598 -- Note that we turn off the tree dump flags immediately, before
599 -- starting the dump. This avoids generating two copies of the dump
600 -- if an abort occurs after printing the dump, and more importantly,
601 -- avoids an infinite loop if an abort occurs during the dump.
603 if Debug_Flag_Z then
604 Current_Source_File := No_Source_File;
605 Debug_Flag_Z := False;
606 Write_Eol;
607 Write_Eol;
608 Write_Str ("Source recreated from tree of Standard (spec)");
609 Underline;
610 Sprint_Node (Standard_Package_Node);
611 Write_Eol;
612 Write_Eol;
613 end if;
615 if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
616 Debug_Flag_G := False;
617 Debug_Flag_O := False;
618 Debug_Flag_S := False;
619 First_Debug_Sloc := No_Location;
621 -- Dump requested units
623 for U in Main_Unit .. Last_Unit loop
624 Current_Source_File := Source_Index (U);
626 -- Dump all units if -gnatdf set, otherwise dump only the source
627 -- files that are in the extended main source. Note that, if we
628 -- are generating debug files, generating that of the main unit
629 -- has an effect on the outcome of In_Extended_Main_Source_Unit
630 -- because slocs are rewritten, so we also test for equality of
631 -- Cunit_Entity to work around this effect.
633 if Debug_Flag_F
634 or else In_Extended_Main_Source_Unit (Cunit_Entity (U))
635 or else Cunit_Entity (U) = Cunit_Entity (Main_Unit)
636 then
637 -- If we are generating debug files, setup to write them
639 if Debug_Generated_Code then
640 Set_Special_Output (Print_Debug_Line'Access);
641 Create_Debug_Source (Source_Index (U), Debug_Sloc);
642 First_Debug_Sloc := Debug_Sloc;
643 Write_Source_Line (1);
644 Last_Line_Printed := 1;
646 -- If this unit has the same entity as the main unit, for
647 -- example is the spec of a stand-alone instantiation of
648 -- a package and the main unit is the body, its debug file
649 -- will also be the same. Therefore, we need to print again
650 -- the main unit to have both units in the debug file.
652 if U /= Main_Unit
653 and then Cunit_Entity (U) = Cunit_Entity (Main_Unit)
654 then
655 Sprint_Node (Cunit (Main_Unit));
656 Write_Eol;
657 end if;
659 Sprint_Node (Cunit (U));
660 Write_Source_Lines (Last_Source_Line (Current_Source_File));
661 Write_Eol;
662 Close_Debug_Source;
663 Set_Special_Output (null);
665 -- Normal output to standard output file
667 else
668 Write_Str ("Source recreated from tree for ");
669 Write_Unit_Name (Unit_Name (U));
670 Underline;
671 Write_Source_Line (1);
672 Last_Line_Printed := 1;
673 Sprint_Node (Cunit (U));
674 Write_Source_Lines (Last_Source_Line (Current_Source_File));
675 Write_Eol;
676 Write_Eol;
677 end if;
678 end if;
679 end loop;
680 end if;
681 end Source_Dump;
683 ---------------------
684 -- Sprint_And_List --
685 ---------------------
687 procedure Sprint_And_List (List : List_Id) is
688 Node : Node_Id;
689 begin
690 if Is_Non_Empty_List (List) then
691 Node := First (List);
692 loop
693 Sprint_Node (Node);
694 Next (Node);
695 exit when Node = Empty;
696 Write_Str (" and ");
697 end loop;
698 end if;
699 end Sprint_And_List;
701 ----------------------------------
702 -- Sprint_Aspect_Specifications --
703 ----------------------------------
705 procedure Sprint_Aspect_Specifications
706 (Node : Node_Id;
707 Semicolon : Boolean)
709 AS : constant List_Id := Aspect_Specifications (Node);
710 A : Node_Id;
712 begin
713 if Semicolon then
714 Write_Erase_Char (';');
715 Indent := Indent + 2;
716 Write_Indent;
717 Write_Str ("with ");
718 Indent := Indent + 5;
720 else
721 Write_Str (" with ");
722 end if;
724 A := First (AS);
725 loop
726 Sprint_Node (Identifier (A));
728 if Class_Present (A) then
729 Write_Str ("'Class");
730 end if;
732 if Present (Expression (A)) then
733 Write_Str (" => ");
734 Sprint_Node (Expression (A));
735 end if;
737 Next (A);
739 exit when No (A);
740 Write_Char (',');
742 if Semicolon then
743 Write_Indent;
744 end if;
745 end loop;
747 if Semicolon then
748 Indent := Indent - 7;
749 Write_Char (';');
750 end if;
751 end Sprint_Aspect_Specifications;
753 ---------------------
754 -- Sprint_Bar_List --
755 ---------------------
757 procedure Sprint_Bar_List (List : List_Id) is
758 Node : Node_Id;
759 begin
760 if Is_Non_Empty_List (List) then
761 Node := First (List);
762 loop
763 Sprint_Node (Node);
764 Next (Node);
765 exit when Node = Empty;
766 Write_Str (" | ");
767 end loop;
768 end if;
769 end Sprint_Bar_List;
771 ----------------------
772 -- Sprint_End_Label --
773 ----------------------
775 procedure Sprint_End_Label
776 (Node : Node_Id;
777 Default : Node_Id)
779 begin
780 if Present (Node)
781 and then Present (End_Label (Node))
782 and then Is_Entity_Name (End_Label (Node))
783 then
784 Set_Entity (End_Label (Node), Default);
786 -- For a function whose name is an operator, use the qualified name
787 -- created for the defining entity.
789 if Nkind (End_Label (Node)) = N_Operator_Symbol then
790 Set_Chars (End_Label (Node), Chars (Default));
791 end if;
793 Sprint_Node (End_Label (Node));
794 else
795 Sprint_Node (Default);
796 end if;
797 end Sprint_End_Label;
799 -----------------------
800 -- Sprint_Comma_List --
801 -----------------------
803 procedure Sprint_Comma_List (List : List_Id) is
804 Node : Node_Id;
806 begin
807 if Is_Non_Empty_List (List) then
808 Node := First (List);
809 loop
810 Sprint_Node (Node);
811 Next (Node);
812 exit when Node = Empty;
814 if not Is_Rewrite_Insertion (Node)
815 or else not Dump_Original_Only
816 then
817 Write_Str (", ");
818 end if;
819 end loop;
820 end if;
821 end Sprint_Comma_List;
823 --------------------------
824 -- Sprint_Indented_List --
825 --------------------------
827 procedure Sprint_Indented_List (List : List_Id) is
828 begin
829 Indent_Begin;
830 Sprint_Node_List (List);
831 Indent_End;
832 end Sprint_Indented_List;
834 ---------------------
835 -- Sprint_Left_Opnd --
836 ---------------------
838 procedure Sprint_Left_Opnd (N : Node_Id) is
839 Opnd : constant Node_Id := Left_Opnd (N);
841 begin
842 if Paren_Count (Opnd) /= 0
843 or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N))
844 then
845 Sprint_Node (Opnd);
847 else
848 Write_Char ('(');
849 Sprint_Node (Opnd);
850 Write_Char (')');
851 end if;
852 end Sprint_Left_Opnd;
854 -----------------
855 -- Sprint_Node --
856 -----------------
858 procedure Sprint_Node (Node : Node_Id) is
859 begin
860 if Is_Rewrite_Insertion (Node) then
861 if not Dump_Original_Only then
863 -- For special cases of nodes that always output <<< >>>
864 -- do not duplicate the output at this point.
866 if Nkind (Node) = N_Freeze_Entity
867 or else Nkind (Node) = N_Freeze_Generic_Entity
868 or else Nkind (Node) = N_Implicit_Label_Declaration
869 then
870 Sprint_Node_Actual (Node);
872 -- Normal case where <<< >>> may be required
874 else
875 Write_Rewrite_Str ("<<<");
876 Sprint_Node_Actual (Node);
877 Write_Rewrite_Str (">>>");
878 end if;
879 end if;
881 elsif Is_Rewrite_Substitution (Node) then
883 -- Case of dump generated only
885 if Dump_Generated_Only then
886 Sprint_Node_Actual (Node);
888 -- Case of dump original only
890 elsif Dump_Original_Only then
891 Sprint_Node_Actual (Original_Node (Node));
893 -- Case of both being dumped
895 else
896 Sprint_Node_Actual (Original_Node (Node));
897 Write_Rewrite_Str ("<<<");
898 Sprint_Node_Actual (Node);
899 Write_Rewrite_Str (">>>");
900 end if;
902 else
903 Sprint_Node_Actual (Node);
904 end if;
905 end Sprint_Node;
907 ------------------------
908 -- Sprint_Node_Actual --
909 ------------------------
911 procedure Sprint_Node_Actual (Node : Node_Id) is
912 Save_Dump_Node : constant Node_Id := Dump_Node;
914 begin
915 if Node = Empty then
916 return;
917 end if;
919 for J in 1 .. Paren_Count (Node) loop
920 Write_Str_With_Col_Check ("(");
921 end loop;
923 -- Setup current dump node
925 Dump_Node := Node;
927 if Nkind (Node) in N_Subexpr
928 and then Do_Range_Check (Node)
929 then
930 Write_Str_With_Col_Check ("{");
931 end if;
933 -- Select print circuit based on node kind
935 case Nkind (Node) is
936 when N_Abort_Statement =>
937 Write_Indent_Str_Sloc ("abort ");
938 Sprint_Comma_List (Names (Node));
939 Write_Char (';');
941 when N_Abortable_Part =>
942 Set_Debug_Sloc;
943 Write_Str_Sloc ("abort ");
944 Sprint_Indented_List (Statements (Node));
946 when N_Abstract_Subprogram_Declaration =>
947 Write_Indent;
948 Sprint_Node (Specification (Node));
949 Write_Str_With_Col_Check (" is ");
950 Write_Str_Sloc ("abstract;");
952 when N_Accept_Alternative =>
953 Sprint_Node_List (Pragmas_Before (Node));
955 if Present (Condition (Node)) then
956 Write_Indent_Str ("when ");
957 Sprint_Node (Condition (Node));
958 Write_Str (" => ");
959 Indent_Annull;
960 end if;
962 Sprint_Node_Sloc (Accept_Statement (Node));
963 Sprint_Node_List (Statements (Node));
965 when N_Accept_Statement =>
966 Write_Indent_Str_Sloc ("accept ");
967 Write_Id (Entry_Direct_Name (Node));
969 if Present (Entry_Index (Node)) then
970 Write_Str_With_Col_Check (" (");
971 Sprint_Node (Entry_Index (Node));
972 Write_Char (')');
973 end if;
975 Write_Param_Specs (Node);
977 if Present (Handled_Statement_Sequence (Node)) then
978 Write_Str_With_Col_Check (" do");
979 Sprint_Node (Handled_Statement_Sequence (Node));
980 Write_Indent_Str ("end ");
981 Write_Id (Entry_Direct_Name (Node));
982 end if;
984 Write_Char (';');
986 when N_Access_Definition =>
988 -- Ada 2005 (AI-254)
990 if Present (Access_To_Subprogram_Definition (Node)) then
991 Sprint_Node (Access_To_Subprogram_Definition (Node));
992 else
993 -- Ada 2005 (AI-231)
995 if Null_Exclusion_Present (Node) then
996 Write_Str ("not null ");
997 end if;
999 Write_Str_With_Col_Check_Sloc ("access ");
1001 if All_Present (Node) then
1002 Write_Str ("all ");
1003 elsif Constant_Present (Node) then
1004 Write_Str ("constant ");
1005 end if;
1007 Sprint_Node (Subtype_Mark (Node));
1008 end if;
1010 when N_Access_Function_Definition =>
1012 -- Ada 2005 (AI-231)
1014 if Null_Exclusion_Present (Node) then
1015 Write_Str ("not null ");
1016 end if;
1018 Write_Str_With_Col_Check_Sloc ("access ");
1020 if Protected_Present (Node) then
1021 Write_Str_With_Col_Check ("protected ");
1022 end if;
1024 Write_Str_With_Col_Check ("function");
1025 Write_Param_Specs (Node);
1026 Write_Str_With_Col_Check (" return ");
1027 Sprint_Node (Result_Definition (Node));
1029 when N_Access_Procedure_Definition =>
1031 -- Ada 2005 (AI-231)
1033 if Null_Exclusion_Present (Node) then
1034 Write_Str ("not null ");
1035 end if;
1037 Write_Str_With_Col_Check_Sloc ("access ");
1039 if Protected_Present (Node) then
1040 Write_Str_With_Col_Check ("protected ");
1041 end if;
1043 Write_Str_With_Col_Check ("procedure");
1044 Write_Param_Specs (Node);
1046 when N_Access_To_Object_Definition =>
1047 Write_Str_With_Col_Check_Sloc ("access ");
1049 if All_Present (Node) then
1050 Write_Str_With_Col_Check ("all ");
1051 elsif Constant_Present (Node) then
1052 Write_Str_With_Col_Check ("constant ");
1053 end if;
1055 -- Ada 2005 (AI-231)
1057 if Null_Exclusion_Present (Node) then
1058 Write_Str ("not null ");
1059 end if;
1061 Sprint_Node (Subtype_Indication (Node));
1063 when N_Aggregate =>
1064 if Null_Record_Present (Node) then
1065 Write_Str_With_Col_Check_Sloc ("(null record)");
1067 else
1068 Write_Str_With_Col_Check_Sloc ("(");
1070 if Present (Expressions (Node)) then
1071 Sprint_Comma_List (Expressions (Node));
1073 if Present (Component_Associations (Node))
1074 and then not Is_Empty_List (Component_Associations (Node))
1075 then
1076 Write_Str (", ");
1077 end if;
1078 end if;
1080 if Present (Component_Associations (Node))
1081 and then not Is_Empty_List (Component_Associations (Node))
1082 then
1083 Indent_Begin;
1085 declare
1086 Nd : Node_Id;
1088 begin
1089 Nd := First (Component_Associations (Node));
1091 loop
1092 Write_Indent;
1093 Sprint_Node (Nd);
1094 Next (Nd);
1095 exit when No (Nd);
1097 if not Is_Rewrite_Insertion (Nd)
1098 or else not Dump_Original_Only
1099 then
1100 Write_Str (", ");
1101 end if;
1102 end loop;
1103 end;
1105 Indent_End;
1106 end if;
1108 Write_Char (')');
1109 end if;
1111 when N_Allocator =>
1112 Write_Str_With_Col_Check_Sloc ("new ");
1114 -- Ada 2005 (AI-231)
1116 if Null_Exclusion_Present (Node) then
1117 Write_Str ("not null ");
1118 end if;
1120 Sprint_Node (Expression (Node));
1122 if Present (Storage_Pool (Node)) then
1123 Write_Str_With_Col_Check ("[storage_pool = ");
1124 Sprint_Node (Storage_Pool (Node));
1125 Write_Char (']');
1126 end if;
1128 when N_And_Then =>
1129 Sprint_Left_Opnd (Node);
1130 Write_Str_Sloc (" and then ");
1131 Sprint_Right_Opnd (Node);
1133 -- Note: the following code for N_Aspect_Specification is not
1134 -- normally used, since we deal with aspects as part of a
1135 -- declaration, but it is here in case we deliberately try
1136 -- to print an N_Aspect_Speficiation node (e.g. from GDB).
1138 when N_Aspect_Specification =>
1139 Sprint_Node (Identifier (Node));
1140 Write_Str (" => ");
1141 Sprint_Node (Expression (Node));
1143 when N_Assignment_Statement =>
1144 Write_Indent;
1145 Sprint_Node (Name (Node));
1146 Write_Str_Sloc (" := ");
1147 Sprint_Node (Expression (Node));
1148 Write_Char (';');
1150 when N_Asynchronous_Select =>
1151 Write_Indent_Str_Sloc ("select");
1152 Indent_Begin;
1153 Sprint_Node (Triggering_Alternative (Node));
1154 Indent_End;
1156 -- Note: let the printing of Abortable_Part handle outputting
1157 -- the ABORT keyword, so that the Sloc can be set correctly.
1159 Write_Indent_Str ("then ");
1160 Sprint_Node (Abortable_Part (Node));
1161 Write_Indent_Str ("end select;");
1163 when N_At_Clause =>
1164 Write_Indent_Str_Sloc ("for ");
1165 Write_Id (Identifier (Node));
1166 Write_Str_With_Col_Check (" use at ");
1167 Sprint_Node (Expression (Node));
1168 Write_Char (';');
1170 when N_Attribute_Definition_Clause =>
1171 Write_Indent_Str_Sloc ("for ");
1172 Sprint_Node (Name (Node));
1173 Write_Char (''');
1174 Write_Name_With_Col_Check (Chars (Node));
1175 Write_Str_With_Col_Check (" use ");
1176 Sprint_Node (Expression (Node));
1177 Write_Char (';');
1179 when N_Attribute_Reference =>
1180 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
1181 Write_Indent;
1182 end if;
1184 Sprint_Node (Prefix (Node));
1185 Write_Char_Sloc (''');
1186 Write_Name_With_Col_Check (Attribute_Name (Node));
1187 Sprint_Paren_Comma_List (Expressions (Node));
1189 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
1190 Write_Char (';');
1191 end if;
1193 when N_Block_Statement =>
1194 Write_Indent;
1196 if Present (Identifier (Node))
1197 and then (not Has_Created_Identifier (Node)
1198 or else not Dump_Original_Only)
1199 then
1200 Write_Rewrite_Str ("<<<");
1201 Write_Id (Identifier (Node));
1202 Write_Str (" : ");
1203 Write_Rewrite_Str (">>>");
1204 end if;
1206 if Present (Declarations (Node)) then
1207 Write_Str_With_Col_Check_Sloc ("declare");
1208 Sprint_Indented_List (Declarations (Node));
1209 Write_Indent;
1210 end if;
1212 Write_Str_With_Col_Check_Sloc ("begin");
1213 Sprint_Node (Handled_Statement_Sequence (Node));
1214 Write_Indent_Str ("end");
1216 if Present (Identifier (Node))
1217 and then (not Has_Created_Identifier (Node)
1218 or else not Dump_Original_Only)
1219 then
1220 Write_Rewrite_Str ("<<<");
1221 Write_Char (' ');
1222 Write_Id (Identifier (Node));
1223 Write_Rewrite_Str (">>>");
1224 end if;
1226 Write_Char (';');
1228 when N_Call_Marker =>
1229 null;
1231 -- Enable the following code for debugging purposes only
1233 -- Write_Indent_Str ("#");
1234 -- Write_Id (Target (Node));
1235 -- Write_Char ('#');
1237 when N_Case_Expression =>
1238 declare
1239 Has_Parens : constant Boolean := Paren_Count (Node) > 0;
1240 Alt : Node_Id;
1242 begin
1243 -- The syntax for case_expression does not include parentheses,
1244 -- but sometimes parentheses are required, so unconditionally
1245 -- generate them here unless already present.
1247 if not Has_Parens then
1248 Write_Char ('(');
1249 end if;
1251 Write_Str_With_Col_Check_Sloc ("case ");
1252 Sprint_Node (Expression (Node));
1253 Write_Str_With_Col_Check (" is");
1255 Alt := First (Alternatives (Node));
1256 loop
1257 Sprint_Node (Alt);
1258 Next (Alt);
1259 exit when No (Alt);
1260 Write_Char (',');
1261 end loop;
1263 if not Has_Parens then
1264 Write_Char (')');
1265 end if;
1266 end;
1268 when N_Case_Expression_Alternative =>
1269 Write_Str_With_Col_Check (" when ");
1270 Sprint_Bar_List (Discrete_Choices (Node));
1271 Write_Str (" => ");
1272 Sprint_Node (Expression (Node));
1274 when N_Case_Statement =>
1275 Write_Indent_Str_Sloc ("case ");
1276 Sprint_Node (Expression (Node));
1277 Write_Str (" is");
1278 Sprint_Indented_List (Alternatives (Node));
1279 Write_Indent_Str ("end case;");
1281 when N_Case_Statement_Alternative =>
1282 Write_Indent_Str_Sloc ("when ");
1283 Sprint_Bar_List (Discrete_Choices (Node));
1284 Write_Str (" => ");
1285 Sprint_Indented_List (Statements (Node));
1287 when N_Character_Literal =>
1288 if Column > Sprint_Line_Limit - 2 then
1289 Write_Indent_Str (" ");
1290 end if;
1292 Write_Char_Sloc (''');
1293 Write_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
1294 Write_Char (''');
1296 when N_Code_Statement =>
1297 Write_Indent;
1298 Set_Debug_Sloc;
1299 Sprint_Node (Expression (Node));
1300 Write_Char (';');
1302 when N_Compilation_Unit =>
1303 Sprint_Node_List (Context_Items (Node));
1304 Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
1306 if Private_Present (Node) then
1307 Write_Indent_Str ("private ");
1308 Indent_Annull;
1309 end if;
1311 Sprint_Node_Sloc (Unit (Node));
1313 if Present (Actions (Aux_Decls_Node (Node)))
1314 or else
1315 Present (Pragmas_After (Aux_Decls_Node (Node)))
1316 then
1317 Write_Indent;
1318 end if;
1320 Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
1321 Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
1323 when N_Compilation_Unit_Aux =>
1324 null; -- nothing to do, never used, see above
1326 when N_Component_Association =>
1327 Set_Debug_Sloc;
1328 Sprint_Bar_List (Choices (Node));
1329 Write_Str (" => ");
1331 -- Ada 2005 (AI-287): Print the box if present
1333 if Box_Present (Node) then
1334 Write_Str_With_Col_Check ("<>");
1335 else
1336 Sprint_Node (Expression (Node));
1337 end if;
1339 when N_Iterated_Component_Association =>
1340 Set_Debug_Sloc;
1341 Write_Str (" for ");
1342 Write_Id (Defining_Identifier (Node));
1343 Write_Str (" in ");
1344 Sprint_Bar_List (Discrete_Choices (Node));
1345 Write_Str (" => ");
1346 Sprint_Node (Expression (Node));
1348 when N_Component_Clause =>
1349 Write_Indent;
1350 Sprint_Node (Component_Name (Node));
1351 Write_Str_Sloc (" at ");
1352 Sprint_Node (Position (Node));
1353 Write_Char (' ');
1354 Write_Str_With_Col_Check ("range ");
1355 Sprint_Node (First_Bit (Node));
1356 Write_Str (" .. ");
1357 Sprint_Node (Last_Bit (Node));
1358 Write_Char (';');
1360 when N_Component_Definition =>
1361 Set_Debug_Sloc;
1363 -- Ada 2005 (AI-230): Access definition components
1365 if Present (Access_Definition (Node)) then
1366 Sprint_Node (Access_Definition (Node));
1368 elsif Present (Subtype_Indication (Node)) then
1369 if Aliased_Present (Node) then
1370 Write_Str_With_Col_Check ("aliased ");
1371 end if;
1373 -- Ada 2005 (AI-231)
1375 if Null_Exclusion_Present (Node) then
1376 Write_Str (" not null ");
1377 end if;
1379 Sprint_Node (Subtype_Indication (Node));
1381 else
1382 Write_Str (" ??? ");
1383 end if;
1385 when N_Component_Declaration =>
1386 if Write_Indent_Identifiers_Sloc (Node) then
1387 Write_Str (" : ");
1388 Sprint_Node (Component_Definition (Node));
1390 if Present (Expression (Node)) then
1391 Write_Str (" := ");
1392 Sprint_Node (Expression (Node));
1393 end if;
1395 Write_Char (';');
1396 end if;
1398 when N_Component_List =>
1399 if Null_Present (Node) then
1400 Indent_Begin;
1401 Write_Indent_Str_Sloc ("null");
1402 Write_Char (';');
1403 Indent_End;
1405 else
1406 Set_Debug_Sloc;
1407 Sprint_Indented_List (Component_Items (Node));
1408 Sprint_Node (Variant_Part (Node));
1409 end if;
1411 when N_Compound_Statement =>
1412 Write_Indent_Str ("do");
1413 Indent_Begin;
1414 Sprint_Node_List (Actions (Node));
1415 Indent_End;
1416 Write_Indent_Str ("end;");
1418 when N_Conditional_Entry_Call =>
1419 Write_Indent_Str_Sloc ("select");
1420 Indent_Begin;
1421 Sprint_Node (Entry_Call_Alternative (Node));
1422 Indent_End;
1423 Write_Indent_Str ("else");
1424 Sprint_Indented_List (Else_Statements (Node));
1425 Write_Indent_Str ("end select;");
1427 when N_Constrained_Array_Definition =>
1428 Write_Str_With_Col_Check_Sloc ("array ");
1429 Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
1430 Write_Str (" of ");
1432 Sprint_Node (Component_Definition (Node));
1434 -- A contract node should not appear in the tree. It is a semantic
1435 -- node attached to entry and [generic] subprogram entities. But we
1436 -- still provide meaningful output, in case called from the debugger.
1438 when N_Contract =>
1439 declare
1440 P : Node_Id;
1442 begin
1443 Indent_Begin;
1444 Write_Str ("N_Contract node");
1445 Write_Eol;
1447 Write_Indent_Str ("Pre_Post_Conditions");
1448 Indent_Begin;
1450 P := Pre_Post_Conditions (Node);
1451 while Present (P) loop
1452 Sprint_Node (P);
1453 P := Next_Pragma (P);
1454 end loop;
1456 Write_Eol;
1457 Indent_End;
1459 Write_Indent_Str ("Contract_Test_Cases");
1460 Indent_Begin;
1462 P := Contract_Test_Cases (Node);
1463 while Present (P) loop
1464 Sprint_Node (P);
1465 P := Next_Pragma (P);
1466 end loop;
1468 Write_Eol;
1469 Indent_End;
1471 Write_Indent_Str ("Classifications");
1472 Indent_Begin;
1474 P := Classifications (Node);
1475 while Present (P) loop
1476 Sprint_Node (P);
1477 P := Next_Pragma (P);
1478 end loop;
1480 Write_Eol;
1481 Indent_End;
1482 Indent_End;
1483 end;
1485 when N_Decimal_Fixed_Point_Definition =>
1486 Write_Str_With_Col_Check_Sloc (" delta ");
1487 Sprint_Node (Delta_Expression (Node));
1488 Write_Str_With_Col_Check ("digits ");
1489 Sprint_Node (Digits_Expression (Node));
1490 Sprint_Opt_Node (Real_Range_Specification (Node));
1492 when N_Defining_Character_Literal =>
1493 Write_Name_With_Col_Check_Sloc (Chars (Node));
1495 when N_Defining_Identifier =>
1496 Set_Debug_Sloc;
1497 Write_Id (Node);
1499 when N_Defining_Operator_Symbol =>
1500 Write_Name_With_Col_Check_Sloc (Chars (Node));
1502 when N_Defining_Program_Unit_Name =>
1503 Set_Debug_Sloc;
1504 Sprint_Node (Name (Node));
1505 Write_Char ('.');
1506 Write_Id (Defining_Identifier (Node));
1508 when N_Delay_Alternative =>
1509 Sprint_Node_List (Pragmas_Before (Node));
1511 if Present (Condition (Node)) then
1512 Write_Indent;
1513 Write_Str_With_Col_Check ("when ");
1514 Sprint_Node (Condition (Node));
1515 Write_Str (" => ");
1516 Indent_Annull;
1517 end if;
1519 Sprint_Node_Sloc (Delay_Statement (Node));
1520 Sprint_Node_List (Statements (Node));
1522 when N_Delay_Relative_Statement =>
1523 Write_Indent_Str_Sloc ("delay ");
1524 Sprint_Node (Expression (Node));
1525 Write_Char (';');
1527 when N_Delay_Until_Statement =>
1528 Write_Indent_Str_Sloc ("delay until ");
1529 Sprint_Node (Expression (Node));
1530 Write_Char (';');
1532 when N_Delta_Constraint =>
1533 Write_Str_With_Col_Check_Sloc ("delta ");
1534 Sprint_Node (Delta_Expression (Node));
1535 Sprint_Opt_Node (Range_Constraint (Node));
1537 when N_Derived_Type_Definition =>
1538 if Abstract_Present (Node) then
1539 Write_Str_With_Col_Check ("abstract ");
1540 end if;
1542 Write_Str_With_Col_Check ("new ");
1544 -- Ada 2005 (AI-231)
1546 if Null_Exclusion_Present (Node) then
1547 Write_Str_With_Col_Check ("not null ");
1548 end if;
1550 Sprint_Node (Subtype_Indication (Node));
1552 if Present (Interface_List (Node)) then
1553 Write_Str_With_Col_Check (" and ");
1554 Sprint_And_List (Interface_List (Node));
1555 Write_Str_With_Col_Check (" with ");
1556 end if;
1558 if Present (Record_Extension_Part (Node)) then
1559 if No (Interface_List (Node)) then
1560 Write_Str_With_Col_Check (" with ");
1561 end if;
1563 Sprint_Node (Record_Extension_Part (Node));
1564 end if;
1566 when N_Designator =>
1567 Sprint_Node (Name (Node));
1568 Write_Char_Sloc ('.');
1569 Write_Id (Identifier (Node));
1571 when N_Digits_Constraint =>
1572 Write_Str_With_Col_Check_Sloc ("digits ");
1573 Sprint_Node (Digits_Expression (Node));
1574 Sprint_Opt_Node (Range_Constraint (Node));
1576 when N_Discriminant_Association =>
1577 Set_Debug_Sloc;
1579 if Present (Selector_Names (Node)) then
1580 Sprint_Bar_List (Selector_Names (Node));
1581 Write_Str (" => ");
1582 end if;
1584 Set_Debug_Sloc;
1585 Sprint_Node (Expression (Node));
1587 when N_Discriminant_Specification =>
1588 Set_Debug_Sloc;
1590 if Write_Identifiers (Node) then
1591 Write_Str (" : ");
1593 if Null_Exclusion_Present (Node) then
1594 Write_Str ("not null ");
1595 end if;
1597 Sprint_Node (Discriminant_Type (Node));
1599 if Present (Expression (Node)) then
1600 Write_Str (" := ");
1601 Sprint_Node (Expression (Node));
1602 end if;
1603 else
1604 Write_Str (", ");
1605 end if;
1607 when N_Elsif_Part =>
1608 Write_Indent_Str_Sloc ("elsif ");
1609 Sprint_Node (Condition (Node));
1610 Write_Str_With_Col_Check (" then");
1611 Sprint_Indented_List (Then_Statements (Node));
1613 when N_Empty =>
1614 null;
1616 when N_Entry_Body =>
1617 Write_Indent_Str_Sloc ("entry ");
1618 Write_Id (Defining_Identifier (Node));
1619 Sprint_Node (Entry_Body_Formal_Part (Node));
1620 Write_Str_With_Col_Check (" is");
1621 Sprint_Indented_List (Declarations (Node));
1622 Write_Indent_Str ("begin");
1623 Sprint_Node (Handled_Statement_Sequence (Node));
1624 Write_Indent_Str ("end ");
1625 Write_Id (Defining_Identifier (Node));
1626 Write_Char (';');
1628 when N_Entry_Body_Formal_Part =>
1629 if Present (Entry_Index_Specification (Node)) then
1630 Write_Str_With_Col_Check_Sloc (" (");
1631 Sprint_Node (Entry_Index_Specification (Node));
1632 Write_Char (')');
1633 end if;
1635 Write_Param_Specs (Node);
1636 Write_Str_With_Col_Check_Sloc (" when ");
1637 Sprint_Node (Condition (Node));
1639 when N_Entry_Call_Alternative =>
1640 Sprint_Node_List (Pragmas_Before (Node));
1641 Sprint_Node_Sloc (Entry_Call_Statement (Node));
1642 Sprint_Node_List (Statements (Node));
1644 when N_Entry_Call_Statement =>
1645 Write_Indent;
1646 Sprint_Node_Sloc (Name (Node));
1647 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1648 Write_Char (';');
1650 when N_Entry_Declaration =>
1651 Write_Indent_Str_Sloc ("entry ");
1652 Write_Id (Defining_Identifier (Node));
1654 if Present (Discrete_Subtype_Definition (Node)) then
1655 Write_Str_With_Col_Check (" (");
1656 Sprint_Node (Discrete_Subtype_Definition (Node));
1657 Write_Char (')');
1658 end if;
1660 Write_Param_Specs (Node);
1661 Write_Char (';');
1663 when N_Entry_Index_Specification =>
1664 Write_Str_With_Col_Check_Sloc ("for ");
1665 Write_Id (Defining_Identifier (Node));
1666 Write_Str_With_Col_Check (" in ");
1667 Sprint_Node (Discrete_Subtype_Definition (Node));
1669 when N_Enumeration_Representation_Clause =>
1670 Write_Indent_Str_Sloc ("for ");
1671 Write_Id (Identifier (Node));
1672 Write_Str_With_Col_Check (" use ");
1673 Sprint_Node (Array_Aggregate (Node));
1674 Write_Char (';');
1676 when N_Enumeration_Type_Definition =>
1677 Set_Debug_Sloc;
1679 -- Skip attempt to print Literals field if it's not there and
1680 -- we are in package Standard (case of Character, which is
1681 -- handled specially (without an explicit literals list).
1683 if Sloc (Node) > Standard_Location
1684 or else Present (Literals (Node))
1685 then
1686 Sprint_Paren_Comma_List (Literals (Node));
1687 end if;
1689 when N_Error =>
1690 Write_Str_With_Col_Check_Sloc ("<error>");
1692 when N_Exception_Declaration =>
1693 if Write_Indent_Identifiers (Node) then
1694 Write_Str_With_Col_Check (" : ");
1696 if Is_Statically_Allocated (Defining_Identifier (Node)) then
1697 Write_Str_With_Col_Check ("static ");
1698 end if;
1700 Write_Str_Sloc ("exception");
1702 if Present (Expression (Node)) then
1703 Write_Str (" := ");
1704 Sprint_Node (Expression (Node));
1705 end if;
1707 Write_Char (';');
1708 end if;
1710 when N_Exception_Handler =>
1711 Write_Indent_Str_Sloc ("when ");
1713 if Present (Choice_Parameter (Node)) then
1714 Sprint_Node (Choice_Parameter (Node));
1715 Write_Str (" : ");
1716 end if;
1718 Sprint_Bar_List (Exception_Choices (Node));
1719 Write_Str (" => ");
1720 Sprint_Indented_List (Statements (Node));
1722 when N_Exception_Renaming_Declaration =>
1723 Write_Indent;
1724 Set_Debug_Sloc;
1725 Sprint_Node (Defining_Identifier (Node));
1726 Write_Str_With_Col_Check (" : exception renames ");
1727 Sprint_Node (Name (Node));
1728 Write_Char (';');
1730 when N_Exit_Statement =>
1731 Write_Indent_Str_Sloc ("exit");
1732 Sprint_Opt_Node (Name (Node));
1734 if Present (Condition (Node)) then
1735 Write_Str_With_Col_Check (" when ");
1736 Sprint_Node (Condition (Node));
1737 end if;
1739 Write_Char (';');
1741 when N_Expanded_Name =>
1742 Sprint_Node (Prefix (Node));
1743 Write_Char_Sloc ('.');
1744 Sprint_Node (Selector_Name (Node));
1746 when N_Explicit_Dereference =>
1747 Sprint_Node (Prefix (Node));
1748 Write_Char_Sloc ('.');
1749 Write_Str_Sloc ("all");
1751 when N_Expression_With_Actions =>
1752 Indent_Begin;
1753 Write_Indent_Str_Sloc ("do ");
1754 Indent_Begin;
1755 Sprint_Node_List (Actions (Node));
1756 Indent_End;
1757 Write_Indent;
1758 Write_Str_With_Col_Check_Sloc ("in ");
1759 Sprint_Node (Expression (Node));
1760 Write_Str_With_Col_Check (" end");
1761 Indent_End;
1762 Write_Indent;
1764 when N_Expression_Function =>
1765 Write_Indent;
1766 Sprint_Node_Sloc (Specification (Node));
1767 Write_Str (" is");
1768 Indent_Begin;
1769 Write_Indent;
1770 Sprint_Node (Expression (Node));
1771 Write_Char (';');
1772 Indent_End;
1774 when N_Extended_Return_Statement =>
1775 Write_Indent_Str_Sloc ("return ");
1776 Sprint_Node_List (Return_Object_Declarations (Node));
1778 if Present (Handled_Statement_Sequence (Node)) then
1779 Write_Str_With_Col_Check (" do");
1780 Sprint_Node (Handled_Statement_Sequence (Node));
1781 Write_Indent_Str ("end return;");
1782 else
1783 Write_Indent_Str (";");
1784 end if;
1786 when N_Delta_Aggregate =>
1787 Write_Str_With_Col_Check_Sloc ("(");
1788 Sprint_Node (Expression (Node));
1789 Write_Str_With_Col_Check (" with delta ");
1790 Sprint_Comma_List (Component_Associations (Node));
1791 Write_Char (')');
1793 when N_Extension_Aggregate =>
1794 Write_Str_With_Col_Check_Sloc ("(");
1795 Sprint_Node (Ancestor_Part (Node));
1796 Write_Str_With_Col_Check (" with ");
1798 if Null_Record_Present (Node) then
1799 Write_Str_With_Col_Check ("null record");
1800 else
1801 if Present (Expressions (Node)) then
1802 Sprint_Comma_List (Expressions (Node));
1804 if Present (Component_Associations (Node)) then
1805 Write_Str (", ");
1806 end if;
1807 end if;
1809 if Present (Component_Associations (Node)) then
1810 Sprint_Comma_List (Component_Associations (Node));
1811 end if;
1812 end if;
1814 Write_Char (')');
1816 when N_Floating_Point_Definition =>
1817 Write_Str_With_Col_Check_Sloc ("digits ");
1818 Sprint_Node (Digits_Expression (Node));
1819 Sprint_Opt_Node (Real_Range_Specification (Node));
1821 when N_Formal_Decimal_Fixed_Point_Definition =>
1822 Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
1824 when N_Formal_Derived_Type_Definition =>
1825 Write_Str_With_Col_Check_Sloc ("new ");
1826 Sprint_Node (Subtype_Mark (Node));
1828 if Present (Interface_List (Node)) then
1829 Write_Str_With_Col_Check (" and ");
1830 Sprint_And_List (Interface_List (Node));
1831 end if;
1833 if Private_Present (Node) then
1834 Write_Str_With_Col_Check (" with private");
1835 end if;
1837 when N_Formal_Abstract_Subprogram_Declaration =>
1838 Write_Indent_Str_Sloc ("with ");
1839 Sprint_Node (Specification (Node));
1841 Write_Str_With_Col_Check (" is abstract");
1843 if Box_Present (Node) then
1844 Write_Str_With_Col_Check (" <>");
1845 elsif Present (Default_Name (Node)) then
1846 Write_Str_With_Col_Check (" ");
1847 Sprint_Node (Default_Name (Node));
1848 end if;
1850 Write_Char (';');
1852 when N_Formal_Concrete_Subprogram_Declaration =>
1853 Write_Indent_Str_Sloc ("with ");
1854 Sprint_Node (Specification (Node));
1856 if Box_Present (Node) then
1857 Write_Str_With_Col_Check (" is <>");
1858 elsif Present (Default_Name (Node)) then
1859 Write_Str_With_Col_Check (" is ");
1860 Sprint_Node (Default_Name (Node));
1861 end if;
1863 Write_Char (';');
1865 when N_Formal_Discrete_Type_Definition =>
1866 Write_Str_With_Col_Check_Sloc ("<>");
1868 when N_Formal_Floating_Point_Definition =>
1869 Write_Str_With_Col_Check_Sloc ("digits <>");
1871 when N_Formal_Modular_Type_Definition =>
1872 Write_Str_With_Col_Check_Sloc ("mod <>");
1874 when N_Formal_Object_Declaration =>
1875 Set_Debug_Sloc;
1877 if Write_Indent_Identifiers (Node) then
1878 Write_Str (" : ");
1880 if In_Present (Node) then
1881 Write_Str_With_Col_Check ("in ");
1882 end if;
1884 if Out_Present (Node) then
1885 Write_Str_With_Col_Check ("out ");
1886 end if;
1888 if Present (Subtype_Mark (Node)) then
1890 -- Ada 2005 (AI-423): Formal object with null exclusion
1892 if Null_Exclusion_Present (Node) then
1893 Write_Str ("not null ");
1894 end if;
1896 Sprint_Node (Subtype_Mark (Node));
1898 -- Ada 2005 (AI-423): Formal object with access definition
1900 else
1901 pragma Assert (Present (Access_Definition (Node)));
1903 Sprint_Node (Access_Definition (Node));
1904 end if;
1906 if Present (Default_Expression (Node)) then
1907 Write_Str (" := ");
1908 Sprint_Node (Default_Expression (Node));
1909 end if;
1911 Write_Char (';');
1912 end if;
1914 when N_Formal_Ordinary_Fixed_Point_Definition =>
1915 Write_Str_With_Col_Check_Sloc ("delta <>");
1917 when N_Formal_Package_Declaration =>
1918 Write_Indent_Str_Sloc ("with package ");
1919 Write_Id (Defining_Identifier (Node));
1920 Write_Str_With_Col_Check (" is new ");
1921 Sprint_Node (Name (Node));
1922 Write_Str_With_Col_Check (" (<>);");
1924 when N_Formal_Private_Type_Definition =>
1925 if Abstract_Present (Node) then
1926 Write_Str_With_Col_Check ("abstract ");
1927 end if;
1929 if Tagged_Present (Node) then
1930 Write_Str_With_Col_Check ("tagged ");
1931 end if;
1933 if Limited_Present (Node) then
1934 Write_Str_With_Col_Check ("limited ");
1935 end if;
1937 Write_Str_With_Col_Check_Sloc ("private");
1939 when N_Formal_Incomplete_Type_Definition =>
1940 if Tagged_Present (Node) then
1941 Write_Str_With_Col_Check ("is tagged ");
1942 end if;
1944 when N_Formal_Signed_Integer_Type_Definition =>
1945 Write_Str_With_Col_Check_Sloc ("range <>");
1947 when N_Formal_Type_Declaration =>
1948 Write_Indent_Str_Sloc ("type ");
1949 Write_Id (Defining_Identifier (Node));
1951 if Present (Discriminant_Specifications (Node)) then
1952 Write_Discr_Specs (Node);
1953 elsif Unknown_Discriminants_Present (Node) then
1954 Write_Str_With_Col_Check ("(<>)");
1955 end if;
1957 if Nkind (Formal_Type_Definition (Node)) /=
1958 N_Formal_Incomplete_Type_Definition
1959 then
1960 Write_Str_With_Col_Check (" is ");
1961 end if;
1963 Sprint_Node (Formal_Type_Definition (Node));
1964 Write_Char (';');
1966 when N_Free_Statement =>
1967 Write_Indent_Str_Sloc ("free ");
1968 Sprint_Node (Expression (Node));
1969 Write_Char (';');
1971 when N_Freeze_Entity =>
1972 if Dump_Original_Only then
1973 null;
1975 -- A freeze node is output if it has some effect (i.e. non-empty
1976 -- actions, or freeze node for an itype, which causes elaboration
1977 -- of the itype), and is also always output if Dump_Freeze_Null
1978 -- is set True.
1980 elsif Present (Actions (Node))
1981 or else Is_Itype (Entity (Node))
1982 or else Dump_Freeze_Null
1983 then
1984 Write_Indent;
1985 Write_Rewrite_Str ("<<<");
1986 Write_Str_With_Col_Check_Sloc ("freeze ");
1987 Write_Id (Entity (Node));
1988 Write_Str (" [");
1990 if No (Actions (Node)) then
1991 Write_Char (']');
1993 else
1994 -- Output freeze actions. We increment Freeze_Indent during
1995 -- this output to avoid generating extra blank lines before
1996 -- any procedures included in the freeze actions.
1998 Freeze_Indent := Freeze_Indent + 1;
1999 Sprint_Indented_List (Actions (Node));
2000 Freeze_Indent := Freeze_Indent - 1;
2001 Write_Indent_Str ("]");
2002 end if;
2004 Write_Rewrite_Str (">>>");
2005 end if;
2007 when N_Freeze_Generic_Entity =>
2008 if Dump_Original_Only then
2009 null;
2011 else
2012 Write_Indent;
2013 Write_Str_With_Col_Check_Sloc ("freeze_generic ");
2014 Write_Id (Entity (Node));
2015 end if;
2017 when N_Full_Type_Declaration =>
2018 Write_Indent_Str_Sloc ("type ");
2019 Sprint_Node (Defining_Identifier (Node));
2020 Write_Discr_Specs (Node);
2021 Write_Str_With_Col_Check (" is ");
2022 Sprint_Node (Type_Definition (Node));
2023 Write_Char (';');
2025 when N_Function_Call =>
2026 Set_Debug_Sloc;
2027 Write_Subprogram_Name (Name (Node));
2028 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
2030 when N_Function_Instantiation =>
2031 Write_Indent_Str_Sloc ("function ");
2032 Sprint_Node (Defining_Unit_Name (Node));
2033 Write_Str_With_Col_Check (" is new ");
2034 Sprint_Node (Name (Node));
2035 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2036 Write_Char (';');
2038 when N_Function_Specification =>
2039 Write_Str_With_Col_Check_Sloc ("function ");
2040 Sprint_Node (Defining_Unit_Name (Node));
2041 Write_Param_Specs (Node);
2042 Write_Str_With_Col_Check (" return ");
2044 -- Ada 2005 (AI-231)
2046 if Nkind (Result_Definition (Node)) /= N_Access_Definition
2047 and then Null_Exclusion_Present (Node)
2048 then
2049 Write_Str (" not null ");
2050 end if;
2052 Sprint_Node (Result_Definition (Node));
2054 when N_Generic_Association =>
2055 Set_Debug_Sloc;
2057 if Present (Selector_Name (Node)) then
2058 Sprint_Node (Selector_Name (Node));
2059 Write_Str (" => ");
2060 end if;
2062 Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
2064 when N_Generic_Function_Renaming_Declaration =>
2065 Write_Indent_Str_Sloc ("generic function ");
2066 Sprint_Node (Defining_Unit_Name (Node));
2067 Write_Str_With_Col_Check (" renames ");
2068 Sprint_Node (Name (Node));
2069 Write_Char (';');
2071 when N_Generic_Package_Declaration =>
2072 Extra_Blank_Line;
2073 Write_Indent_Str_Sloc ("generic ");
2074 Sprint_Indented_List (Generic_Formal_Declarations (Node));
2075 Write_Indent;
2076 Sprint_Node (Specification (Node));
2077 Write_Char (';');
2079 when N_Generic_Package_Renaming_Declaration =>
2080 Write_Indent_Str_Sloc ("generic package ");
2081 Sprint_Node (Defining_Unit_Name (Node));
2082 Write_Str_With_Col_Check (" renames ");
2083 Sprint_Node (Name (Node));
2084 Write_Char (';');
2086 when N_Generic_Procedure_Renaming_Declaration =>
2087 Write_Indent_Str_Sloc ("generic procedure ");
2088 Sprint_Node (Defining_Unit_Name (Node));
2089 Write_Str_With_Col_Check (" renames ");
2090 Sprint_Node (Name (Node));
2091 Write_Char (';');
2093 when N_Generic_Subprogram_Declaration =>
2094 Extra_Blank_Line;
2095 Write_Indent_Str_Sloc ("generic ");
2096 Sprint_Indented_List (Generic_Formal_Declarations (Node));
2097 Write_Indent;
2098 Sprint_Node (Specification (Node));
2099 Write_Char (';');
2101 when N_Goto_Statement =>
2102 Write_Indent_Str_Sloc ("goto ");
2103 Sprint_Node (Name (Node));
2104 Write_Char (';');
2106 if Nkind (Next (Node)) = N_Label then
2107 Write_Indent;
2108 end if;
2110 when N_Handled_Sequence_Of_Statements =>
2111 Set_Debug_Sloc;
2112 Sprint_Indented_List (Statements (Node));
2114 if Present (Exception_Handlers (Node)) then
2115 Write_Indent_Str ("exception");
2116 Indent_Begin;
2117 Sprint_Node_List (Exception_Handlers (Node));
2118 Indent_End;
2119 end if;
2121 if Present (At_End_Proc (Node)) then
2122 Write_Indent_Str ("at end");
2123 Indent_Begin;
2124 Write_Indent;
2125 Sprint_Node (At_End_Proc (Node));
2126 Write_Char (';');
2127 Indent_End;
2128 end if;
2130 when N_Identifier =>
2131 Set_Debug_Sloc;
2132 Write_Id (Node);
2134 when N_If_Expression =>
2135 declare
2136 Has_Parens : constant Boolean := Paren_Count (Node) > 0;
2137 Condition : constant Node_Id := First (Expressions (Node));
2138 Then_Expr : constant Node_Id := Next (Condition);
2140 begin
2141 -- The syntax for if_expression does not include parentheses,
2142 -- but sometimes parentheses are required, so unconditionally
2143 -- generate them here unless already present.
2145 if not Has_Parens then
2146 Write_Char ('(');
2147 end if;
2149 Write_Str_With_Col_Check_Sloc ("if ");
2150 Sprint_Node (Condition);
2151 Write_Str_With_Col_Check (" then ");
2153 -- Defense against junk here
2155 if Present (Then_Expr) then
2156 Sprint_Node (Then_Expr);
2158 if Present (Next (Then_Expr)) then
2159 Write_Str_With_Col_Check (" else ");
2160 Sprint_Node (Next (Then_Expr));
2161 end if;
2162 end if;
2164 if not Has_Parens then
2165 Write_Char (')');
2166 end if;
2167 end;
2169 when N_If_Statement =>
2170 Write_Indent_Str_Sloc ("if ");
2171 Sprint_Node (Condition (Node));
2172 Write_Str_With_Col_Check (" then");
2173 Sprint_Indented_List (Then_Statements (Node));
2174 Sprint_Opt_Node_List (Elsif_Parts (Node));
2176 if Present (Else_Statements (Node)) then
2177 Write_Indent_Str ("else");
2178 Sprint_Indented_List (Else_Statements (Node));
2179 end if;
2181 Write_Indent_Str ("end if;");
2183 when N_Implicit_Label_Declaration =>
2184 if not Dump_Original_Only then
2185 Write_Indent;
2186 Write_Rewrite_Str ("<<<");
2187 Set_Debug_Sloc;
2188 Write_Id (Defining_Identifier (Node));
2189 Write_Str (" : ");
2190 Write_Str_With_Col_Check ("label");
2191 Write_Rewrite_Str (">>>");
2192 end if;
2194 when N_In =>
2195 Sprint_Left_Opnd (Node);
2196 Write_Str_Sloc (" in ");
2198 if Present (Right_Opnd (Node)) then
2199 Sprint_Right_Opnd (Node);
2200 else
2201 Sprint_Bar_List (Alternatives (Node));
2202 end if;
2204 when N_Incomplete_Type_Declaration =>
2205 Write_Indent_Str_Sloc ("type ");
2206 Write_Id (Defining_Identifier (Node));
2208 if Present (Discriminant_Specifications (Node)) then
2209 Write_Discr_Specs (Node);
2210 elsif Unknown_Discriminants_Present (Node) then
2211 Write_Str_With_Col_Check ("(<>)");
2212 end if;
2214 Write_Char (';');
2216 when N_Index_Or_Discriminant_Constraint =>
2217 Set_Debug_Sloc;
2218 Sprint_Paren_Comma_List (Constraints (Node));
2220 when N_Indexed_Component =>
2221 Sprint_Node_Sloc (Prefix (Node));
2222 Sprint_Opt_Paren_Comma_List (Expressions (Node));
2224 when N_Integer_Literal =>
2225 if Print_In_Hex (Node) then
2226 Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
2227 else
2228 Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
2229 end if;
2231 when N_Iteration_Scheme =>
2232 if Present (Condition (Node)) then
2233 Write_Str_With_Col_Check_Sloc ("while ");
2234 Sprint_Node (Condition (Node));
2235 else
2236 Write_Str_With_Col_Check_Sloc ("for ");
2238 if Present (Iterator_Specification (Node)) then
2239 Sprint_Node (Iterator_Specification (Node));
2240 else
2241 Sprint_Node (Loop_Parameter_Specification (Node));
2242 end if;
2243 end if;
2245 Write_Char (' ');
2247 when N_Iterator_Specification =>
2248 Set_Debug_Sloc;
2249 Write_Id (Defining_Identifier (Node));
2251 if Present (Subtype_Indication (Node)) then
2252 Write_Str_With_Col_Check (" : ");
2253 Sprint_Node (Subtype_Indication (Node));
2254 end if;
2256 if Of_Present (Node) then
2257 Write_Str_With_Col_Check (" of ");
2258 else
2259 Write_Str_With_Col_Check (" in ");
2260 end if;
2262 if Reverse_Present (Node) then
2263 Write_Str_With_Col_Check ("reverse ");
2264 end if;
2266 Sprint_Node (Name (Node));
2268 when N_Itype_Reference =>
2269 Write_Indent_Str_Sloc ("reference ");
2270 Write_Id (Itype (Node));
2272 when N_Label =>
2273 Write_Indent_Str_Sloc ("<<");
2274 Write_Id (Identifier (Node));
2275 Write_Str (">>");
2277 when N_Loop_Parameter_Specification =>
2278 Set_Debug_Sloc;
2279 Write_Id (Defining_Identifier (Node));
2280 Write_Str_With_Col_Check (" in ");
2282 if Reverse_Present (Node) then
2283 Write_Str_With_Col_Check ("reverse ");
2284 end if;
2286 Sprint_Node (Discrete_Subtype_Definition (Node));
2288 when N_Loop_Statement =>
2289 Write_Indent;
2291 if Present (Identifier (Node))
2292 and then (not Has_Created_Identifier (Node)
2293 or else not Dump_Original_Only)
2294 then
2295 Write_Rewrite_Str ("<<<");
2296 Write_Id (Identifier (Node));
2297 Write_Str (" : ");
2298 Write_Rewrite_Str (">>>");
2299 Sprint_Node (Iteration_Scheme (Node));
2300 Write_Str_With_Col_Check_Sloc ("loop");
2301 Sprint_Indented_List (Statements (Node));
2302 Write_Indent_Str ("end loop ");
2303 Write_Rewrite_Str ("<<<");
2304 Write_Id (Identifier (Node));
2305 Write_Rewrite_Str (">>>");
2306 Write_Char (';');
2308 else
2309 Sprint_Node (Iteration_Scheme (Node));
2310 Write_Str_With_Col_Check_Sloc ("loop");
2311 Sprint_Indented_List (Statements (Node));
2312 Write_Indent_Str ("end loop;");
2313 end if;
2315 when N_Mod_Clause =>
2316 Sprint_Node_List (Pragmas_Before (Node));
2317 Write_Str_With_Col_Check_Sloc ("at mod ");
2318 Sprint_Node (Expression (Node));
2320 when N_Modular_Type_Definition =>
2321 Write_Str_With_Col_Check_Sloc ("mod ");
2322 Sprint_Node (Expression (Node));
2324 when N_Not_In =>
2325 Sprint_Left_Opnd (Node);
2326 Write_Str_Sloc (" not in ");
2328 if Present (Right_Opnd (Node)) then
2329 Sprint_Right_Opnd (Node);
2330 else
2331 Sprint_Bar_List (Alternatives (Node));
2332 end if;
2334 when N_Null =>
2335 Write_Str_With_Col_Check_Sloc ("null");
2337 when N_Null_Statement =>
2338 if Comes_From_Source (Node)
2339 or else Dump_Freeze_Null
2340 or else not Is_List_Member (Node)
2341 or else (No (Prev (Node)) and then No (Next (Node)))
2342 then
2343 Write_Indent_Str_Sloc ("null;");
2344 end if;
2346 when N_Number_Declaration =>
2347 Set_Debug_Sloc;
2349 if Write_Indent_Identifiers (Node) then
2350 Write_Str_With_Col_Check (" : constant ");
2351 Write_Str (" := ");
2352 Sprint_Node (Expression (Node));
2353 Write_Char (';');
2354 end if;
2356 when N_Object_Declaration =>
2357 Set_Debug_Sloc;
2359 if Write_Indent_Identifiers (Node) then
2360 declare
2361 Def_Id : constant Entity_Id := Defining_Identifier (Node);
2363 begin
2364 Write_Str_With_Col_Check (" : ");
2366 if Is_Statically_Allocated (Def_Id) then
2367 Write_Str_With_Col_Check ("static ");
2368 end if;
2370 if Aliased_Present (Node) then
2371 Write_Str_With_Col_Check ("aliased ");
2372 end if;
2374 if Constant_Present (Node) then
2375 Write_Str_With_Col_Check ("constant ");
2376 end if;
2378 -- Ada 2005 (AI-231)
2380 if Null_Exclusion_Present (Node) then
2381 Write_Str_With_Col_Check ("not null ");
2382 end if;
2384 -- Print type. We used to print the Object_Definition from
2385 -- the node, but it is much more useful to print the Etype
2386 -- of the defining identifier for the case where the nominal
2387 -- type is an unconstrained array type. For example, this
2388 -- will be a clear reference to the Itype with the bounds
2389 -- in the case of a type like String. The object after
2390 -- all is constrained, even if its nominal subtype is
2391 -- unconstrained.
2393 declare
2394 Odef : constant Node_Id := Object_Definition (Node);
2396 begin
2397 if Nkind (Odef) = N_Identifier
2398 and then Present (Etype (Odef))
2399 and then Is_Array_Type (Etype (Odef))
2400 and then not Is_Constrained (Etype (Odef))
2401 and then Present (Etype (Def_Id))
2402 then
2403 Sprint_Node (Etype (Def_Id));
2405 -- In other cases, the nominal type is fine to print
2407 else
2408 Sprint_Node (Odef);
2409 end if;
2410 end;
2412 if Present (Expression (Node))
2413 and then Expression (Node) /= Error
2414 then
2415 Write_Str (" := ");
2416 Sprint_Node (Expression (Node));
2417 end if;
2419 Write_Char (';');
2421 -- Handle implicit importation and implicit exportation of
2422 -- object declarations:
2423 -- $pragma import (Convention_Id, Def_Id, "...");
2424 -- $pragma export (Convention_Id, Def_Id, "...");
2426 if Is_Internal (Def_Id)
2427 and then Present (Interface_Name (Def_Id))
2428 then
2429 Write_Indent_Str_Sloc ("$pragma ");
2431 if Is_Imported (Def_Id) then
2432 Write_Str ("import (");
2434 else pragma Assert (Is_Exported (Def_Id));
2435 Write_Str ("export (");
2436 end if;
2438 declare
2439 Prefix : constant String := "Convention_";
2440 S : constant String := Convention (Def_Id)'Img;
2442 begin
2443 Name_Len := S'Last - Prefix'Last;
2444 Name_Buffer (1 .. Name_Len) :=
2445 S (Prefix'Last + 1 .. S'Last);
2446 Set_Casing (All_Lower_Case);
2447 Write_Str (Name_Buffer (1 .. Name_Len));
2448 end;
2450 Write_Str (", ");
2451 Write_Id (Def_Id);
2452 Write_Str (", ");
2453 Write_String_Table_Entry
2454 (Strval (Interface_Name (Def_Id)));
2455 Write_Str (");");
2456 end if;
2457 end;
2458 end if;
2460 when N_Object_Renaming_Declaration =>
2461 Write_Indent;
2462 Set_Debug_Sloc;
2463 Sprint_Node (Defining_Identifier (Node));
2464 Write_Str (" : ");
2466 -- Ada 2005 (AI-230): Access renamings
2468 if Present (Access_Definition (Node)) then
2469 Sprint_Node (Access_Definition (Node));
2471 elsif Present (Subtype_Mark (Node)) then
2473 -- Ada 2005 (AI-423): Object renaming with a null exclusion
2475 if Null_Exclusion_Present (Node) then
2476 Write_Str ("not null ");
2477 end if;
2479 Sprint_Node (Subtype_Mark (Node));
2481 else
2482 Write_Str (" ??? ");
2483 end if;
2485 Write_Str_With_Col_Check (" renames ");
2486 Sprint_Node (Name (Node));
2487 Write_Char (';');
2489 when N_Op_Abs =>
2490 Write_Operator (Node, "abs ");
2491 Sprint_Right_Opnd (Node);
2493 when N_Op_Add =>
2494 Sprint_Left_Opnd (Node);
2495 Write_Operator (Node, " + ");
2496 Sprint_Right_Opnd (Node);
2498 when N_Op_And =>
2499 Sprint_Left_Opnd (Node);
2500 Write_Operator (Node, " and ");
2501 Sprint_Right_Opnd (Node);
2503 when N_Op_Concat =>
2504 Sprint_Left_Opnd (Node);
2505 Write_Operator (Node, " & ");
2506 Sprint_Right_Opnd (Node);
2508 when N_Op_Divide =>
2509 Sprint_Left_Opnd (Node);
2510 Write_Char (' ');
2511 Process_TFAI_RR_Flags (Node);
2512 Write_Operator (Node, "/ ");
2513 Sprint_Right_Opnd (Node);
2515 when N_Op_Eq =>
2516 Sprint_Left_Opnd (Node);
2517 Write_Operator (Node, " = ");
2518 Sprint_Right_Opnd (Node);
2520 when N_Op_Expon =>
2521 Sprint_Left_Opnd (Node);
2522 Write_Operator (Node, " ** ");
2523 Sprint_Right_Opnd (Node);
2525 when N_Op_Ge =>
2526 Sprint_Left_Opnd (Node);
2527 Write_Operator (Node, " >= ");
2528 Sprint_Right_Opnd (Node);
2530 when N_Op_Gt =>
2531 Sprint_Left_Opnd (Node);
2532 Write_Operator (Node, " > ");
2533 Sprint_Right_Opnd (Node);
2535 when N_Op_Le =>
2536 Sprint_Left_Opnd (Node);
2537 Write_Operator (Node, " <= ");
2538 Sprint_Right_Opnd (Node);
2540 when N_Op_Lt =>
2541 Sprint_Left_Opnd (Node);
2542 Write_Operator (Node, " < ");
2543 Sprint_Right_Opnd (Node);
2545 when N_Op_Minus =>
2546 Write_Operator (Node, "-");
2547 Sprint_Right_Opnd (Node);
2549 when N_Op_Mod =>
2550 Sprint_Left_Opnd (Node);
2552 if Treat_Fixed_As_Integer (Node) then
2553 Write_Str (" #");
2554 end if;
2556 Write_Operator (Node, " mod ");
2557 Sprint_Right_Opnd (Node);
2559 when N_Op_Multiply =>
2560 Sprint_Left_Opnd (Node);
2561 Write_Char (' ');
2562 Process_TFAI_RR_Flags (Node);
2563 Write_Operator (Node, "* ");
2564 Sprint_Right_Opnd (Node);
2566 when N_Op_Ne =>
2567 Sprint_Left_Opnd (Node);
2568 Write_Operator (Node, " /= ");
2569 Sprint_Right_Opnd (Node);
2571 when N_Op_Not =>
2572 Write_Operator (Node, "not ");
2573 Sprint_Right_Opnd (Node);
2575 when N_Op_Or =>
2576 Sprint_Left_Opnd (Node);
2577 Write_Operator (Node, " or ");
2578 Sprint_Right_Opnd (Node);
2580 when N_Op_Plus =>
2581 Write_Operator (Node, "+");
2582 Sprint_Right_Opnd (Node);
2584 when N_Op_Rem =>
2585 Sprint_Left_Opnd (Node);
2587 if Treat_Fixed_As_Integer (Node) then
2588 Write_Str (" #");
2589 end if;
2591 Write_Operator (Node, " rem ");
2592 Sprint_Right_Opnd (Node);
2594 when N_Op_Shift =>
2595 Set_Debug_Sloc;
2596 Write_Id (Node);
2597 Write_Char ('!');
2598 Write_Str_With_Col_Check ("(");
2599 Sprint_Node (Left_Opnd (Node));
2600 Write_Str (", ");
2601 Sprint_Node (Right_Opnd (Node));
2602 Write_Char (')');
2604 when N_Op_Subtract =>
2605 Sprint_Left_Opnd (Node);
2606 Write_Operator (Node, " - ");
2607 Sprint_Right_Opnd (Node);
2609 when N_Op_Xor =>
2610 Sprint_Left_Opnd (Node);
2611 Write_Operator (Node, " xor ");
2612 Sprint_Right_Opnd (Node);
2614 when N_Operator_Symbol =>
2615 Write_Name_With_Col_Check_Sloc (Chars (Node));
2617 when N_Ordinary_Fixed_Point_Definition =>
2618 Write_Str_With_Col_Check_Sloc ("delta ");
2619 Sprint_Node (Delta_Expression (Node));
2620 Sprint_Opt_Node (Real_Range_Specification (Node));
2622 when N_Or_Else =>
2623 Sprint_Left_Opnd (Node);
2624 Write_Str_Sloc (" or else ");
2625 Sprint_Right_Opnd (Node);
2627 when N_Others_Choice =>
2628 if All_Others (Node) then
2629 Write_Str_With_Col_Check ("all ");
2630 end if;
2632 Write_Str_With_Col_Check_Sloc ("others");
2634 when N_Package_Body =>
2635 Extra_Blank_Line;
2636 Write_Indent_Str_Sloc ("package body ");
2637 Sprint_Node (Defining_Unit_Name (Node));
2638 Write_Str (" is");
2639 Sprint_Indented_List (Declarations (Node));
2641 if Present (Handled_Statement_Sequence (Node)) then
2642 Write_Indent_Str ("begin");
2643 Sprint_Node (Handled_Statement_Sequence (Node));
2644 end if;
2646 Write_Indent_Str ("end ");
2647 Sprint_End_Label
2648 (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
2649 Write_Char (';');
2651 when N_Package_Body_Stub =>
2652 Write_Indent_Str_Sloc ("package body ");
2653 Sprint_Node (Defining_Identifier (Node));
2654 Write_Str_With_Col_Check (" is separate;");
2656 when N_Package_Declaration =>
2657 Extra_Blank_Line;
2658 Write_Indent;
2659 Sprint_Node_Sloc (Specification (Node));
2660 Write_Char (';');
2662 -- If this is an instantiation, get the aspects from the original
2663 -- instantiation node.
2665 if Is_Generic_Instance (Defining_Entity (Node))
2666 and then Has_Aspects
2667 (Package_Instantiation (Defining_Entity (Node)))
2668 then
2669 Sprint_Aspect_Specifications
2670 (Package_Instantiation (Defining_Entity (Node)),
2671 Semicolon => True);
2672 end if;
2674 when N_Package_Instantiation =>
2675 Extra_Blank_Line;
2676 Write_Indent_Str_Sloc ("package ");
2677 Sprint_Node (Defining_Unit_Name (Node));
2678 Write_Str (" is new ");
2679 Sprint_Node (Name (Node));
2680 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2681 Write_Char (';');
2683 when N_Package_Renaming_Declaration =>
2684 Write_Indent_Str_Sloc ("package ");
2685 Sprint_Node (Defining_Unit_Name (Node));
2686 Write_Str_With_Col_Check (" renames ");
2687 Sprint_Node (Name (Node));
2688 Write_Char (';');
2690 when N_Package_Specification =>
2691 Write_Str_With_Col_Check_Sloc ("package ");
2692 Sprint_Node (Defining_Unit_Name (Node));
2694 if Nkind (Parent (Node)) = N_Generic_Package_Declaration
2695 and then Has_Aspects (Parent (Node))
2696 then
2697 Sprint_Aspect_Specifications
2698 (Parent (Node), Semicolon => False);
2700 -- An instantiation is rewritten as a package declaration, but
2701 -- the aspects belong to the instantiation node.
2703 elsif Nkind (Parent (Node)) = N_Package_Declaration then
2704 declare
2705 Pack : constant Entity_Id := Defining_Entity (Node);
2707 begin
2708 if not Is_Generic_Instance (Pack) then
2709 if Has_Aspects (Parent (Node)) then
2710 Sprint_Aspect_Specifications
2711 (Parent (Node), Semicolon => False);
2712 end if;
2713 end if;
2714 end;
2715 end if;
2717 Write_Str (" is");
2718 Sprint_Indented_List (Visible_Declarations (Node));
2720 if Present (Private_Declarations (Node)) then
2721 Write_Indent_Str ("private");
2722 Sprint_Indented_List (Private_Declarations (Node));
2723 end if;
2725 Write_Indent_Str ("end ");
2726 Sprint_Node (Defining_Unit_Name (Node));
2728 when N_Parameter_Association =>
2729 Sprint_Node_Sloc (Selector_Name (Node));
2730 Write_Str (" => ");
2731 Sprint_Node (Explicit_Actual_Parameter (Node));
2733 when N_Parameter_Specification =>
2734 Set_Debug_Sloc;
2736 if Write_Identifiers (Node) then
2737 Write_Str (" : ");
2739 if In_Present (Node) then
2740 Write_Str_With_Col_Check ("in ");
2741 end if;
2743 if Out_Present (Node) then
2744 Write_Str_With_Col_Check ("out ");
2745 end if;
2747 -- Ada 2005 (AI-231): Parameter specification may carry null
2748 -- exclusion. Do not print it now if this is an access formal,
2749 -- it is emitted when the access definition is displayed.
2751 if Null_Exclusion_Present (Node)
2752 and then Nkind (Parameter_Type (Node)) /= N_Access_Definition
2753 then
2754 Write_Str ("not null ");
2755 end if;
2757 if Aliased_Present (Node) then
2758 Write_Str ("aliased ");
2759 end if;
2761 Sprint_Node (Parameter_Type (Node));
2763 if Present (Expression (Node)) then
2764 Write_Str (" := ");
2765 Sprint_Node (Expression (Node));
2766 end if;
2767 else
2768 Write_Str (", ");
2769 end if;
2771 when N_Pop_Constraint_Error_Label =>
2772 Write_Indent_Str ("%pop_constraint_error_label");
2774 when N_Pop_Program_Error_Label =>
2775 Write_Indent_Str ("%pop_program_error_label");
2777 when N_Pop_Storage_Error_Label =>
2778 Write_Indent_Str ("%pop_storage_error_label");
2780 when N_Private_Extension_Declaration =>
2781 Write_Indent_Str_Sloc ("type ");
2782 Write_Id (Defining_Identifier (Node));
2784 if Present (Discriminant_Specifications (Node)) then
2785 Write_Discr_Specs (Node);
2786 elsif Unknown_Discriminants_Present (Node) then
2787 Write_Str_With_Col_Check ("(<>)");
2788 end if;
2790 Write_Str_With_Col_Check (" is new ");
2791 Sprint_Node (Subtype_Indication (Node));
2793 if Present (Interface_List (Node)) then
2794 Write_Str_With_Col_Check (" and ");
2795 Sprint_And_List (Interface_List (Node));
2796 end if;
2798 Write_Str_With_Col_Check (" with private;");
2800 when N_Private_Type_Declaration =>
2801 Write_Indent_Str_Sloc ("type ");
2802 Write_Id (Defining_Identifier (Node));
2804 if Present (Discriminant_Specifications (Node)) then
2805 Write_Discr_Specs (Node);
2806 elsif Unknown_Discriminants_Present (Node) then
2807 Write_Str_With_Col_Check ("(<>)");
2808 end if;
2810 Write_Str (" is ");
2812 if Tagged_Present (Node) then
2813 Write_Str_With_Col_Check ("tagged ");
2814 end if;
2816 if Limited_Present (Node) then
2817 Write_Str_With_Col_Check ("limited ");
2818 end if;
2820 Write_Str_With_Col_Check ("private;");
2822 when N_Push_Constraint_Error_Label =>
2823 Write_Indent_Str ("%push_constraint_error_label (");
2825 if Present (Exception_Label (Node)) then
2826 Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2827 end if;
2829 Write_Str (")");
2831 when N_Push_Program_Error_Label =>
2832 Write_Indent_Str ("%push_program_error_label (");
2834 if Present (Exception_Label (Node)) then
2835 Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2836 end if;
2838 Write_Str (")");
2840 when N_Push_Storage_Error_Label =>
2841 Write_Indent_Str ("%push_storage_error_label (");
2843 if Present (Exception_Label (Node)) then
2844 Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
2845 end if;
2847 Write_Str (")");
2849 when N_Pragma =>
2850 Write_Indent_Str_Sloc ("pragma ");
2851 Write_Name_With_Col_Check (Pragma_Name_Unmapped (Node));
2853 if Present (Pragma_Argument_Associations (Node)) then
2854 Sprint_Opt_Paren_Comma_List
2855 (Pragma_Argument_Associations (Node));
2856 end if;
2858 Write_Char (';');
2860 when N_Pragma_Argument_Association =>
2861 Set_Debug_Sloc;
2863 if Chars (Node) /= No_Name then
2864 Write_Name_With_Col_Check (Chars (Node));
2865 Write_Str (" => ");
2866 end if;
2868 Sprint_Node (Expression (Node));
2870 when N_Procedure_Call_Statement =>
2871 Write_Indent;
2872 Set_Debug_Sloc;
2873 Write_Subprogram_Name (Name (Node));
2874 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
2875 Write_Char (';');
2877 when N_Procedure_Instantiation =>
2878 Write_Indent_Str_Sloc ("procedure ");
2879 Sprint_Node (Defining_Unit_Name (Node));
2880 Write_Str_With_Col_Check (" is new ");
2881 Sprint_Node (Name (Node));
2882 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
2883 Write_Char (';');
2885 when N_Procedure_Specification =>
2886 Write_Str_With_Col_Check_Sloc ("procedure ");
2887 Sprint_Node (Defining_Unit_Name (Node));
2888 Write_Param_Specs (Node);
2890 when N_Protected_Body =>
2891 Write_Indent_Str_Sloc ("protected body ");
2892 Write_Id (Defining_Identifier (Node));
2893 Write_Str (" is");
2894 Sprint_Indented_List (Declarations (Node));
2895 Write_Indent_Str ("end ");
2896 Write_Id (Defining_Identifier (Node));
2897 Write_Char (';');
2899 when N_Protected_Body_Stub =>
2900 Write_Indent_Str_Sloc ("protected body ");
2901 Write_Id (Defining_Identifier (Node));
2902 Write_Str_With_Col_Check (" is separate;");
2904 when N_Protected_Definition =>
2905 Set_Debug_Sloc;
2906 Sprint_Indented_List (Visible_Declarations (Node));
2908 if Present (Private_Declarations (Node)) then
2909 Write_Indent_Str ("private");
2910 Sprint_Indented_List (Private_Declarations (Node));
2911 end if;
2913 Write_Indent_Str ("end ");
2915 when N_Protected_Type_Declaration =>
2916 Write_Indent_Str_Sloc ("protected type ");
2917 Sprint_Node (Defining_Identifier (Node));
2918 Write_Discr_Specs (Node);
2920 if Present (Interface_List (Node)) then
2921 Write_Str (" is new ");
2922 Sprint_And_List (Interface_List (Node));
2923 Write_Str (" with ");
2924 else
2925 Write_Str (" is");
2926 end if;
2928 Sprint_Node (Protected_Definition (Node));
2929 Write_Id (Defining_Identifier (Node));
2930 Write_Char (';');
2932 when N_Qualified_Expression =>
2933 Sprint_Node (Subtype_Mark (Node));
2934 Write_Char_Sloc (''');
2936 -- Print expression, make sure we have at least one level of
2937 -- parentheses around the expression. For cases of qualified
2938 -- expressions in the source, this is always the case, but
2939 -- for generated qualifications, there may be no explicit
2940 -- parentheses present.
2942 if Paren_Count (Expression (Node)) /= 0 then
2943 Sprint_Node (Expression (Node));
2945 else
2946 Write_Char ('(');
2947 Sprint_Node (Expression (Node));
2949 -- Odd case, for the qualified expressions used in machine
2950 -- code the argument may be a procedure call, resulting in
2951 -- a junk semicolon before the right parent, get rid of it.
2953 Write_Erase_Char (';');
2955 -- Now we can add the terminating right paren
2957 Write_Char (')');
2958 end if;
2960 when N_Quantified_Expression =>
2961 Write_Str (" for");
2963 if All_Present (Node) then
2964 Write_Str (" all ");
2965 else
2966 Write_Str (" some ");
2967 end if;
2969 if Present (Iterator_Specification (Node)) then
2970 Sprint_Node (Iterator_Specification (Node));
2971 else
2972 Sprint_Node (Loop_Parameter_Specification (Node));
2973 end if;
2975 Write_Str (" => ");
2976 Sprint_Node (Condition (Node));
2978 when N_Raise_Expression =>
2979 declare
2980 Has_Parens : constant Boolean := Paren_Count (Node) > 0;
2982 begin
2983 -- The syntax for raise_expression does not include parentheses
2984 -- but sometimes parentheses are required, so unconditionally
2985 -- generate them here unless already present.
2987 if not Has_Parens then
2988 Write_Char ('(');
2989 end if;
2991 Write_Str_With_Col_Check_Sloc ("raise ");
2992 Sprint_Node (Name (Node));
2994 if Present (Expression (Node)) then
2995 Write_Str_With_Col_Check (" with ");
2996 Sprint_Node (Expression (Node));
2997 end if;
2999 if not Has_Parens then
3000 Write_Char (')');
3001 end if;
3002 end;
3004 when N_Raise_Constraint_Error =>
3006 -- This node can be used either as a subexpression or as a
3007 -- statement form. The following test is a reasonably reliable
3008 -- way to distinguish the two cases.
3010 if Is_List_Member (Node)
3011 and then Nkind (Parent (Node)) not in N_Subexpr
3012 then
3013 Write_Indent;
3014 end if;
3016 Write_Str_With_Col_Check_Sloc ("[constraint_error");
3017 Write_Condition_And_Reason (Node);
3019 when N_Raise_Program_Error =>
3021 -- This node can be used either as a subexpression or as a
3022 -- statement form. The following test is a reasonably reliable
3023 -- way to distinguish the two cases.
3025 if Is_List_Member (Node)
3026 and then Nkind (Parent (Node)) not in N_Subexpr
3027 then
3028 Write_Indent;
3029 end if;
3031 Write_Str_With_Col_Check_Sloc ("[program_error");
3032 Write_Condition_And_Reason (Node);
3034 when N_Raise_Storage_Error =>
3036 -- This node can be used either as a subexpression or as a
3037 -- statement form. The following test is a reasonably reliable
3038 -- way to distinguish the two cases.
3040 if Is_List_Member (Node)
3041 and then Nkind (Parent (Node)) not in N_Subexpr
3042 then
3043 Write_Indent;
3044 end if;
3046 Write_Str_With_Col_Check_Sloc ("[storage_error");
3047 Write_Condition_And_Reason (Node);
3049 when N_Raise_Statement =>
3050 Write_Indent_Str_Sloc ("raise ");
3051 Sprint_Node (Name (Node));
3053 if Present (Expression (Node)) then
3054 Write_Str_With_Col_Check_Sloc (" with ");
3055 Sprint_Node (Expression (Node));
3056 end if;
3058 Write_Char (';');
3060 when N_Range =>
3061 Sprint_Node (Low_Bound (Node));
3062 Write_Str_Sloc (" .. ");
3063 Sprint_Node (High_Bound (Node));
3064 Update_Itype (Node);
3066 when N_Range_Constraint =>
3067 Write_Str_With_Col_Check_Sloc ("range ");
3068 Sprint_Node (Range_Expression (Node));
3070 when N_Real_Literal =>
3071 Write_Ureal_With_Col_Check_Sloc (Realval (Node));
3073 when N_Real_Range_Specification =>
3074 Write_Str_With_Col_Check_Sloc ("range ");
3075 Sprint_Node (Low_Bound (Node));
3076 Write_Str (" .. ");
3077 Sprint_Node (High_Bound (Node));
3079 when N_Record_Definition =>
3080 if Abstract_Present (Node) then
3081 Write_Str_With_Col_Check ("abstract ");
3082 end if;
3084 if Tagged_Present (Node) then
3085 Write_Str_With_Col_Check ("tagged ");
3086 end if;
3088 if Limited_Present (Node) then
3089 Write_Str_With_Col_Check ("limited ");
3090 end if;
3092 if Null_Present (Node) then
3093 Write_Str_With_Col_Check_Sloc ("null record");
3095 else
3096 Write_Str_With_Col_Check_Sloc ("record");
3097 Sprint_Node (Component_List (Node));
3098 Write_Indent_Str ("end record");
3099 end if;
3101 when N_Record_Representation_Clause =>
3102 Write_Indent_Str_Sloc ("for ");
3103 Sprint_Node (Identifier (Node));
3104 Write_Str_With_Col_Check (" use record ");
3106 if Present (Mod_Clause (Node)) then
3107 Sprint_Node (Mod_Clause (Node));
3108 end if;
3110 Sprint_Indented_List (Component_Clauses (Node));
3111 Write_Indent_Str ("end record;");
3113 when N_Reduction_Expression =>
3114 Write_Str (" for");
3116 if Present (Iterator_Specification (Node)) then
3117 Sprint_Node (Iterator_Specification (Node));
3118 else
3119 Sprint_Node (Loop_Parameter_Specification (Node));
3120 end if;
3122 Write_Str (" => ");
3123 Sprint_Node (Expression (Node));
3124 null;
3126 when N_Reduction_Expression_Parameter =>
3127 Write_Char ('<');
3129 if Present (Expression (Node)) then
3130 Sprint_Node (Expression (Node));
3131 end if;
3133 Write_Char ('>');
3135 when N_Reference =>
3136 Sprint_Node (Prefix (Node));
3137 Write_Str_With_Col_Check_Sloc ("'reference");
3139 when N_Requeue_Statement =>
3140 Write_Indent_Str_Sloc ("requeue ");
3141 Sprint_Node (Name (Node));
3143 if Abort_Present (Node) then
3144 Write_Str_With_Col_Check (" with abort");
3145 end if;
3147 Write_Char (';');
3149 -- Don't we want to print more detail???
3151 -- Doc of this extended syntax belongs in sinfo.ads and/or
3152 -- sprint.ads ???
3154 when N_SCIL_Dispatch_Table_Tag_Init =>
3155 Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
3157 when N_SCIL_Dispatching_Call =>
3158 Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
3160 when N_SCIL_Membership_Test =>
3161 Write_Indent_Str ("[N_SCIL_Membership_Test]");
3163 when N_Simple_Return_Statement =>
3164 if Present (Expression (Node)) then
3165 Write_Indent_Str_Sloc ("return ");
3166 Sprint_Node (Expression (Node));
3167 Write_Char (';');
3168 else
3169 Write_Indent_Str_Sloc ("return;");
3170 end if;
3172 when N_Selective_Accept =>
3173 Write_Indent_Str_Sloc ("select");
3175 declare
3176 Alt_Node : Node_Id;
3177 begin
3178 Alt_Node := First (Select_Alternatives (Node));
3179 loop
3180 Indent_Begin;
3181 Sprint_Node (Alt_Node);
3182 Indent_End;
3183 Next (Alt_Node);
3184 exit when No (Alt_Node);
3185 Write_Indent_Str ("or");
3186 end loop;
3187 end;
3189 if Present (Else_Statements (Node)) then
3190 Write_Indent_Str ("else");
3191 Sprint_Indented_List (Else_Statements (Node));
3192 end if;
3194 Write_Indent_Str ("end select;");
3196 when N_Signed_Integer_Type_Definition =>
3197 Write_Str_With_Col_Check_Sloc ("range ");
3198 Sprint_Node (Low_Bound (Node));
3199 Write_Str (" .. ");
3200 Sprint_Node (High_Bound (Node));
3202 when N_Single_Protected_Declaration =>
3203 Write_Indent_Str_Sloc ("protected ");
3204 Write_Id (Defining_Identifier (Node));
3205 Write_Str (" is");
3206 Sprint_Node (Protected_Definition (Node));
3207 Write_Id (Defining_Identifier (Node));
3208 Write_Char (';');
3210 when N_Single_Task_Declaration =>
3211 Write_Indent_Str_Sloc ("task ");
3212 Sprint_Node (Defining_Identifier (Node));
3214 if Present (Task_Definition (Node)) then
3215 Write_Str (" is");
3216 Sprint_Node (Task_Definition (Node));
3217 end if;
3219 Write_Char (';');
3221 when N_Selected_Component =>
3222 Sprint_Node (Prefix (Node));
3223 Write_Char_Sloc ('.');
3224 Sprint_Node (Selector_Name (Node));
3226 when N_Slice =>
3227 Set_Debug_Sloc;
3228 Sprint_Node (Prefix (Node));
3229 Write_Str_With_Col_Check (" (");
3230 Sprint_Node (Discrete_Range (Node));
3231 Write_Char (')');
3233 when N_String_Literal =>
3234 if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then
3235 Write_Indent_Str (" ");
3236 end if;
3238 Set_Debug_Sloc;
3239 Write_String_Table_Entry (Strval (Node));
3241 when N_Subprogram_Body =>
3243 -- Output extra blank line unless we are in freeze actions
3245 if Freeze_Indent = 0 then
3246 Extra_Blank_Line;
3247 end if;
3249 Write_Indent;
3251 if Present (Corresponding_Spec (Node)) then
3252 Sprint_Node_Sloc (Parent (Corresponding_Spec (Node)));
3253 else
3254 Sprint_Node_Sloc (Specification (Node));
3255 end if;
3257 Write_Str (" is");
3259 Sprint_Indented_List (Declarations (Node));
3260 Write_Indent_Str ("begin");
3261 Sprint_Node (Handled_Statement_Sequence (Node));
3263 Write_Indent_Str ("end ");
3265 Sprint_End_Label
3266 (Handled_Statement_Sequence (Node),
3267 Defining_Unit_Name (Specification (Node)));
3268 Write_Char (';');
3270 if Is_List_Member (Node)
3271 and then Present (Next (Node))
3272 and then Nkind (Next (Node)) /= N_Subprogram_Body
3273 then
3274 Write_Indent;
3275 end if;
3277 when N_Subprogram_Body_Stub =>
3278 Write_Indent;
3279 Sprint_Node_Sloc (Specification (Node));
3280 Write_Str_With_Col_Check (" is separate;");
3282 when N_Subprogram_Declaration =>
3283 Write_Indent;
3284 Sprint_Node_Sloc (Specification (Node));
3286 if Nkind (Specification (Node)) = N_Procedure_Specification
3287 and then Null_Present (Specification (Node))
3288 then
3289 Write_Str_With_Col_Check (" is null");
3290 end if;
3292 Write_Char (';');
3294 when N_Subprogram_Renaming_Declaration =>
3295 Write_Indent;
3296 Sprint_Node (Specification (Node));
3297 Write_Str_With_Col_Check_Sloc (" renames ");
3298 Sprint_Node (Name (Node));
3299 Write_Char (';');
3301 when N_Subtype_Declaration =>
3302 Write_Indent_Str_Sloc ("subtype ");
3303 Sprint_Node (Defining_Identifier (Node));
3304 Write_Str (" is ");
3306 -- Ada 2005 (AI-231)
3308 if Null_Exclusion_Present (Node) then
3309 Write_Str ("not null ");
3310 end if;
3312 Sprint_Node (Subtype_Indication (Node));
3313 Write_Char (';');
3315 when N_Subtype_Indication =>
3316 Sprint_Node_Sloc (Subtype_Mark (Node));
3317 Write_Char (' ');
3318 Sprint_Node (Constraint (Node));
3320 when N_Subunit =>
3321 Write_Indent_Str_Sloc ("separate (");
3322 Sprint_Node (Name (Node));
3323 Write_Char (')');
3324 Extra_Blank_Line;
3325 Sprint_Node (Proper_Body (Node));
3327 when N_Target_Name =>
3328 Write_Char ('@');
3330 when N_Task_Body =>
3331 Write_Indent_Str_Sloc ("task body ");
3332 Write_Id (Defining_Identifier (Node));
3333 Write_Str (" is");
3334 Sprint_Indented_List (Declarations (Node));
3335 Write_Indent_Str ("begin");
3336 Sprint_Node (Handled_Statement_Sequence (Node));
3337 Write_Indent_Str ("end ");
3338 Sprint_End_Label
3339 (Handled_Statement_Sequence (Node), Defining_Identifier (Node));
3340 Write_Char (';');
3342 when N_Task_Body_Stub =>
3343 Write_Indent_Str_Sloc ("task body ");
3344 Write_Id (Defining_Identifier (Node));
3345 Write_Str_With_Col_Check (" is separate;");
3347 when N_Task_Definition =>
3348 Set_Debug_Sloc;
3349 Sprint_Indented_List (Visible_Declarations (Node));
3351 if Present (Private_Declarations (Node)) then
3352 Write_Indent_Str ("private");
3353 Sprint_Indented_List (Private_Declarations (Node));
3354 end if;
3356 Write_Indent_Str ("end ");
3357 Sprint_End_Label (Node, Defining_Identifier (Parent (Node)));
3359 when N_Task_Type_Declaration =>
3360 Write_Indent_Str_Sloc ("task type ");
3361 Sprint_Node (Defining_Identifier (Node));
3362 Write_Discr_Specs (Node);
3364 if Present (Interface_List (Node)) then
3365 Write_Str (" is new ");
3366 Sprint_And_List (Interface_List (Node));
3367 end if;
3369 if Present (Task_Definition (Node)) then
3370 if No (Interface_List (Node)) then
3371 Write_Str (" is");
3372 else
3373 Write_Str (" with ");
3374 end if;
3376 Sprint_Node (Task_Definition (Node));
3377 end if;
3379 Write_Char (';');
3381 when N_Terminate_Alternative =>
3382 Sprint_Node_List (Pragmas_Before (Node));
3383 Write_Indent;
3385 if Present (Condition (Node)) then
3386 Write_Str_With_Col_Check ("when ");
3387 Sprint_Node (Condition (Node));
3388 Write_Str (" => ");
3389 end if;
3391 Write_Str_With_Col_Check_Sloc ("terminate;");
3392 Sprint_Node_List (Pragmas_After (Node));
3394 when N_Timed_Entry_Call =>
3395 Write_Indent_Str_Sloc ("select");
3396 Indent_Begin;
3397 Sprint_Node (Entry_Call_Alternative (Node));
3398 Indent_End;
3399 Write_Indent_Str ("or");
3400 Indent_Begin;
3401 Sprint_Node (Delay_Alternative (Node));
3402 Indent_End;
3403 Write_Indent_Str ("end select;");
3405 when N_Triggering_Alternative =>
3406 Sprint_Node_List (Pragmas_Before (Node));
3407 Sprint_Node_Sloc (Triggering_Statement (Node));
3408 Sprint_Node_List (Statements (Node));
3410 when N_Type_Conversion =>
3411 Set_Debug_Sloc;
3412 Sprint_Node (Subtype_Mark (Node));
3413 Col_Check (4);
3415 if Conversion_OK (Node) then
3416 Write_Char ('?');
3417 end if;
3419 if Float_Truncate (Node) then
3420 Write_Char ('^');
3421 end if;
3423 if Rounded_Result (Node) then
3424 Write_Char ('@');
3425 end if;
3427 Write_Char ('(');
3428 Sprint_Node (Expression (Node));
3429 Write_Char (')');
3431 when N_Unchecked_Expression =>
3432 Col_Check (10);
3433 Write_Str ("`(");
3434 Sprint_Node_Sloc (Expression (Node));
3435 Write_Char (')');
3437 when N_Unchecked_Type_Conversion =>
3438 Sprint_Node (Subtype_Mark (Node));
3439 Write_Char ('!');
3440 Write_Str_With_Col_Check ("(");
3441 Sprint_Node_Sloc (Expression (Node));
3442 Write_Char (')');
3444 when N_Unconstrained_Array_Definition =>
3445 Write_Str_With_Col_Check_Sloc ("array (");
3447 declare
3448 Node1 : Node_Id;
3449 begin
3450 Node1 := First (Subtype_Marks (Node));
3451 loop
3452 Sprint_Node (Node1);
3453 Write_Str_With_Col_Check (" range <>");
3454 Next (Node1);
3455 exit when Node1 = Empty;
3456 Write_Str (", ");
3457 end loop;
3458 end;
3460 Write_Str (") of ");
3461 Sprint_Node (Component_Definition (Node));
3463 when N_Unused_At_Start | N_Unused_At_End =>
3464 Write_Indent_Str ("***** Error, unused node encountered *****");
3465 Write_Eol;
3467 when N_Use_Package_Clause =>
3468 Write_Indent_Str_Sloc ("use ");
3469 Sprint_Node_Sloc (Name (Node));
3470 Write_Char (';');
3472 when N_Use_Type_Clause =>
3473 Write_Indent_Str_Sloc ("use type ");
3474 Sprint_Node_Sloc (Subtype_Mark (Node));
3475 Write_Char (';');
3477 when N_Validate_Unchecked_Conversion =>
3478 Write_Indent_Str_Sloc ("validate unchecked_conversion (");
3479 Sprint_Node (Source_Type (Node));
3480 Write_Str (", ");
3481 Sprint_Node (Target_Type (Node));
3482 Write_Str (");");
3484 when N_Variable_Reference_Marker =>
3485 null;
3487 -- Enable the following code for debugging purposes only
3489 -- if Is_Read (Node) and then Is_Write (Node) then
3490 -- Write_Indent_Str ("rw#");
3492 -- elsif Is_Read (Node) then
3493 -- Write_Indent_Str ("r#");
3495 -- else
3496 -- pragma Assert (Is_Write (Node));
3497 -- Write_Indent_Str ("w#");
3498 -- end if;
3500 -- Write_Id (Target (Node));
3501 -- Write_Char ('#');
3503 when N_Variant =>
3504 Write_Indent_Str_Sloc ("when ");
3505 Sprint_Bar_List (Discrete_Choices (Node));
3506 Write_Str (" => ");
3507 Sprint_Node (Component_List (Node));
3509 when N_Variant_Part =>
3510 Indent_Begin;
3511 Write_Indent_Str_Sloc ("case ");
3512 Sprint_Node (Name (Node));
3513 Write_Str (" is ");
3514 Sprint_Indented_List (Variants (Node));
3515 Write_Indent_Str ("end case");
3516 Indent_End;
3518 when N_With_Clause =>
3520 -- Special test, if we are dumping the original tree only,
3521 -- then we want to eliminate the bogus with clauses that
3522 -- correspond to the non-existent children of Text_IO.
3524 if Dump_Original_Only
3525 and then Is_Text_IO_Special_Unit (Name (Node))
3526 then
3527 null;
3529 -- Normal case, output the with clause
3531 else
3532 if First_Name (Node) or else not Dump_Original_Only then
3534 -- Ada 2005 (AI-50217): Print limited with_clauses
3536 if Private_Present (Node) and Limited_Present (Node) then
3537 Write_Indent_Str ("limited private with ");
3539 elsif Private_Present (Node) then
3540 Write_Indent_Str ("private with ");
3542 elsif Limited_Present (Node) then
3543 Write_Indent_Str ("limited with ");
3545 else
3546 Write_Indent_Str ("with ");
3547 end if;
3549 else
3550 Write_Str (", ");
3551 end if;
3553 Sprint_Node_Sloc (Name (Node));
3555 if Last_Name (Node) or else not Dump_Original_Only then
3556 Write_Char (';');
3557 end if;
3558 end if;
3559 end case;
3561 -- Print aspects, except for special case of package declaration,
3562 -- where the aspects are printed inside the package specification.
3564 if Has_Aspects (Node)
3565 and then not Nkind_In (Node, N_Package_Declaration,
3566 N_Generic_Package_Declaration)
3567 then
3568 Sprint_Aspect_Specifications (Node, Semicolon => True);
3569 end if;
3571 if Nkind (Node) in N_Subexpr
3572 and then Do_Range_Check (Node)
3573 then
3574 Write_Str ("}");
3575 end if;
3577 for J in 1 .. Paren_Count (Node) loop
3578 Write_Char (')');
3579 end loop;
3581 Dump_Node := Save_Dump_Node;
3582 end Sprint_Node_Actual;
3584 ----------------------
3585 -- Sprint_Node_List --
3586 ----------------------
3588 procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is
3589 Node : Node_Id;
3591 begin
3592 if Is_Non_Empty_List (List) then
3593 Node := First (List);
3595 loop
3596 Sprint_Node (Node);
3597 Next (Node);
3598 exit when Node = Empty;
3599 end loop;
3600 end if;
3602 if New_Lines and then Column /= 1 then
3603 Write_Eol;
3604 end if;
3605 end Sprint_Node_List;
3607 ----------------------
3608 -- Sprint_Node_Sloc --
3609 ----------------------
3611 procedure Sprint_Node_Sloc (Node : Node_Id) is
3612 begin
3613 Sprint_Node (Node);
3615 if Debug_Generated_Code and then Present (Dump_Node) then
3616 Set_Sloc (Dump_Node, Sloc (Node));
3617 Dump_Node := Empty;
3618 end if;
3619 end Sprint_Node_Sloc;
3621 ---------------------
3622 -- Sprint_Opt_Node --
3623 ---------------------
3625 procedure Sprint_Opt_Node (Node : Node_Id) is
3626 begin
3627 if Present (Node) then
3628 Write_Char (' ');
3629 Sprint_Node (Node);
3630 end if;
3631 end Sprint_Opt_Node;
3633 --------------------------
3634 -- Sprint_Opt_Node_List --
3635 --------------------------
3637 procedure Sprint_Opt_Node_List (List : List_Id) is
3638 begin
3639 if Present (List) then
3640 Sprint_Node_List (List);
3641 end if;
3642 end Sprint_Opt_Node_List;
3644 ---------------------------------
3645 -- Sprint_Opt_Paren_Comma_List --
3646 ---------------------------------
3648 procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
3649 begin
3650 if Is_Non_Empty_List (List) then
3651 Write_Char (' ');
3652 Sprint_Paren_Comma_List (List);
3653 end if;
3654 end Sprint_Opt_Paren_Comma_List;
3656 -----------------------------
3657 -- Sprint_Paren_Comma_List --
3658 -----------------------------
3660 procedure Sprint_Paren_Comma_List (List : List_Id) is
3661 N : Node_Id;
3662 Node_Exists : Boolean := False;
3664 begin
3666 if Is_Non_Empty_List (List) then
3668 if Dump_Original_Only then
3669 N := First (List);
3670 while Present (N) loop
3671 if not Is_Rewrite_Insertion (N) then
3672 Node_Exists := True;
3673 exit;
3674 end if;
3676 Next (N);
3677 end loop;
3679 if not Node_Exists then
3680 return;
3681 end if;
3682 end if;
3684 Write_Str_With_Col_Check ("(");
3685 Sprint_Comma_List (List);
3686 Write_Char (')');
3687 end if;
3688 end Sprint_Paren_Comma_List;
3690 ----------------------
3691 -- Sprint_Right_Opnd --
3692 ----------------------
3694 procedure Sprint_Right_Opnd (N : Node_Id) is
3695 Opnd : constant Node_Id := Right_Opnd (N);
3697 begin
3698 if Paren_Count (Opnd) /= 0
3699 or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N))
3700 then
3701 Sprint_Node (Opnd);
3703 else
3704 Write_Char ('(');
3705 Sprint_Node (Opnd);
3706 Write_Char (')');
3707 end if;
3708 end Sprint_Right_Opnd;
3710 ------------------
3711 -- Update_Itype --
3712 ------------------
3714 procedure Update_Itype (Node : Node_Id) is
3715 begin
3716 if Present (Etype (Node))
3717 and then Is_Itype (Etype (Node))
3718 and then Debug_Generated_Code
3719 then
3720 Set_Sloc (Etype (Node), Sloc (Node));
3721 end if;
3722 end Update_Itype;
3724 ---------------------
3725 -- Write_Char_Sloc --
3726 ---------------------
3728 procedure Write_Char_Sloc (C : Character) is
3729 begin
3730 if Debug_Generated_Code and then C /= ' ' then
3731 Set_Debug_Sloc;
3732 end if;
3734 Write_Char (C);
3735 end Write_Char_Sloc;
3737 --------------------------------
3738 -- Write_Condition_And_Reason --
3739 --------------------------------
3741 procedure Write_Condition_And_Reason (Node : Node_Id) is
3742 Cond : constant Node_Id := Condition (Node);
3743 Image : constant String := RT_Exception_Code'Image
3744 (RT_Exception_Code'Val
3745 (UI_To_Int (Reason (Node))));
3747 begin
3748 if Present (Cond) then
3750 -- If condition is a single entity, or NOT with a single entity,
3751 -- output all on one line, since it will likely fit just fine.
3753 if Is_Entity_Name (Cond)
3754 or else (Nkind (Cond) = N_Op_Not
3755 and then Is_Entity_Name (Right_Opnd (Cond)))
3756 then
3757 Write_Str_With_Col_Check (" when ");
3758 Sprint_Node (Cond);
3759 Write_Char (' ');
3761 -- Otherwise for more complex condition, multiple lines
3763 else
3764 Write_Str_With_Col_Check (" when");
3765 Indent := Indent + 2;
3766 Write_Indent;
3767 Sprint_Node (Cond);
3768 Write_Indent;
3769 Indent := Indent - 2;
3770 end if;
3772 -- If no condition, just need a space (all on one line)
3774 else
3775 Write_Char (' ');
3776 end if;
3778 -- Write the reason
3780 Write_Char ('"');
3782 for J in 4 .. Image'Last loop
3783 if Image (J) = '_' then
3784 Write_Char (' ');
3785 else
3786 Write_Char (Fold_Lower (Image (J)));
3787 end if;
3788 end loop;
3790 Write_Str ("""]");
3791 end Write_Condition_And_Reason;
3793 --------------------------------
3794 -- Write_Corresponding_Source --
3795 --------------------------------
3797 procedure Write_Corresponding_Source (S : String) is
3798 Loc : Source_Ptr;
3799 Src : Source_Buffer_Ptr;
3801 begin
3802 -- Ignore if there is no current source file, or we're not in dump
3803 -- source text mode, or if in freeze actions.
3805 if Current_Source_File > No_Source_File
3806 and then Dump_Source_Text
3807 and then Freeze_Indent = 0
3808 then
3810 -- Ignore null string
3812 if S = "" then
3813 return;
3814 end if;
3816 -- Ignore space or semicolon at end of given string
3818 if S (S'Last) = ' ' or else S (S'Last) = ';' then
3819 Write_Corresponding_Source (S (S'First .. S'Last - 1));
3820 return;
3821 end if;
3823 -- Loop to look at next lines not yet printed in source file
3825 for L in
3826 Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File)
3827 loop
3828 Src := Source_Text (Current_Source_File);
3829 Loc := Line_Start (L, Current_Source_File);
3831 -- If comment, keep looking
3833 if Src (Loc .. Loc + 1) = "--" then
3834 null;
3836 -- Search to first non-blank
3838 else
3839 while Src (Loc) not in Line_Terminator loop
3841 -- Non-blank found
3843 if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then
3845 -- Loop through characters in string to see if we match
3847 for J in S'Range loop
3849 -- If mismatch, then not the case we are looking for
3851 if Src (Loc) /= S (J) then
3852 return;
3853 end if;
3855 Loc := Loc + 1;
3856 end loop;
3858 -- If we fall through, string matched, if white space or
3859 -- semicolon after the matched string, this is the case
3860 -- we are looking for.
3862 if Src (Loc) in Line_Terminator
3863 or else Src (Loc) = ' '
3864 or else Src (Loc) = ASCII.HT
3865 or else Src (Loc) = ';'
3866 then
3867 -- So output source lines up to and including this one
3869 Write_Source_Lines (L);
3870 return;
3871 end if;
3872 end if;
3874 Loc := Loc + 1;
3875 end loop;
3876 end if;
3878 -- Line was all blanks, or a comment line, keep looking
3880 end loop;
3881 end if;
3882 end Write_Corresponding_Source;
3884 -----------------------
3885 -- Write_Discr_Specs --
3886 -----------------------
3888 procedure Write_Discr_Specs (N : Node_Id) is
3889 Specs : List_Id;
3890 Spec : Node_Id;
3892 begin
3893 Specs := Discriminant_Specifications (N);
3895 if Present (Specs) then
3896 Write_Str_With_Col_Check (" (");
3897 Spec := First (Specs);
3899 loop
3900 Sprint_Node (Spec);
3901 Next (Spec);
3902 exit when Spec = Empty;
3904 -- Add semicolon, unless we are printing original tree and the
3905 -- next specification is part of a list (but not the first
3906 -- element of that list)
3908 if not Dump_Original_Only or else not Prev_Ids (Spec) then
3909 Write_Str ("; ");
3910 end if;
3911 end loop;
3913 Write_Char (')');
3914 end if;
3915 end Write_Discr_Specs;
3917 -----------------
3918 -- Write_Ekind --
3919 -----------------
3921 procedure Write_Ekind (E : Entity_Id) is
3922 S : constant String := Entity_Kind'Image (Ekind (E));
3924 begin
3925 Name_Len := S'Length;
3926 Name_Buffer (1 .. Name_Len) := S;
3927 Set_Casing (Mixed_Case);
3928 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3929 end Write_Ekind;
3931 --------------
3932 -- Write_Id --
3933 --------------
3935 procedure Write_Id (N : Node_Id) is
3936 begin
3937 -- Deal with outputting Itype
3939 -- Note: if we are printing the full tree with -gnatds, then we may
3940 -- end up picking up the Associated_Node link from a generic template
3941 -- here which overlaps the Entity field, but as documented, Write_Itype
3942 -- is defended against junk calls.
3944 if Nkind (N) in N_Entity then
3945 Write_Itype (N);
3946 elsif Nkind (N) in N_Has_Entity then
3947 Write_Itype (Entity (N));
3948 end if;
3950 -- Case of a defining identifier
3952 if Nkind (N) = N_Defining_Identifier then
3954 -- If defining identifier has an interface name (and no
3955 -- address clause), then we output the interface name.
3957 if (Is_Imported (N) or else Is_Exported (N))
3958 and then Present (Interface_Name (N))
3959 and then No (Address_Clause (N))
3960 then
3961 String_To_Name_Buffer (Strval (Interface_Name (N)));
3962 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
3964 -- If no interface name (or inactive because there was
3965 -- an address clause), then just output the Chars name.
3967 else
3968 Write_Name_With_Col_Check (Chars (N));
3969 end if;
3971 -- Case of selector of an expanded name where the expanded name
3972 -- has an associated entity, output this entity. Check that the
3973 -- entity or associated node is of the right kind, see above.
3975 elsif Nkind (Parent (N)) = N_Expanded_Name
3976 and then Selector_Name (Parent (N)) = N
3977 and then Present (Entity_Or_Associated_Node (Parent (N)))
3978 and then Nkind (Entity (Parent (N))) in N_Entity
3979 then
3980 Write_Id (Entity (Parent (N)));
3982 -- For any other node with an associated entity, output it
3984 elsif Nkind (N) in N_Has_Entity
3985 and then Present (Entity_Or_Associated_Node (N))
3986 and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
3987 then
3988 Write_Id (Entity (N));
3990 -- All other cases, we just print the Chars field
3992 else
3993 Write_Name_With_Col_Check (Chars (N));
3994 end if;
3995 end Write_Id;
3997 -----------------------
3998 -- Write_Identifiers --
3999 -----------------------
4001 function Write_Identifiers (Node : Node_Id) return Boolean is
4002 begin
4003 Sprint_Node (Defining_Identifier (Node));
4004 Update_Itype (Defining_Identifier (Node));
4006 -- The remainder of the declaration must be printed unless we are
4007 -- printing the original tree and this is not the last identifier
4009 return
4010 not Dump_Original_Only or else not More_Ids (Node);
4012 end Write_Identifiers;
4014 ------------------------
4015 -- Write_Implicit_Def --
4016 ------------------------
4018 procedure Write_Implicit_Def (E : Entity_Id) is
4019 Ind : Node_Id;
4021 begin
4022 case Ekind (E) is
4023 when E_Array_Subtype =>
4024 Write_Str_With_Col_Check ("subtype ");
4025 Write_Id (E);
4026 Write_Str_With_Col_Check (" is ");
4027 Write_Id (Base_Type (E));
4028 Write_Str_With_Col_Check (" (");
4030 Ind := First_Index (E);
4031 while Present (Ind) loop
4032 Sprint_Node (Ind);
4033 Next_Index (Ind);
4035 if Present (Ind) then
4036 Write_Str (", ");
4037 end if;
4038 end loop;
4040 Write_Str (");");
4042 when E_Enumeration_Subtype
4043 | E_Signed_Integer_Subtype
4045 Write_Str_With_Col_Check ("subtype ");
4046 Write_Id (E);
4047 Write_Str (" is ");
4048 Write_Id (Etype (E));
4049 Write_Str_With_Col_Check (" range ");
4050 Sprint_Node (Scalar_Range (E));
4051 Write_Str (";");
4053 when others =>
4054 Write_Str_With_Col_Check ("type ");
4055 Write_Id (E);
4056 Write_Str_With_Col_Check (" is <");
4057 Write_Ekind (E);
4058 Write_Str (">;");
4059 end case;
4060 end Write_Implicit_Def;
4062 ------------------
4063 -- Write_Indent --
4064 ------------------
4066 procedure Write_Indent is
4067 Loc : constant Source_Ptr := Sloc (Dump_Node);
4069 begin
4070 if Indent_Annull_Flag then
4071 Indent_Annull_Flag := False;
4072 else
4073 -- Deal with Dump_Source_Text output. Note that we ignore implicit
4074 -- label declarations, since they typically have the sloc of the
4075 -- corresponding label, which really messes up the -gnatL output.
4077 if Dump_Source_Text
4078 and then Loc > No_Location
4079 and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration
4080 then
4081 if Get_Source_File_Index (Loc) = Current_Source_File then
4082 Write_Source_Lines
4083 (Get_Physical_Line_Number (Sloc (Dump_Node)));
4084 end if;
4085 end if;
4087 Write_Eol;
4089 for J in 1 .. Indent loop
4090 Write_Char (' ');
4091 end loop;
4092 end if;
4093 end Write_Indent;
4095 ------------------------------
4096 -- Write_Indent_Identifiers --
4097 ------------------------------
4099 function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
4100 begin
4101 -- We need to start a new line for every node, except in the case
4102 -- where we are printing the original tree and this is not the first
4103 -- defining identifier in the list.
4105 if not Dump_Original_Only or else not Prev_Ids (Node) then
4106 Write_Indent;
4108 -- If printing original tree and this is not the first defining
4109 -- identifier in the list, then the previous call to this procedure
4110 -- printed only the name, and we add a comma to separate the names.
4112 else
4113 Write_Str (", ");
4114 end if;
4116 Sprint_Node (Defining_Identifier (Node));
4118 -- The remainder of the declaration must be printed unless we are
4119 -- printing the original tree and this is not the last identifier
4121 return
4122 not Dump_Original_Only or else not More_Ids (Node);
4123 end Write_Indent_Identifiers;
4125 -----------------------------------
4126 -- Write_Indent_Identifiers_Sloc --
4127 -----------------------------------
4129 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
4130 begin
4131 -- We need to start a new line for every node, except in the case
4132 -- where we are printing the original tree and this is not the first
4133 -- defining identifier in the list.
4135 if not Dump_Original_Only or else not Prev_Ids (Node) then
4136 Write_Indent;
4138 -- If printing original tree and this is not the first defining
4139 -- identifier in the list, then the previous call to this procedure
4140 -- printed only the name, and we add a comma to separate the names.
4142 else
4143 Write_Str (", ");
4144 end if;
4146 Set_Debug_Sloc;
4147 Sprint_Node (Defining_Identifier (Node));
4149 -- The remainder of the declaration must be printed unless we are
4150 -- printing the original tree and this is not the last identifier
4152 return not Dump_Original_Only or else not More_Ids (Node);
4153 end Write_Indent_Identifiers_Sloc;
4155 ----------------------
4156 -- Write_Indent_Str --
4157 ----------------------
4159 procedure Write_Indent_Str (S : String) is
4160 begin
4161 Write_Corresponding_Source (S);
4162 Write_Indent;
4163 Write_Str (S);
4164 end Write_Indent_Str;
4166 ---------------------------
4167 -- Write_Indent_Str_Sloc --
4168 ---------------------------
4170 procedure Write_Indent_Str_Sloc (S : String) is
4171 begin
4172 Write_Corresponding_Source (S);
4173 Write_Indent;
4174 Write_Str_Sloc (S);
4175 end Write_Indent_Str_Sloc;
4177 -----------------
4178 -- Write_Itype --
4179 -----------------
4181 procedure Write_Itype (Typ : Entity_Id) is
4183 procedure Write_Header (T : Boolean := True);
4184 -- Write type if T is True, subtype if T is false
4186 ------------------
4187 -- Write_Header --
4188 ------------------
4190 procedure Write_Header (T : Boolean := True) is
4191 begin
4192 if T then
4193 Write_Str ("[type ");
4194 else
4195 Write_Str ("[subtype ");
4196 end if;
4198 Write_Name_With_Col_Check (Chars (Typ));
4199 Write_Str (" is ");
4200 end Write_Header;
4202 -- Start of processing for Write_Itype
4204 begin
4205 if Nkind (Typ) in N_Entity
4206 and then Is_Itype (Typ)
4207 and then not Itype_Printed (Typ)
4208 then
4209 -- Itype to be printed
4211 declare
4212 B : constant Node_Id := Etype (Typ);
4213 X : Node_Id;
4214 P : constant Node_Id := Parent (Typ);
4216 S : constant Saved_Output_Buffer := Save_Output_Buffer;
4217 -- Save current output buffer
4219 Old_Sloc : Source_Ptr;
4220 -- Save sloc of related node, so it is not modified when
4221 -- printing with -gnatD.
4223 begin
4224 -- Write indentation at start of line
4226 for J in 1 .. Indent loop
4227 Write_Char (' ');
4228 end loop;
4230 -- If we have a constructed declaration for the itype, print it
4232 if Present (P)
4233 and then Nkind (P) in N_Declaration
4234 and then Defining_Entity (P) = Typ
4235 then
4236 -- We must set Itype_Printed true before the recursive call to
4237 -- print the node, otherwise we get an infinite recursion.
4239 Set_Itype_Printed (Typ, True);
4241 -- Write the declaration enclosed in [], avoiding new line
4242 -- at start of declaration, and semicolon at end.
4244 -- Note: The itype may be imported from another unit, in which
4245 -- case we do not want to modify the Sloc of the declaration.
4246 -- Otherwise the itype may appear to be in the current unit,
4247 -- and the back-end will reject a reference out of scope.
4249 Write_Char ('[');
4250 Indent_Annull_Flag := True;
4251 Old_Sloc := Sloc (P);
4252 Sprint_Node (P);
4253 Set_Sloc (P, Old_Sloc);
4254 Write_Erase_Char (';');
4256 -- If no constructed declaration, then we have to concoct the
4257 -- source corresponding to the type entity that we have at hand.
4259 else
4260 case Ekind (Typ) is
4262 -- Access types and subtypes
4264 when Access_Kind =>
4265 Write_Header (Ekind (Typ) = E_Access_Type);
4267 if Can_Never_Be_Null (Typ) then
4268 Write_Str ("not null ");
4269 end if;
4271 Write_Str ("access ");
4273 if Is_Access_Constant (Typ) then
4274 Write_Str ("constant ");
4275 end if;
4277 Write_Id (Directly_Designated_Type (Typ));
4279 -- Array types
4281 when E_Array_Type =>
4282 Write_Header;
4283 Write_Str ("array (");
4285 X := First_Index (Typ);
4286 loop
4287 Sprint_Node (X);
4289 if not Is_Constrained (Typ) then
4290 Write_Str (" range <>");
4291 end if;
4293 Next_Index (X);
4294 exit when No (X);
4295 Write_Str (", ");
4296 end loop;
4298 Write_Str (") of ");
4299 X := Component_Type (Typ);
4301 -- Preserve sloc of component type, which is defined
4302 -- elsewhere than the itype (see comment above).
4304 Old_Sloc := Sloc (X);
4305 Sprint_Node (X);
4306 Set_Sloc (X, Old_Sloc);
4308 -- Array subtypes
4310 -- Preserve Sloc of index subtypes, as above
4312 when E_Array_Subtype =>
4313 Write_Header (False);
4314 Write_Id (Etype (Typ));
4315 Write_Str (" (");
4317 X := First_Index (Typ);
4318 loop
4319 Old_Sloc := Sloc (X);
4320 Sprint_Node (X);
4321 Set_Sloc (X, Old_Sloc);
4322 Next_Index (X);
4323 exit when No (X);
4324 Write_Str (", ");
4325 end loop;
4327 Write_Char (')');
4329 -- Signed integer types, and modular integer subtypes,
4330 -- and also enumeration subtypes.
4332 when E_Enumeration_Subtype
4333 | E_Modular_Integer_Subtype
4334 | E_Signed_Integer_Subtype
4335 | E_Signed_Integer_Type
4337 Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
4339 if Ekind (Typ) = E_Signed_Integer_Type then
4340 Write_Str ("new ");
4341 end if;
4343 Write_Id (B);
4345 -- Print bounds if different from base type
4347 declare
4348 L : constant Node_Id := Type_Low_Bound (Typ);
4349 H : constant Node_Id := Type_High_Bound (Typ);
4350 LE : Node_Id;
4351 HE : Node_Id;
4353 begin
4354 -- B can either be a scalar type, in which case the
4355 -- declaration of Typ may constrain it with different
4356 -- bounds, or a private type, in which case we know
4357 -- that the declaration of Typ cannot have a scalar
4358 -- constraint.
4360 if Is_Scalar_Type (B) then
4361 LE := Type_Low_Bound (B);
4362 HE := Type_High_Bound (B);
4363 else
4364 LE := Empty;
4365 HE := Empty;
4366 end if;
4368 if No (LE)
4369 or else (True
4370 and then Nkind (L) = N_Integer_Literal
4371 and then Nkind (H) = N_Integer_Literal
4372 and then Nkind (LE) = N_Integer_Literal
4373 and then Nkind (HE) = N_Integer_Literal
4374 and then UI_Eq (Intval (L), Intval (LE))
4375 and then UI_Eq (Intval (H), Intval (HE)))
4376 then
4377 null;
4379 else
4380 Write_Str (" range ");
4381 Sprint_Node (Type_Low_Bound (Typ));
4382 Write_Str (" .. ");
4383 Sprint_Node (Type_High_Bound (Typ));
4384 end if;
4385 end;
4387 -- Modular integer types
4389 when E_Modular_Integer_Type =>
4390 Write_Header;
4391 Write_Str ("mod ");
4392 Write_Uint_With_Col_Check (Modulus (Typ), Auto);
4394 -- Floating point types and subtypes
4396 when E_Floating_Point_Subtype
4397 | E_Floating_Point_Type
4399 Write_Header (Ekind (Typ) = E_Floating_Point_Type);
4401 if Ekind (Typ) = E_Floating_Point_Type then
4402 Write_Str ("new ");
4403 end if;
4405 Write_Id (Etype (Typ));
4407 if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
4408 Write_Str (" digits ");
4409 Write_Uint_With_Col_Check
4410 (Digits_Value (Typ), Decimal);
4411 end if;
4413 -- Print bounds if not different from base type
4415 declare
4416 L : constant Node_Id := Type_Low_Bound (Typ);
4417 H : constant Node_Id := Type_High_Bound (Typ);
4418 LE : constant Node_Id := Type_Low_Bound (B);
4419 HE : constant Node_Id := Type_High_Bound (B);
4421 begin
4422 if Nkind (L) = N_Real_Literal
4423 and then Nkind (H) = N_Real_Literal
4424 and then Nkind (LE) = N_Real_Literal
4425 and then Nkind (HE) = N_Real_Literal
4426 and then UR_Eq (Realval (L), Realval (LE))
4427 and then UR_Eq (Realval (H), Realval (HE))
4428 then
4429 null;
4431 else
4432 Write_Str (" range ");
4433 Sprint_Node (Type_Low_Bound (Typ));
4434 Write_Str (" .. ");
4435 Sprint_Node (Type_High_Bound (Typ));
4436 end if;
4437 end;
4439 -- Record subtypes
4441 when E_Record_Subtype
4442 | E_Record_Subtype_With_Private
4444 Write_Header (False);
4445 Write_Str ("record");
4446 Indent_Begin;
4448 declare
4449 C : Entity_Id;
4450 begin
4451 C := First_Entity (Typ);
4452 while Present (C) loop
4453 Write_Indent;
4454 Write_Id (C);
4455 Write_Str (" : ");
4456 Write_Id (Etype (C));
4457 Next_Entity (C);
4458 end loop;
4459 end;
4461 Indent_End;
4462 Write_Indent_Str (" end record");
4464 -- Class-Wide types
4466 when E_Class_Wide_Subtype
4467 | E_Class_Wide_Type
4469 Write_Header (Ekind (Typ) = E_Class_Wide_Type);
4470 Write_Name_With_Col_Check (Chars (Etype (Typ)));
4471 Write_Str ("'Class");
4473 -- Subprogram types
4475 when E_Subprogram_Type =>
4476 Write_Header;
4478 if Etype (Typ) = Standard_Void_Type then
4479 Write_Str ("procedure");
4480 else
4481 Write_Str ("function");
4482 end if;
4484 if Present (First_Entity (Typ)) then
4485 Write_Str (" (");
4487 declare
4488 Param : Entity_Id;
4490 begin
4491 Param := First_Entity (Typ);
4492 loop
4493 Write_Id (Param);
4494 Write_Str (" : ");
4496 if Ekind (Param) = E_In_Out_Parameter then
4497 Write_Str ("in out ");
4498 elsif Ekind (Param) = E_Out_Parameter then
4499 Write_Str ("out ");
4500 end if;
4502 Write_Id (Etype (Param));
4503 Next_Entity (Param);
4504 exit when No (Param);
4505 Write_Str (", ");
4506 end loop;
4508 Write_Char (')');
4509 end;
4510 end if;
4512 if Etype (Typ) /= Standard_Void_Type then
4513 Write_Str (" return ");
4514 Write_Id (Etype (Typ));
4515 end if;
4517 when E_String_Literal_Subtype =>
4518 declare
4519 LB : constant Uint :=
4520 Expr_Value (String_Literal_Low_Bound (Typ));
4521 Len : constant Uint :=
4522 String_Literal_Length (Typ);
4523 begin
4524 Write_Header (False);
4525 Write_Str ("String (");
4526 Write_Int (UI_To_Int (LB));
4527 Write_Str (" .. ");
4528 Write_Int (UI_To_Int (LB + Len) - 1);
4529 Write_Str (");");
4530 end;
4532 -- For all other Itypes, print ??? (fill in later)
4534 when others =>
4535 Write_Header (True);
4536 Write_Str ("???");
4537 end case;
4538 end if;
4540 -- Add terminating bracket and restore output buffer
4542 Write_Char (']');
4543 Write_Eol;
4544 Restore_Output_Buffer (S);
4545 end;
4547 Set_Itype_Printed (Typ);
4548 end if;
4549 end Write_Itype;
4551 -------------------------------
4552 -- Write_Name_With_Col_Check --
4553 -------------------------------
4555 procedure Write_Name_With_Col_Check (N : Name_Id) is
4556 J : Natural;
4557 K : Natural;
4558 L : Natural;
4560 begin
4561 -- Avoid crashing on invalid Name_Ids
4563 if not Is_Valid_Name (N) then
4564 Write_Str ("<invalid name ");
4565 Write_Int (Int (N));
4566 Write_Str (">");
4567 return;
4568 end if;
4570 Get_Name_String (N);
4572 -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4573 -- upper case letter, nnn is one or more digits and b is a lower case
4574 -- letter by C...b, so that listings do not depend on serial numbers.
4576 if Debug_Flag_II then
4577 J := 1;
4578 while J < Name_Len - 1 loop
4579 if Name_Buffer (J) in 'A' .. 'Z'
4580 and then Name_Buffer (J + 1) in '0' .. '9'
4581 then
4582 K := J + 1;
4583 while K < Name_Len loop
4584 exit when Name_Buffer (K) not in '0' .. '9';
4585 K := K + 1;
4586 end loop;
4588 if Name_Buffer (K) in 'a' .. 'z' then
4589 L := Name_Len - K + 1;
4591 Name_Buffer (J + 4 .. J + L + 3) :=
4592 Name_Buffer (K .. Name_Len);
4593 Name_Buffer (J + 1 .. J + 3) := "...";
4594 Name_Len := J + L + 3;
4595 J := J + 5;
4597 else
4598 J := K;
4599 end if;
4601 else
4602 J := J + 1;
4603 end if;
4604 end loop;
4605 end if;
4607 -- Fall through for normal case
4609 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
4610 end Write_Name_With_Col_Check;
4612 ------------------------------------
4613 -- Write_Name_With_Col_Check_Sloc --
4614 ------------------------------------
4616 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
4617 begin
4618 -- Avoid crashing on invalid Name_Ids
4620 if not Is_Valid_Name (N) then
4621 Write_Str ("<invalid name ");
4622 Write_Int (Int (N));
4623 Write_Str (">");
4624 return;
4625 end if;
4627 Get_Name_String (N);
4628 Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
4629 end Write_Name_With_Col_Check_Sloc;
4631 --------------------
4632 -- Write_Operator --
4633 --------------------
4635 procedure Write_Operator (N : Node_Id; S : String) is
4636 F : Natural := S'First;
4637 T : Natural := S'Last;
4639 begin
4640 -- If no overflow check, just write string out, and we are done
4642 if not Do_Overflow_Check (N) then
4643 Write_Str_Sloc (S);
4645 -- If overflow check, we want to surround the operator with curly
4646 -- brackets, but not include spaces within the brackets.
4648 else
4649 if S (F) = ' ' then
4650 Write_Char (' ');
4651 F := F + 1;
4652 end if;
4654 if S (T) = ' ' then
4655 T := T - 1;
4656 end if;
4658 Write_Char ('{');
4659 Write_Str_Sloc (S (F .. T));
4660 Write_Char ('}');
4662 if S (S'Last) = ' ' then
4663 Write_Char (' ');
4664 end if;
4665 end if;
4666 end Write_Operator;
4668 -----------------------
4669 -- Write_Param_Specs --
4670 -----------------------
4672 procedure Write_Param_Specs (N : Node_Id) is
4673 Specs : constant List_Id := Parameter_Specifications (N);
4674 Specs_Present : constant Boolean := Is_Non_Empty_List (Specs);
4676 Ent : Entity_Id;
4677 Extras : Node_Id;
4678 Spec : Node_Id;
4679 Formal : Node_Id;
4681 Output : Boolean := False;
4682 -- Set true if we output at least one parameter
4684 begin
4685 -- Write out explicit specs from Parameter_Speficiations list
4687 if Specs_Present then
4688 Write_Str_With_Col_Check (" (");
4689 Output := True;
4691 Spec := First (Specs);
4692 loop
4693 Sprint_Node (Spec);
4694 Formal := Defining_Identifier (Spec);
4695 Next (Spec);
4696 exit when Spec = Empty;
4698 -- Add semicolon, unless we are printing original tree and the
4699 -- next specification is part of a list (but not the first element
4700 -- of that list).
4702 if not Dump_Original_Only or else not Prev_Ids (Spec) then
4703 Write_Str ("; ");
4704 end if;
4705 end loop;
4706 end if;
4708 -- See if we have extra formals
4710 if Nkind_In (N, N_Function_Specification,
4711 N_Procedure_Specification)
4712 then
4713 Ent := Defining_Entity (N);
4715 -- Loop to write extra formals (if any)
4717 if Present (Ent) and then Is_Subprogram (Ent) then
4718 Extras := Extra_Formals (Ent);
4720 if Present (Extras) then
4721 if not Specs_Present then
4722 Write_Str_With_Col_Check (" (");
4723 Output := True;
4724 end if;
4726 Formal := Extras;
4727 while Present (Formal) loop
4728 if Specs_Present or else Formal /= Extras then
4729 Write_Str ("; ");
4730 end if;
4732 Write_Name_With_Col_Check (Chars (Formal));
4733 Write_Str (" : ");
4734 Write_Name_With_Col_Check (Chars (Etype (Formal)));
4735 Formal := Extra_Formal (Formal);
4736 end loop;
4737 end if;
4738 end if;
4739 end if;
4741 if Output then
4742 Write_Char (')');
4743 end if;
4744 end Write_Param_Specs;
4746 -----------------------
4747 -- Write_Rewrite_Str --
4748 -----------------------
4750 procedure Write_Rewrite_Str (S : String) is
4751 begin
4752 if not Dump_Generated_Only then
4753 if S'Length = 3 and then S = ">>>" then
4754 Write_Str (">>>");
4755 else
4756 Write_Str_With_Col_Check (S);
4757 end if;
4758 end if;
4759 end Write_Rewrite_Str;
4761 -----------------------
4762 -- Write_Source_Line --
4763 -----------------------
4765 procedure Write_Source_Line (L : Physical_Line_Number) is
4766 Loc : Source_Ptr;
4767 Src : Source_Buffer_Ptr;
4768 Scn : Source_Ptr;
4770 begin
4771 if Dump_Source_Text then
4772 Src := Source_Text (Current_Source_File);
4773 Loc := Line_Start (L, Current_Source_File);
4774 Write_Eol;
4776 -- See if line is a comment line, if not, and if not line one,
4777 -- precede with blank line.
4779 Scn := Loc;
4780 while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
4781 Scn := Scn + 1;
4782 end loop;
4784 if (Src (Scn) in Line_Terminator
4785 or else Src (Scn .. Scn + 1) /= "--")
4786 and then L /= 1
4787 then
4788 Write_Eol;
4789 end if;
4791 -- Now write the source text of the line
4793 Write_Str ("-- ");
4794 Write_Int (Int (L));
4795 Write_Str (": ");
4797 while Src (Loc) not in Line_Terminator loop
4798 Write_Char (Src (Loc));
4799 Loc := Loc + 1;
4800 end loop;
4801 end if;
4802 end Write_Source_Line;
4804 ------------------------
4805 -- Write_Source_Lines --
4806 ------------------------
4808 procedure Write_Source_Lines (L : Physical_Line_Number) is
4809 begin
4810 while Last_Line_Printed < L loop
4811 Last_Line_Printed := Last_Line_Printed + 1;
4812 Write_Source_Line (Last_Line_Printed);
4813 end loop;
4814 end Write_Source_Lines;
4816 --------------------
4817 -- Write_Str_Sloc --
4818 --------------------
4820 procedure Write_Str_Sloc (S : String) is
4821 begin
4822 for J in S'Range loop
4823 Write_Char_Sloc (S (J));
4824 end loop;
4825 end Write_Str_Sloc;
4827 ------------------------------
4828 -- Write_Str_With_Col_Check --
4829 ------------------------------
4831 procedure Write_Str_With_Col_Check (S : String) is
4832 begin
4833 if Int (S'Last) + Column > Sprint_Line_Limit then
4834 Write_Indent_Str (" ");
4836 if S (S'First) = ' ' then
4837 Write_Str (S (S'First + 1 .. S'Last));
4838 else
4839 Write_Str (S);
4840 end if;
4842 else
4843 Write_Str (S);
4844 end if;
4845 end Write_Str_With_Col_Check;
4847 -----------------------------------
4848 -- Write_Str_With_Col_Check_Sloc --
4849 -----------------------------------
4851 procedure Write_Str_With_Col_Check_Sloc (S : String) is
4852 begin
4853 if Int (S'Last) + Column > Sprint_Line_Limit then
4854 Write_Indent_Str (" ");
4856 if S (S'First) = ' ' then
4857 Write_Str_Sloc (S (S'First + 1 .. S'Last));
4858 else
4859 Write_Str_Sloc (S);
4860 end if;
4862 else
4863 Write_Str_Sloc (S);
4864 end if;
4865 end Write_Str_With_Col_Check_Sloc;
4867 ---------------------------
4868 -- Write_Subprogram_Name --
4869 ---------------------------
4871 procedure Write_Subprogram_Name (N : Node_Id) is
4872 begin
4873 if not Comes_From_Source (N)
4874 and then Is_Entity_Name (N)
4875 then
4876 declare
4877 Ent : constant Entity_Id := Entity (N);
4878 begin
4879 if not In_Extended_Main_Source_Unit (Ent)
4880 and then In_Predefined_Unit (Ent)
4881 then
4882 -- Run-time routine name, output name with a preceding dollar
4883 -- making sure that we do not get a line split between them.
4885 Col_Check (Length_Of_Name (Chars (Ent)) + 1);
4886 Write_Char ('$');
4887 Write_Name (Chars (Ent));
4888 return;
4889 end if;
4890 end;
4891 end if;
4893 -- Normal case, not a run-time routine name
4895 Sprint_Node (N);
4896 end Write_Subprogram_Name;
4898 -------------------------------
4899 -- Write_Uint_With_Col_Check --
4900 -------------------------------
4902 procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is
4903 begin
4904 Col_Check (UI_Decimal_Digits_Hi (U));
4905 UI_Write (U, Format);
4906 end Write_Uint_With_Col_Check;
4908 ------------------------------------
4909 -- Write_Uint_With_Col_Check_Sloc --
4910 ------------------------------------
4912 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
4913 begin
4914 Col_Check (UI_Decimal_Digits_Hi (U));
4915 Set_Debug_Sloc;
4916 UI_Write (U, Format);
4917 end Write_Uint_With_Col_Check_Sloc;
4919 -------------------------------------
4920 -- Write_Ureal_With_Col_Check_Sloc --
4921 -------------------------------------
4923 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
4924 D : constant Uint := Denominator (U);
4925 N : constant Uint := Numerator (U);
4926 begin
4927 Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
4928 Set_Debug_Sloc;
4929 UR_Write (U, Brackets => True);
4930 end Write_Ureal_With_Col_Check_Sloc;
4932 end Sprint;