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