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