?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / sprint.adb
blobe7c1a6a0de97d85d16169ecee71a411ae36e0c1a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S P R I N T --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.1 $
10 -- --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
28
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Lib; use Lib;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Opt; use Opt;
37 with Output; use Output;
38 with Rtsfind; use Rtsfind;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
41 with Sinput.L; use Sinput.L;
42 with Snames; use Snames;
43 with Stand; use Stand;
44 with Stringt; use Stringt;
45 with Uintp; use Uintp;
46 with Uname; use Uname;
47 with Urealp; use Urealp;
48
49 package body Sprint is
50
51 Debug_Node : Node_Id := Empty;
52 -- If we are in Debug_Generated_Code mode, then this location is set
53 -- to the current node requiring Sloc fixup, until Set_Debug_Sloc is
54 -- called to set the proper value. The call clears it back to Empty.
55
56 Debug_Sloc : Source_Ptr;
57 -- Sloc of first byte of line currently being written if we are
58 -- generating a source debug file.
59
60 Dump_Original_Only : Boolean;
61 -- Set True if the -gnatdo (dump original tree) flag is set
62
63 Dump_Generated_Only : Boolean;
64 -- Set True if the -gnatG (dump generated tree) debug flag is set
65 -- or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
66
67 Dump_Freeze_Null : Boolean;
68 -- Set True if freeze nodes and non-source null statements output
69
70 Indent : Int := 0;
71 -- Number of columns for current line output indentation
72
73 Indent_Annull_Flag : Boolean := False;
74 -- Set True if subsequent Write_Indent call to be ignored, gets reset
75 -- by this call, so it is only active to suppress a single indent call.
76
77 Line_Limit : constant := 72;
78 -- Limit value for chopping long lines
79
80 Freeze_Indent : Int := 0;
81 -- Keep track of freeze indent level (controls blank lines before
82 -- procedures within expression freeze actions)
83
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
87
88 procedure Col_Check (N : Nat);
89 -- Check that at least N characters remain on current line, and if not,
90 -- then start an extra line with two characters extra indentation for
91 -- continuing text on the next line.
92
93 procedure Indent_Annull;
94 -- Causes following call to Write_Indent to be ignored. This is used when
95 -- a higher level node wants to stop a lower level node from starting a
96 -- new line, when it would otherwise be inclined to do so (e.g. the case
97 -- of an accept statement called from an accept alternative with a guard)
98
99 procedure Indent_Begin;
100 -- Increase indentation level
101
102 procedure Indent_End;
103 -- Decrease indentation level
104
105 procedure Print_Eol;
106 -- Terminate current line in line buffer
107
108 procedure Process_TFAI_RR_Flags (Nod : Node_Id);
109 -- Given a divide, multiplication or division node, check the flags
110 -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
111 -- appropriate special syntax characters (# and @).
112
113 procedure Set_Debug_Sloc;
114 -- If Debug_Node is non-empty, this routine sets the appropriate value
115 -- in its Sloc field, from the current location in the debug source file
116 -- that is currently being written. Note that Debug_Node is always empty
117 -- if a debug source file is not being written.
118
119 procedure Sprint_Bar_List (List : List_Id);
120 -- Print the given list with items separated by vertical bars
121
122 procedure Sprint_Node_Actual (Node : Node_Id);
123 -- This routine prints its node argument. It is a lower level routine than
124 -- Sprint_Node, in that it does not bother about rewritten trees.
125
126 procedure Sprint_Node_Sloc (Node : Node_Id);
127 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
128 -- sets the Sloc of the current debug node to be a copy of the Sloc
129 -- of the sprinted node Node. Note that this is done after printing
130 -- Node, so that the Sloc is the proper updated value for the debug file.
131
132 procedure Write_Char_Sloc (C : Character);
133 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
134 -- called to ensure that the current node has a proper Sloc set.
135
136 procedure Write_Discr_Specs (N : Node_Id);
137 -- Output discriminant specification for node, which is any of the type
138 -- declarations that can have discriminants.
139
140 procedure Write_Ekind (E : Entity_Id);
141 -- Write the String corresponding to the Ekind without "E_".
142
143 procedure Write_Id (N : Node_Id);
144 -- N is a node with a Chars field. This procedure writes the name that
145 -- will be used in the generated code associated with the name. For a
146 -- node with no associated entity, this is simply the Chars field. For
147 -- the case where there is an entity associated with the node, we print
148 -- the name associated with the entity (since it may have been encoded).
149 -- One other special case is that an entity has an active external name
150 -- (i.e. an external name present with no address clause), then this
151 -- external name is output.
152
153 function Write_Identifiers (Node : Node_Id) return Boolean;
154 -- Handle node where the grammar has a list of defining identifiers, but
155 -- the tree has a separate declaration for each identifier. Handles the
156 -- printing of the defining identifier, and returns True if the type and
157 -- initialization information is to be printed, False if it is to be
158 -- skipped (the latter case happens when printing defining identifiers
159 -- other than the first in the original tree output case).
160
161 procedure Write_Implicit_Def (E : Entity_Id);
162 pragma Warnings (Off, Write_Implicit_Def);
163 -- Write the definition of the implicit type E according to its Ekind
164 -- For now a debugging procedure, but might be used in the future.
165
166 procedure Write_Indent;
167 -- Start a new line and write indentation spacing
168
169 function Write_Indent_Identifiers (Node : Node_Id) return Boolean;
170 -- Like Write_Identifiers except that each new printed declaration
171 -- is at the start of a new line.
172
173 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean;
174 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
175 -- mode, the Sloc of the current debug node is set to point ot the
176 -- first output identifier.
177
178 procedure Write_Indent_Str (S : String);
179 -- Start a new line and write indent spacing followed by given string
180
181 procedure Write_Indent_Str_Sloc (S : String);
182 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
183 -- the Sloc of the current node is set to the first non-blank character
184 -- in the string S.
185
186 procedure Write_Name_With_Col_Check (N : Name_Id);
187 -- Write name (using Write_Name) with initial column check, and possible
188 -- initial Write_Indent (to get new line) if current line is too full.
189
190 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id);
191 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
192 -- mode, sets Sloc of current debug node to first character of name.
193
194 procedure Write_Operator (N : Node_Id; S : String);
195 -- Like Write_Str_Sloc, used for operators, encloses the string in
196 -- characters {} if the Do_Overflow flag is set on the node N.
197
198 procedure Write_Param_Specs (N : Node_Id);
199 -- Output parameter specifications for node (which is either a function
200 -- or procedure specification with a Parameter_Specifications field)
201
202 procedure Write_Rewrite_Str (S : String);
203 -- Writes out a string (typically containing <<< or >>>}) for a node
204 -- created by rewriting the tree. Suppressed if we are outputting the
205 -- generated code only, since in this case we don't specially mark nodes
206 -- created by rewriting).
207
208 procedure Write_Str_Sloc (S : String);
209 -- Like Write_Str, but sets debug Sloc of current debug node to first
210 -- non-blank character if a current debug node is active.
211
212 procedure Write_Str_With_Col_Check (S : String);
213 -- Write string (using Write_Str) with initial column check, and possible
214 -- initial Write_Indent (to get new line) if current line is too full.
215
216 procedure Write_Str_With_Col_Check_Sloc (S : String);
217 -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug
218 -- node to first non-blank character if a current debug node is active.
219
220 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format);
221 -- Write Uint (using UI_Write) with initial column check, and possible
222 -- initial Write_Indent (to get new line) if current line is too full.
223 -- The format parameter determines the output format (see UI_Write).
224 -- In addition, in Debug_Generated_Code mode, sets the current node
225 -- Sloc to the first character of the output value.
226
227 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal);
228 -- Write Ureal (using same output format as UR_Write) with column checks
229 -- and a possible initial Write_Indent (to get new line) if current line
230 -- is too full. In addition, in Debug_Generated_Code mode, sets the
231 -- current node Sloc to the first character of the output value.
232
233 ---------------
234 -- Col_Check --
235 ---------------
236
237 procedure Col_Check (N : Nat) is
238 begin
239 if N + Column > Line_Limit then
240 Write_Indent_Str (" ");
241 end if;
242 end Col_Check;
243
244 -------------------
245 -- Indent_Annull --
246 -------------------
247
248 procedure Indent_Annull is
249 begin
250 Indent_Annull_Flag := True;
251 end Indent_Annull;
252
253 ------------------
254 -- Indent_Begin --
255 ------------------
256
257 procedure Indent_Begin is
258 begin
259 Indent := Indent + 3;
260 end Indent_Begin;
261
262 ----------------
263 -- Indent_End --
264 ----------------
265
266 procedure Indent_End is
267 begin
268 Indent := Indent - 3;
269 end Indent_End;
270
271 --------
272 -- PG --
273 --------
274
275 procedure PG (Node : Node_Id) is
276 begin
277 Dump_Generated_Only := True;
278 Dump_Original_Only := False;
279 Sprint_Node (Node);
280 Print_Eol;
281 end PG;
282
283 --------
284 -- PO --
285 --------
286
287 procedure PO (Node : Node_Id) is
288 begin
289 Dump_Generated_Only := False;
290 Dump_Original_Only := True;
291 Sprint_Node (Node);
292 Print_Eol;
293 end PO;
294
295 ---------------
296 -- Print_Eol --
297 ---------------
298
299 procedure Print_Eol is
300 begin
301 -- If we are writing a debug source file, then grab it from the
302 -- Output buffer, and reset the column counter (the routines in
303 -- Output never actually write any output for us in this mode,
304 -- they just build line images in Buffer).
305
306 if Debug_Generated_Code then
307 Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc);
308 Column := 1;
309
310 -- In normal mode, we call Write_Eol to write the line normally
311
312 else
313 Write_Eol;
314 end if;
315 end Print_Eol;
316
317 ---------------------------
318 -- Process_TFAI_RR_Flags --
319 ---------------------------
320
321 procedure Process_TFAI_RR_Flags (Nod : Node_Id) is
322 begin
323 if Treat_Fixed_As_Integer (Nod) then
324 Write_Char ('#');
325 end if;
326
327 if Rounded_Result (Nod) then
328 Write_Char ('@');
329 end if;
330 end Process_TFAI_RR_Flags;
331
332 --------
333 -- PS --
334 --------
335
336 procedure PS (Node : Node_Id) is
337 begin
338 Dump_Generated_Only := False;
339 Dump_Original_Only := False;
340 Sprint_Node (Node);
341 Print_Eol;
342 end PS;
343
344 --------------------
345 -- Set_Debug_Sloc --
346 --------------------
347
348 procedure Set_Debug_Sloc is
349 begin
350 if Present (Debug_Node) then
351 Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1));
352 Debug_Node := Empty;
353 end if;
354 end Set_Debug_Sloc;
355
356 -----------------
357 -- Source_Dump --
358 -----------------
359
360 procedure Source_Dump is
361
362 procedure Underline;
363 -- Put underline under string we just printed
364
365 procedure Underline is
366 Col : constant Int := Column;
367
368 begin
369 Print_Eol;
370
371 while Col > Column loop
372 Write_Char ('-');
373 end loop;
374
375 Print_Eol;
376 end Underline;
377
378 -- Start of processing for Tree_Dump.
379
380 begin
381 Dump_Generated_Only := Debug_Flag_G or
382 Print_Generated_Code or
383 Debug_Generated_Code;
384 Dump_Original_Only := Debug_Flag_O;
385 Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G;
386
387 -- Note that we turn off the tree dump flags immediately, before
388 -- starting the dump. This avoids generating two copies of the dump
389 -- if an abort occurs after printing the dump, and more importantly,
390 -- avoids an infinite loop if an abort occurs during the dump.
391
392 if Debug_Flag_Z then
393 Debug_Flag_Z := False;
394 Print_Eol;
395 Print_Eol;
396 Write_Str ("Source recreated from tree of Standard (spec)");
397 Underline;
398 Sprint_Node (Standard_Package_Node);
399 Print_Eol;
400 Print_Eol;
401 end if;
402
403 if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
404 Debug_Flag_G := False;
405 Debug_Flag_O := False;
406 Debug_Flag_S := False;
407
408 -- Dump requested units
409
410 for U in Main_Unit .. Last_Unit loop
411
412 -- Dump all units if -gnatdf set, otherwise we dump only
413 -- the source files that are in the extended main source.
414
415 if Debug_Flag_F
416 or else In_Extended_Main_Source_Unit (Cunit_Entity (U))
417 then
418 -- If we are generating debug files, setup to write them
419
420 if Debug_Generated_Code then
421 Create_Debug_Source (Source_Index (U), Debug_Sloc);
422 Sprint_Node (Cunit (U));
423 Print_Eol;
424 Close_Debug_Source;
425
426 -- Normal output to standard output file
427
428 else
429 Write_Str ("Source recreated from tree for ");
430 Write_Unit_Name (Unit_Name (U));
431 Underline;
432 Sprint_Node (Cunit (U));
433 Write_Eol;
434 Write_Eol;
435 end if;
436 end if;
437 end loop;
438 end if;
439 end Source_Dump;
440
441 ---------------------
442 -- Sprint_Bar_List --
443 ---------------------
444
445 procedure Sprint_Bar_List (List : List_Id) is
446 Node : Node_Id;
447
448 begin
449 if Is_Non_Empty_List (List) then
450 Node := First (List);
451
452 loop
453 Sprint_Node (Node);
454 Next (Node);
455 exit when Node = Empty;
456 Write_Str (" | ");
457 end loop;
458 end if;
459 end Sprint_Bar_List;
460
461 -----------------------
462 -- Sprint_Comma_List --
463 -----------------------
464
465 procedure Sprint_Comma_List (List : List_Id) is
466 Node : Node_Id;
467
468 begin
469 if Is_Non_Empty_List (List) then
470 Node := First (List);
471
472 loop
473 Sprint_Node (Node);
474 Next (Node);
475 exit when Node = Empty;
476
477 if not Is_Rewrite_Insertion (Node)
478 or else not Dump_Original_Only
479 then
480 Write_Str (", ");
481 end if;
482
483 end loop;
484 end if;
485 end Sprint_Comma_List;
486
487 --------------------------
488 -- Sprint_Indented_List --
489 --------------------------
490
491 procedure Sprint_Indented_List (List : List_Id) is
492 begin
493 Indent_Begin;
494 Sprint_Node_List (List);
495 Indent_End;
496 end Sprint_Indented_List;
497
498 -----------------
499 -- Sprint_Node --
500 -----------------
501
502 procedure Sprint_Node (Node : Node_Id) is
503 begin
504 if Is_Rewrite_Insertion (Node) then
505 if not Dump_Original_Only then
506
507 -- For special cases of nodes that always output <<< >>>
508 -- do not duplicate the output at this point.
509
510 if Nkind (Node) = N_Freeze_Entity
511 or else Nkind (Node) = N_Implicit_Label_Declaration
512 then
513 Sprint_Node_Actual (Node);
514
515 -- Normal case where <<< >>> may be required
516
517 else
518 Write_Rewrite_Str ("<<<");
519 Sprint_Node_Actual (Node);
520 Write_Rewrite_Str (">>>");
521 end if;
522 end if;
523
524 elsif Is_Rewrite_Substitution (Node) then
525
526 -- Case of dump generated only
527
528 if Dump_Generated_Only then
529 Sprint_Node_Actual (Node);
530
531 -- Case of dump original only
532
533 elsif Dump_Original_Only then
534 Sprint_Node_Actual (Original_Node (Node));
535
536 -- Case of both being dumped
537
538 else
539 Sprint_Node_Actual (Original_Node (Node));
540 Write_Rewrite_Str ("<<<");
541 Sprint_Node_Actual (Node);
542 Write_Rewrite_Str (">>>");
543 end if;
544
545 else
546 Sprint_Node_Actual (Node);
547 end if;
548 end Sprint_Node;
549
550 ------------------------
551 -- Sprint_Node_Actual --
552 ------------------------
553
554 procedure Sprint_Node_Actual (Node : Node_Id) is
555 Save_Debug_Node : constant Node_Id := Debug_Node;
556
557 begin
558 if Node = Empty then
559 return;
560 end if;
561
562 for J in 1 .. Paren_Count (Node) loop
563 Write_Str_With_Col_Check ("(");
564 end loop;
565
566 -- Setup node for Sloc fixup if writing a debug source file. Note
567 -- that we take care of any previous node not yet properly set.
568
569 if Debug_Generated_Code then
570 Debug_Node := Node;
571 end if;
572
573 if Nkind (Node) in N_Subexpr
574 and then Do_Range_Check (Node)
575 then
576 Write_Str_With_Col_Check ("{");
577 end if;
578
579 -- Select print circuit based on node kind
580
581 case Nkind (Node) is
582
583 when N_Abort_Statement =>
584 Write_Indent_Str_Sloc ("abort ");
585 Sprint_Comma_List (Names (Node));
586 Write_Char (';');
587
588 when N_Abortable_Part =>
589 Set_Debug_Sloc;
590 Write_Str_Sloc ("abort ");
591 Sprint_Indented_List (Statements (Node));
592
593 when N_Abstract_Subprogram_Declaration =>
594 Write_Indent;
595 Sprint_Node (Specification (Node));
596 Write_Str_With_Col_Check (" is ");
597 Write_Str_Sloc ("abstract;");
598
599 when N_Accept_Alternative =>
600 Sprint_Node_List (Pragmas_Before (Node));
601
602 if Present (Condition (Node)) then
603 Write_Indent_Str ("when ");
604 Sprint_Node (Condition (Node));
605 Write_Str (" => ");
606 Indent_Annull;
607 end if;
608
609 Sprint_Node_Sloc (Accept_Statement (Node));
610 Sprint_Node_List (Statements (Node));
611
612 when N_Accept_Statement =>
613 Write_Indent_Str_Sloc ("accept ");
614 Write_Id (Entry_Direct_Name (Node));
615
616 if Present (Entry_Index (Node)) then
617 Write_Str_With_Col_Check (" (");
618 Sprint_Node (Entry_Index (Node));
619 Write_Char (')');
620 end if;
621
622 Write_Param_Specs (Node);
623
624 if Present (Handled_Statement_Sequence (Node)) then
625 Write_Str_With_Col_Check (" do");
626 Sprint_Node (Handled_Statement_Sequence (Node));
627 Write_Indent_Str ("end ");
628 Write_Id (Entry_Direct_Name (Node));
629 end if;
630
631 Write_Char (';');
632
633 when N_Access_Definition =>
634 Write_Str_With_Col_Check_Sloc ("access ");
635 Sprint_Node (Subtype_Mark (Node));
636
637 when N_Access_Function_Definition =>
638 Write_Str_With_Col_Check_Sloc ("access ");
639
640 if Protected_Present (Node) then
641 Write_Str_With_Col_Check ("protected ");
642 end if;
643
644 Write_Str_With_Col_Check ("function");
645 Write_Param_Specs (Node);
646 Write_Str_With_Col_Check (" return ");
647 Sprint_Node (Subtype_Mark (Node));
648
649 when N_Access_Procedure_Definition =>
650 Write_Str_With_Col_Check_Sloc ("access ");
651
652 if Protected_Present (Node) then
653 Write_Str_With_Col_Check ("protected ");
654 end if;
655
656 Write_Str_With_Col_Check ("procedure");
657 Write_Param_Specs (Node);
658
659 when N_Access_To_Object_Definition =>
660 Write_Str_With_Col_Check_Sloc ("access ");
661
662 if All_Present (Node) then
663 Write_Str_With_Col_Check ("all ");
664 elsif Constant_Present (Node) then
665 Write_Str_With_Col_Check ("constant ");
666 end if;
667
668 Sprint_Node (Subtype_Indication (Node));
669
670 when N_Aggregate =>
671 if Null_Record_Present (Node) then
672 Write_Str_With_Col_Check_Sloc ("(null record)");
673
674 else
675 Write_Str_With_Col_Check_Sloc ("(");
676
677 if Present (Expressions (Node)) then
678 Sprint_Comma_List (Expressions (Node));
679
680 if Present (Component_Associations (Node)) then
681 Write_Str (", ");
682 end if;
683 end if;
684
685 if Present (Component_Associations (Node)) then
686 Indent_Begin;
687
688 declare
689 Nd : Node_Id;
690
691 begin
692 Nd := First (Component_Associations (Node));
693
694 loop
695 Write_Indent;
696 Sprint_Node (Nd);
697 Next (Nd);
698 exit when No (Nd);
699
700 if not Is_Rewrite_Insertion (Nd)
701 or else not Dump_Original_Only
702 then
703 Write_Str (", ");
704 end if;
705 end loop;
706 end;
707
708 Indent_End;
709 end if;
710
711 Write_Char (')');
712 end if;
713
714 when N_Allocator =>
715 Write_Str_With_Col_Check_Sloc ("new ");
716 Sprint_Node (Expression (Node));
717
718 if Present (Storage_Pool (Node)) then
719 Write_Str_With_Col_Check ("[storage_pool = ");
720 Sprint_Node (Storage_Pool (Node));
721 Write_Char (']');
722 end if;
723
724 when N_And_Then =>
725 Sprint_Node (Left_Opnd (Node));
726 Write_Str_Sloc (" and then ");
727 Sprint_Node (Right_Opnd (Node));
728
729 when N_At_Clause =>
730 Write_Indent_Str_Sloc ("for ");
731 Write_Id (Identifier (Node));
732 Write_Str_With_Col_Check (" use at ");
733 Sprint_Node (Expression (Node));
734 Write_Char (';');
735
736 when N_Assignment_Statement =>
737 Write_Indent;
738 Sprint_Node (Name (Node));
739 Write_Str_Sloc (" := ");
740 Sprint_Node (Expression (Node));
741 Write_Char (';');
742
743 when N_Asynchronous_Select =>
744 Write_Indent_Str_Sloc ("select");
745 Indent_Begin;
746 Sprint_Node (Triggering_Alternative (Node));
747 Indent_End;
748
749 -- Note: let the printing of Abortable_Part handle outputting
750 -- the ABORT keyword, so that the Slco can be set correctly.
751
752 Write_Indent_Str ("then ");
753 Sprint_Node (Abortable_Part (Node));
754 Write_Indent_Str ("end select;");
755
756 when N_Attribute_Definition_Clause =>
757 Write_Indent_Str_Sloc ("for ");
758 Sprint_Node (Name (Node));
759 Write_Char (''');
760 Write_Name_With_Col_Check (Chars (Node));
761 Write_Str_With_Col_Check (" use ");
762 Sprint_Node (Expression (Node));
763 Write_Char (';');
764
765 when N_Attribute_Reference =>
766 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
767 Write_Indent;
768 end if;
769
770 Sprint_Node (Prefix (Node));
771 Write_Char_Sloc (''');
772 Write_Name_With_Col_Check (Attribute_Name (Node));
773 Sprint_Paren_Comma_List (Expressions (Node));
774
775 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then
776 Write_Char (';');
777 end if;
778
779 when N_Block_Statement =>
780 Write_Indent;
781
782 if Present (Identifier (Node))
783 and then (not Has_Created_Identifier (Node)
784 or else not Dump_Original_Only)
785 then
786 Write_Rewrite_Str ("<<<");
787 Write_Id (Identifier (Node));
788 Write_Str (" : ");
789 Write_Rewrite_Str (">>>");
790 end if;
791
792 if Present (Declarations (Node)) then
793 Write_Str_With_Col_Check_Sloc ("declare");
794 Sprint_Indented_List (Declarations (Node));
795 Write_Indent;
796 end if;
797
798 Write_Str_With_Col_Check_Sloc ("begin");
799 Sprint_Node (Handled_Statement_Sequence (Node));
800 Write_Indent_Str ("end");
801
802 if Present (Identifier (Node))
803 and then (not Has_Created_Identifier (Node)
804 or else not Dump_Original_Only)
805 then
806 Write_Rewrite_Str ("<<<");
807 Write_Char (' ');
808 Write_Id (Identifier (Node));
809 Write_Rewrite_Str (">>>");
810 end if;
811
812 Write_Char (';');
813
814 when N_Case_Statement =>
815 Write_Indent_Str_Sloc ("case ");
816 Sprint_Node (Expression (Node));
817 Write_Str (" is");
818 Sprint_Indented_List (Alternatives (Node));
819 Write_Indent_Str ("end case;");
820
821 when N_Case_Statement_Alternative =>
822 Write_Indent_Str_Sloc ("when ");
823 Sprint_Bar_List (Discrete_Choices (Node));
824 Write_Str (" => ");
825 Sprint_Indented_List (Statements (Node));
826
827 when N_Character_Literal =>
828 if Column > 70 then
829 Write_Indent_Str (" ");
830 end if;
831
832 Write_Char_Sloc (''');
833 Write_Char_Code (Char_Literal_Value (Node));
834 Write_Char (''');
835
836 when N_Code_Statement =>
837 Write_Indent;
838 Set_Debug_Sloc;
839 Sprint_Node (Expression (Node));
840 Write_Char (';');
841
842 when N_Compilation_Unit =>
843 Sprint_Node_List (Context_Items (Node));
844 Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node)));
845
846 if Private_Present (Node) then
847 Write_Indent_Str ("private ");
848 Indent_Annull;
849 end if;
850
851 Sprint_Node_Sloc (Unit (Node));
852
853 if Present (Actions (Aux_Decls_Node (Node)))
854 or else
855 Present (Pragmas_After (Aux_Decls_Node (Node)))
856 then
857 Write_Indent;
858 end if;
859
860 Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node)));
861 Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node)));
862
863 when N_Compilation_Unit_Aux =>
864 null; -- nothing to do, never used, see above
865
866 when N_Component_Association =>
867 Set_Debug_Sloc;
868 Sprint_Bar_List (Choices (Node));
869 Write_Str (" => ");
870 Sprint_Node (Expression (Node));
871
872 when N_Component_Clause =>
873 Write_Indent;
874 Sprint_Node (Component_Name (Node));
875 Write_Str_Sloc (" at ");
876 Sprint_Node (Position (Node));
877 Write_Char (' ');
878 Write_Str_With_Col_Check ("range ");
879 Sprint_Node (First_Bit (Node));
880 Write_Str (" .. ");
881 Sprint_Node (Last_Bit (Node));
882 Write_Char (';');
883
884 when N_Component_Declaration =>
885 if Write_Indent_Identifiers_Sloc (Node) then
886 Write_Str (" : ");
887
888 if Aliased_Present (Node) then
889 Write_Str_With_Col_Check ("aliased ");
890 end if;
891
892 Sprint_Node (Subtype_Indication (Node));
893
894 if Present (Expression (Node)) then
895 Write_Str (" := ");
896 Sprint_Node (Expression (Node));
897 end if;
898
899 Write_Char (';');
900 end if;
901
902 when N_Component_List =>
903 if Null_Present (Node) then
904 Indent_Begin;
905 Write_Indent_Str_Sloc ("null");
906 Write_Char (';');
907 Indent_End;
908
909 else
910 Set_Debug_Sloc;
911 Sprint_Indented_List (Component_Items (Node));
912 Sprint_Node (Variant_Part (Node));
913 end if;
914
915 when N_Conditional_Entry_Call =>
916 Write_Indent_Str_Sloc ("select");
917 Indent_Begin;
918 Sprint_Node (Entry_Call_Alternative (Node));
919 Indent_End;
920 Write_Indent_Str ("else");
921 Sprint_Indented_List (Else_Statements (Node));
922 Write_Indent_Str ("end select;");
923
924 when N_Conditional_Expression =>
925 declare
926 Condition : constant Node_Id := First (Expressions (Node));
927 Then_Expr : constant Node_Id := Next (Condition);
928 Else_Expr : constant Node_Id := Next (Then_Expr);
929
930 begin
931 Write_Str_With_Col_Check_Sloc ("(if ");
932 Sprint_Node (Condition);
933 Write_Str_With_Col_Check (" then ");
934 Sprint_Node (Then_Expr);
935 Write_Str_With_Col_Check (" else ");
936 Sprint_Node (Else_Expr);
937 Write_Char (')');
938 end;
939
940 when N_Constrained_Array_Definition =>
941 Write_Str_With_Col_Check_Sloc ("array ");
942 Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
943 Write_Str (" of ");
944
945 if Aliased_Present (Node) then
946 Write_Str_With_Col_Check ("aliased ");
947 end if;
948
949 Sprint_Node (Subtype_Indication (Node));
950
951 when N_Decimal_Fixed_Point_Definition =>
952 Write_Str_With_Col_Check_Sloc (" delta ");
953 Sprint_Node (Delta_Expression (Node));
954 Write_Str_With_Col_Check ("digits ");
955 Sprint_Node (Digits_Expression (Node));
956 Sprint_Opt_Node (Real_Range_Specification (Node));
957
958 when N_Defining_Character_Literal =>
959 Write_Name_With_Col_Check_Sloc (Chars (Node));
960
961 when N_Defining_Identifier =>
962 Set_Debug_Sloc;
963 Write_Id (Node);
964
965 when N_Defining_Operator_Symbol =>
966 Write_Name_With_Col_Check_Sloc (Chars (Node));
967
968 when N_Defining_Program_Unit_Name =>
969 Set_Debug_Sloc;
970 Sprint_Node (Name (Node));
971 Write_Char ('.');
972 Write_Id (Defining_Identifier (Node));
973
974 when N_Delay_Alternative =>
975 Sprint_Node_List (Pragmas_Before (Node));
976
977 if Present (Condition (Node)) then
978 Write_Indent;
979 Write_Str_With_Col_Check ("when ");
980 Sprint_Node (Condition (Node));
981 Write_Str (" => ");
982 Indent_Annull;
983 end if;
984
985 Sprint_Node_Sloc (Delay_Statement (Node));
986 Sprint_Node_List (Statements (Node));
987
988 when N_Delay_Relative_Statement =>
989 Write_Indent_Str_Sloc ("delay ");
990 Sprint_Node (Expression (Node));
991 Write_Char (';');
992
993 when N_Delay_Until_Statement =>
994 Write_Indent_Str_Sloc ("delay until ");
995 Sprint_Node (Expression (Node));
996 Write_Char (';');
997
998 when N_Delta_Constraint =>
999 Write_Str_With_Col_Check_Sloc ("delta ");
1000 Sprint_Node (Delta_Expression (Node));
1001 Sprint_Opt_Node (Range_Constraint (Node));
1002
1003 when N_Derived_Type_Definition =>
1004 if Abstract_Present (Node) then
1005 Write_Str_With_Col_Check ("abstract ");
1006 end if;
1007
1008 Write_Str_With_Col_Check_Sloc ("new ");
1009 Sprint_Node (Subtype_Indication (Node));
1010
1011 if Present (Record_Extension_Part (Node)) then
1012 Write_Str_With_Col_Check (" with ");
1013 Sprint_Node (Record_Extension_Part (Node));
1014 end if;
1015
1016 when N_Designator =>
1017 Sprint_Node (Name (Node));
1018 Write_Char_Sloc ('.');
1019 Write_Id (Identifier (Node));
1020
1021 when N_Digits_Constraint =>
1022 Write_Str_With_Col_Check_Sloc ("digits ");
1023 Sprint_Node (Digits_Expression (Node));
1024 Sprint_Opt_Node (Range_Constraint (Node));
1025
1026 when N_Discriminant_Association =>
1027 Set_Debug_Sloc;
1028
1029 if Present (Selector_Names (Node)) then
1030 Sprint_Bar_List (Selector_Names (Node));
1031 Write_Str (" => ");
1032 end if;
1033
1034 Set_Debug_Sloc;
1035 Sprint_Node (Expression (Node));
1036
1037 when N_Discriminant_Specification =>
1038 Set_Debug_Sloc;
1039
1040 if Write_Identifiers (Node) then
1041 Write_Str (" : ");
1042 Sprint_Node (Discriminant_Type (Node));
1043
1044 if Present (Expression (Node)) then
1045 Write_Str (" := ");
1046 Sprint_Node (Expression (Node));
1047 end if;
1048 else
1049 Write_Str (", ");
1050 end if;
1051
1052 when N_Elsif_Part =>
1053 Write_Indent_Str_Sloc ("elsif ");
1054 Sprint_Node (Condition (Node));
1055 Write_Str_With_Col_Check (" then");
1056 Sprint_Indented_List (Then_Statements (Node));
1057
1058 when N_Empty =>
1059 null;
1060
1061 when N_Entry_Body =>
1062 Write_Indent_Str_Sloc ("entry ");
1063 Write_Id (Defining_Identifier (Node));
1064 Sprint_Node (Entry_Body_Formal_Part (Node));
1065 Write_Str_With_Col_Check (" is");
1066 Sprint_Indented_List (Declarations (Node));
1067 Write_Indent_Str ("begin");
1068 Sprint_Node (Handled_Statement_Sequence (Node));
1069 Write_Indent_Str ("end ");
1070 Write_Id (Defining_Identifier (Node));
1071 Write_Char (';');
1072
1073 when N_Entry_Body_Formal_Part =>
1074 if Present (Entry_Index_Specification (Node)) then
1075 Write_Str_With_Col_Check_Sloc (" (");
1076 Sprint_Node (Entry_Index_Specification (Node));
1077 Write_Char (')');
1078 end if;
1079
1080 Write_Param_Specs (Node);
1081 Write_Str_With_Col_Check_Sloc (" when ");
1082 Sprint_Node (Condition (Node));
1083
1084 when N_Entry_Call_Alternative =>
1085 Sprint_Node_List (Pragmas_Before (Node));
1086 Sprint_Node_Sloc (Entry_Call_Statement (Node));
1087 Sprint_Node_List (Statements (Node));
1088
1089 when N_Entry_Call_Statement =>
1090 Write_Indent;
1091 Sprint_Node_Sloc (Name (Node));
1092 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1093 Write_Char (';');
1094
1095 when N_Entry_Declaration =>
1096 Write_Indent_Str_Sloc ("entry ");
1097 Write_Id (Defining_Identifier (Node));
1098
1099 if Present (Discrete_Subtype_Definition (Node)) then
1100 Write_Str_With_Col_Check (" (");
1101 Sprint_Node (Discrete_Subtype_Definition (Node));
1102 Write_Char (')');
1103 end if;
1104
1105 Write_Param_Specs (Node);
1106 Write_Char (';');
1107
1108 when N_Entry_Index_Specification =>
1109 Write_Str_With_Col_Check_Sloc ("for ");
1110 Write_Id (Defining_Identifier (Node));
1111 Write_Str_With_Col_Check (" in ");
1112 Sprint_Node (Discrete_Subtype_Definition (Node));
1113
1114 when N_Enumeration_Representation_Clause =>
1115 Write_Indent_Str_Sloc ("for ");
1116 Write_Id (Identifier (Node));
1117 Write_Str_With_Col_Check (" use ");
1118 Sprint_Node (Array_Aggregate (Node));
1119 Write_Char (';');
1120
1121 when N_Enumeration_Type_Definition =>
1122 Set_Debug_Sloc;
1123
1124 -- Skip attempt to print Literals field if it's not there and
1125 -- we are in package Standard (case of Character, which is
1126 -- handled specially (without an explicit literals list).
1127
1128 if Sloc (Node) > Standard_Location
1129 or else Present (Literals (Node))
1130 then
1131 Sprint_Paren_Comma_List (Literals (Node));
1132 end if;
1133
1134 when N_Error =>
1135 Write_Str_With_Col_Check_Sloc ("<error>");
1136
1137 when N_Exception_Declaration =>
1138 if Write_Indent_Identifiers (Node) then
1139 Write_Str_With_Col_Check (" : ");
1140 Write_Str_Sloc ("exception;");
1141 end if;
1142
1143 when N_Exception_Handler =>
1144 Write_Indent_Str_Sloc ("when ");
1145
1146 if Present (Choice_Parameter (Node)) then
1147 Sprint_Node (Choice_Parameter (Node));
1148 Write_Str (" : ");
1149 end if;
1150
1151 Sprint_Bar_List (Exception_Choices (Node));
1152 Write_Str (" => ");
1153 Sprint_Indented_List (Statements (Node));
1154
1155 when N_Exception_Renaming_Declaration =>
1156 Write_Indent;
1157 Set_Debug_Sloc;
1158 Sprint_Node (Defining_Identifier (Node));
1159 Write_Str_With_Col_Check (" : exception renames ");
1160 Sprint_Node (Name (Node));
1161 Write_Char (';');
1162
1163 when N_Exit_Statement =>
1164 Write_Indent_Str_Sloc ("exit");
1165 Sprint_Opt_Node (Name (Node));
1166
1167 if Present (Condition (Node)) then
1168 Write_Str_With_Col_Check (" when ");
1169 Sprint_Node (Condition (Node));
1170 end if;
1171
1172 Write_Char (';');
1173
1174 when N_Explicit_Dereference =>
1175 Sprint_Node (Prefix (Node));
1176 Write_Char ('.');
1177 Write_Str_Sloc ("all");
1178
1179 when N_Extension_Aggregate =>
1180 Write_Str_With_Col_Check_Sloc ("(");
1181 Sprint_Node (Ancestor_Part (Node));
1182 Write_Str_With_Col_Check (" with ");
1183
1184 if Null_Record_Present (Node) then
1185 Write_Str_With_Col_Check ("null record");
1186 else
1187 if Present (Expressions (Node)) then
1188 Sprint_Comma_List (Expressions (Node));
1189
1190 if Present (Component_Associations (Node)) then
1191 Write_Str (", ");
1192 end if;
1193 end if;
1194
1195 if Present (Component_Associations (Node)) then
1196 Sprint_Comma_List (Component_Associations (Node));
1197 end if;
1198 end if;
1199
1200 Write_Char (')');
1201
1202 when N_Floating_Point_Definition =>
1203 Write_Str_With_Col_Check_Sloc ("digits ");
1204 Sprint_Node (Digits_Expression (Node));
1205 Sprint_Opt_Node (Real_Range_Specification (Node));
1206
1207 when N_Formal_Decimal_Fixed_Point_Definition =>
1208 Write_Str_With_Col_Check_Sloc ("delta <> digits <>");
1209
1210 when N_Formal_Derived_Type_Definition =>
1211 Write_Str_With_Col_Check_Sloc ("new ");
1212 Sprint_Node (Subtype_Mark (Node));
1213
1214 if Private_Present (Node) then
1215 Write_Str_With_Col_Check (" with private");
1216 end if;
1217
1218 when N_Formal_Discrete_Type_Definition =>
1219 Write_Str_With_Col_Check_Sloc ("<>");
1220
1221 when N_Formal_Floating_Point_Definition =>
1222 Write_Str_With_Col_Check_Sloc ("digits <>");
1223
1224 when N_Formal_Modular_Type_Definition =>
1225 Write_Str_With_Col_Check_Sloc ("mod <>");
1226
1227 when N_Formal_Object_Declaration =>
1228 Set_Debug_Sloc;
1229
1230 if Write_Indent_Identifiers (Node) then
1231 Write_Str (" : ");
1232
1233 if In_Present (Node) then
1234 Write_Str_With_Col_Check ("in ");
1235 end if;
1236
1237 if Out_Present (Node) then
1238 Write_Str_With_Col_Check ("out ");
1239 end if;
1240
1241 Sprint_Node (Subtype_Mark (Node));
1242
1243 if Present (Expression (Node)) then
1244 Write_Str (" := ");
1245 Sprint_Node (Expression (Node));
1246 end if;
1247
1248 Write_Char (';');
1249 end if;
1250
1251 when N_Formal_Ordinary_Fixed_Point_Definition =>
1252 Write_Str_With_Col_Check_Sloc ("delta <>");
1253
1254 when N_Formal_Package_Declaration =>
1255 Write_Indent_Str_Sloc ("with package ");
1256 Write_Id (Defining_Identifier (Node));
1257 Write_Str_With_Col_Check (" is new ");
1258 Sprint_Node (Name (Node));
1259 Write_Str_With_Col_Check (" (<>);");
1260
1261 when N_Formal_Private_Type_Definition =>
1262 if Abstract_Present (Node) then
1263 Write_Str_With_Col_Check ("abstract ");
1264 end if;
1265
1266 if Tagged_Present (Node) then
1267 Write_Str_With_Col_Check ("tagged ");
1268 end if;
1269
1270 if Limited_Present (Node) then
1271 Write_Str_With_Col_Check ("limited ");
1272 end if;
1273
1274 Write_Str_With_Col_Check_Sloc ("private");
1275
1276 when N_Formal_Signed_Integer_Type_Definition =>
1277 Write_Str_With_Col_Check_Sloc ("range <>");
1278
1279 when N_Formal_Subprogram_Declaration =>
1280 Write_Indent_Str_Sloc ("with ");
1281 Sprint_Node (Specification (Node));
1282
1283 if Box_Present (Node) then
1284 Write_Str_With_Col_Check (" is <>");
1285 elsif Present (Default_Name (Node)) then
1286 Write_Str_With_Col_Check (" is ");
1287 Sprint_Node (Default_Name (Node));
1288 end if;
1289
1290 Write_Char (';');
1291
1292 when N_Formal_Type_Declaration =>
1293 Write_Indent_Str_Sloc ("type ");
1294 Write_Id (Defining_Identifier (Node));
1295
1296 if Present (Discriminant_Specifications (Node)) then
1297 Write_Discr_Specs (Node);
1298 elsif Unknown_Discriminants_Present (Node) then
1299 Write_Str_With_Col_Check ("(<>)");
1300 end if;
1301
1302 Write_Str_With_Col_Check (" is ");
1303 Sprint_Node (Formal_Type_Definition (Node));
1304 Write_Char (';');
1305
1306 when N_Free_Statement =>
1307 Write_Indent_Str_Sloc ("free ");
1308 Sprint_Node (Expression (Node));
1309 Write_Char (';');
1310
1311 when N_Freeze_Entity =>
1312 if Dump_Original_Only then
1313 null;
1314
1315 elsif Present (Actions (Node)) or else Dump_Freeze_Null then
1316 Write_Indent;
1317 Write_Rewrite_Str ("<<<");
1318 Write_Str_With_Col_Check_Sloc ("freeze ");
1319 Write_Id (Entity (Node));
1320 Write_Str (" [");
1321
1322 if No (Actions (Node)) then
1323 Write_Char (']');
1324
1325 else
1326 Freeze_Indent := Freeze_Indent + 1;
1327 Sprint_Indented_List (Actions (Node));
1328 Freeze_Indent := Freeze_Indent - 1;
1329 Write_Indent_Str ("]");
1330 end if;
1331
1332 Write_Rewrite_Str (">>>");
1333 end if;
1334
1335 when N_Full_Type_Declaration =>
1336 Write_Indent_Str_Sloc ("type ");
1337 Write_Id (Defining_Identifier (Node));
1338 Write_Discr_Specs (Node);
1339 Write_Str_With_Col_Check (" is ");
1340 Sprint_Node (Type_Definition (Node));
1341 Write_Char (';');
1342
1343 when N_Function_Call =>
1344 Set_Debug_Sloc;
1345 Sprint_Node (Name (Node));
1346 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1347
1348 when N_Function_Instantiation =>
1349 Write_Indent_Str_Sloc ("function ");
1350 Sprint_Node (Defining_Unit_Name (Node));
1351 Write_Str_With_Col_Check (" is new ");
1352 Sprint_Node (Name (Node));
1353 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
1354 Write_Char (';');
1355
1356 when N_Function_Specification =>
1357 Write_Str_With_Col_Check_Sloc ("function ");
1358 Sprint_Node (Defining_Unit_Name (Node));
1359 Write_Param_Specs (Node);
1360 Write_Str_With_Col_Check (" return ");
1361 Sprint_Node (Subtype_Mark (Node));
1362
1363 when N_Generic_Association =>
1364 Set_Debug_Sloc;
1365
1366 if Present (Selector_Name (Node)) then
1367 Sprint_Node (Selector_Name (Node));
1368 Write_Str (" => ");
1369 end if;
1370
1371 Sprint_Node (Explicit_Generic_Actual_Parameter (Node));
1372
1373 when N_Generic_Function_Renaming_Declaration =>
1374 Write_Indent_Str_Sloc ("generic function ");
1375 Sprint_Node (Defining_Unit_Name (Node));
1376 Write_Str_With_Col_Check (" renames ");
1377 Sprint_Node (Name (Node));
1378 Write_Char (';');
1379
1380 when N_Generic_Package_Declaration =>
1381 Write_Indent;
1382 Write_Indent_Str_Sloc ("generic ");
1383 Sprint_Indented_List (Generic_Formal_Declarations (Node));
1384 Write_Indent;
1385 Sprint_Node (Specification (Node));
1386 Write_Char (';');
1387
1388 when N_Generic_Package_Renaming_Declaration =>
1389 Write_Indent_Str_Sloc ("generic package ");
1390 Sprint_Node (Defining_Unit_Name (Node));
1391 Write_Str_With_Col_Check (" renames ");
1392 Sprint_Node (Name (Node));
1393 Write_Char (';');
1394
1395 when N_Generic_Procedure_Renaming_Declaration =>
1396 Write_Indent_Str_Sloc ("generic procedure ");
1397 Sprint_Node (Defining_Unit_Name (Node));
1398 Write_Str_With_Col_Check (" renames ");
1399 Sprint_Node (Name (Node));
1400 Write_Char (';');
1401
1402 when N_Generic_Subprogram_Declaration =>
1403 Write_Indent;
1404 Write_Indent_Str_Sloc ("generic ");
1405 Sprint_Indented_List (Generic_Formal_Declarations (Node));
1406 Write_Indent;
1407 Sprint_Node (Specification (Node));
1408 Write_Char (';');
1409
1410 when N_Goto_Statement =>
1411 Write_Indent_Str_Sloc ("goto ");
1412 Sprint_Node (Name (Node));
1413 Write_Char (';');
1414
1415 if Nkind (Next (Node)) = N_Label then
1416 Write_Indent;
1417 end if;
1418
1419 when N_Handled_Sequence_Of_Statements =>
1420 Set_Debug_Sloc;
1421 Sprint_Indented_List (Statements (Node));
1422
1423 if Present (Exception_Handlers (Node)) then
1424 Write_Indent_Str ("exception");
1425 Indent_Begin;
1426 Sprint_Node_List (Exception_Handlers (Node));
1427 Indent_End;
1428 end if;
1429
1430 if Present (At_End_Proc (Node)) then
1431 Write_Indent_Str ("at end");
1432 Indent_Begin;
1433 Write_Indent;
1434 Sprint_Node (At_End_Proc (Node));
1435 Write_Char (';');
1436 Indent_End;
1437 end if;
1438
1439 when N_Identifier =>
1440 Set_Debug_Sloc;
1441 Write_Id (Node);
1442
1443 when N_If_Statement =>
1444 Write_Indent_Str_Sloc ("if ");
1445 Sprint_Node (Condition (Node));
1446 Write_Str_With_Col_Check (" then");
1447 Sprint_Indented_List (Then_Statements (Node));
1448 Sprint_Opt_Node_List (Elsif_Parts (Node));
1449
1450 if Present (Else_Statements (Node)) then
1451 Write_Indent_Str ("else");
1452 Sprint_Indented_List (Else_Statements (Node));
1453 end if;
1454
1455 Write_Indent_Str ("end if;");
1456
1457 when N_Implicit_Label_Declaration =>
1458 if not Dump_Original_Only then
1459 Write_Indent;
1460 Write_Rewrite_Str ("<<<");
1461 Set_Debug_Sloc;
1462 Write_Id (Defining_Identifier (Node));
1463 Write_Str (" : ");
1464 Write_Str_With_Col_Check ("label");
1465 Write_Rewrite_Str (">>>");
1466 end if;
1467
1468 when N_In =>
1469 Sprint_Node (Left_Opnd (Node));
1470 Write_Str_Sloc (" in ");
1471 Sprint_Node (Right_Opnd (Node));
1472
1473 when N_Incomplete_Type_Declaration =>
1474 Write_Indent_Str_Sloc ("type ");
1475 Write_Id (Defining_Identifier (Node));
1476
1477 if Present (Discriminant_Specifications (Node)) then
1478 Write_Discr_Specs (Node);
1479 elsif Unknown_Discriminants_Present (Node) then
1480 Write_Str_With_Col_Check ("(<>)");
1481 end if;
1482
1483 Write_Char (';');
1484
1485 when N_Index_Or_Discriminant_Constraint =>
1486 Set_Debug_Sloc;
1487 Sprint_Paren_Comma_List (Constraints (Node));
1488
1489 when N_Indexed_Component =>
1490 Sprint_Node_Sloc (Prefix (Node));
1491 Sprint_Opt_Paren_Comma_List (Expressions (Node));
1492
1493 when N_Integer_Literal =>
1494 if Print_In_Hex (Node) then
1495 Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex);
1496 else
1497 Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto);
1498 end if;
1499
1500 when N_Iteration_Scheme =>
1501 if Present (Condition (Node)) then
1502 Write_Str_With_Col_Check_Sloc ("while ");
1503 Sprint_Node (Condition (Node));
1504 else
1505 Write_Str_With_Col_Check_Sloc ("for ");
1506 Sprint_Node (Loop_Parameter_Specification (Node));
1507 end if;
1508
1509 Write_Char (' ');
1510
1511 when N_Itype_Reference =>
1512 Write_Indent_Str_Sloc ("reference ");
1513 Write_Id (Itype (Node));
1514
1515 when N_Label =>
1516 Write_Indent_Str_Sloc ("<<");
1517 Write_Id (Identifier (Node));
1518 Write_Str (">>");
1519
1520 when N_Loop_Parameter_Specification =>
1521 Set_Debug_Sloc;
1522 Write_Id (Defining_Identifier (Node));
1523 Write_Str_With_Col_Check (" in ");
1524
1525 if Reverse_Present (Node) then
1526 Write_Str_With_Col_Check ("reverse ");
1527 end if;
1528
1529 Sprint_Node (Discrete_Subtype_Definition (Node));
1530
1531 when N_Loop_Statement =>
1532 Write_Indent;
1533
1534 if Present (Identifier (Node))
1535 and then (not Has_Created_Identifier (Node)
1536 or else not Dump_Original_Only)
1537 then
1538 Write_Rewrite_Str ("<<<");
1539 Write_Id (Identifier (Node));
1540 Write_Str (" : ");
1541 Write_Rewrite_Str (">>>");
1542 Sprint_Node (Iteration_Scheme (Node));
1543 Write_Str_With_Col_Check_Sloc ("loop");
1544 Sprint_Indented_List (Statements (Node));
1545 Write_Indent_Str ("end loop ");
1546 Write_Rewrite_Str ("<<<");
1547 Write_Id (Identifier (Node));
1548 Write_Rewrite_Str (">>>");
1549 Write_Char (';');
1550
1551 else
1552 Sprint_Node (Iteration_Scheme (Node));
1553 Write_Str_With_Col_Check_Sloc ("loop");
1554 Sprint_Indented_List (Statements (Node));
1555 Write_Indent_Str ("end loop;");
1556 end if;
1557
1558 when N_Mod_Clause =>
1559 Sprint_Node_List (Pragmas_Before (Node));
1560 Write_Str_With_Col_Check_Sloc ("at mod ");
1561 Sprint_Node (Expression (Node));
1562
1563 when N_Modular_Type_Definition =>
1564 Write_Str_With_Col_Check_Sloc ("mod ");
1565 Sprint_Node (Expression (Node));
1566
1567 when N_Not_In =>
1568 Sprint_Node (Left_Opnd (Node));
1569 Write_Str_Sloc (" not in ");
1570 Sprint_Node (Right_Opnd (Node));
1571
1572 when N_Null =>
1573 Write_Str_With_Col_Check_Sloc ("null");
1574
1575 when N_Null_Statement =>
1576 if Comes_From_Source (Node)
1577 or else Dump_Freeze_Null
1578 or else not Is_List_Member (Node)
1579 or else (No (Prev (Node)) and then No (Next (Node)))
1580 then
1581 Write_Indent_Str_Sloc ("null;");
1582 end if;
1583
1584 when N_Number_Declaration =>
1585 Set_Debug_Sloc;
1586
1587 if Write_Indent_Identifiers (Node) then
1588 Write_Str_With_Col_Check (" : constant ");
1589 Write_Str (" := ");
1590 Sprint_Node (Expression (Node));
1591 Write_Char (';');
1592 end if;
1593
1594 when N_Object_Declaration =>
1595
1596 -- Put extra blank line before and after if this is a handler
1597 -- record or a subprogram descriptor.
1598
1599 declare
1600 Typ : constant Entity_Id := Etype (Defining_Identifier (Node));
1601 Exc : constant Boolean :=
1602 Is_RTE (Typ, RE_Handler_Record)
1603 or else
1604 Is_RTE (Typ, RE_Subprogram_Descriptor);
1605
1606 begin
1607 if Exc then
1608 Write_Indent;
1609 end if;
1610
1611 Set_Debug_Sloc;
1612
1613 if Write_Indent_Identifiers (Node) then
1614 Write_Str (" : ");
1615
1616 if Aliased_Present (Node) then
1617 Write_Str_With_Col_Check ("aliased ");
1618 end if;
1619
1620 if Constant_Present (Node) then
1621 Write_Str_With_Col_Check ("constant ");
1622 end if;
1623
1624 Sprint_Node (Object_Definition (Node));
1625
1626 if Present (Expression (Node)) then
1627 Write_Str (" := ");
1628 Sprint_Node (Expression (Node));
1629 end if;
1630
1631 Write_Char (';');
1632 end if;
1633
1634 if Exc then
1635 Write_Indent;
1636 end if;
1637 end;
1638
1639 when N_Object_Renaming_Declaration =>
1640 Write_Indent;
1641 Set_Debug_Sloc;
1642 Sprint_Node (Defining_Identifier (Node));
1643 Write_Str (" : ");
1644 Sprint_Node (Subtype_Mark (Node));
1645 Write_Str_With_Col_Check (" renames ");
1646 Sprint_Node (Name (Node));
1647 Write_Char (';');
1648
1649 when N_Op_Abs =>
1650 Write_Operator (Node, "abs ");
1651 Sprint_Node (Right_Opnd (Node));
1652
1653 when N_Op_Add =>
1654 Sprint_Node (Left_Opnd (Node));
1655 Write_Operator (Node, " + ");
1656 Sprint_Node (Right_Opnd (Node));
1657
1658 when N_Op_And =>
1659 Sprint_Node (Left_Opnd (Node));
1660 Write_Operator (Node, " and ");
1661 Sprint_Node (Right_Opnd (Node));
1662
1663 when N_Op_Concat =>
1664 Sprint_Node (Left_Opnd (Node));
1665 Write_Operator (Node, " & ");
1666 Sprint_Node (Right_Opnd (Node));
1667
1668 when N_Op_Divide =>
1669 Sprint_Node (Left_Opnd (Node));
1670 Write_Char (' ');
1671 Process_TFAI_RR_Flags (Node);
1672 Write_Operator (Node, "/ ");
1673 Sprint_Node (Right_Opnd (Node));
1674
1675 when N_Op_Eq =>
1676 Sprint_Node (Left_Opnd (Node));
1677 Write_Operator (Node, " = ");
1678 Sprint_Node (Right_Opnd (Node));
1679
1680 when N_Op_Expon =>
1681 Sprint_Node (Left_Opnd (Node));
1682 Write_Operator (Node, " ** ");
1683 Sprint_Node (Right_Opnd (Node));
1684
1685 when N_Op_Ge =>
1686 Sprint_Node (Left_Opnd (Node));
1687 Write_Operator (Node, " >= ");
1688 Sprint_Node (Right_Opnd (Node));
1689
1690 when N_Op_Gt =>
1691 Sprint_Node (Left_Opnd (Node));
1692 Write_Operator (Node, " > ");
1693 Sprint_Node (Right_Opnd (Node));
1694
1695 when N_Op_Le =>
1696 Sprint_Node (Left_Opnd (Node));
1697 Write_Operator (Node, " <= ");
1698 Sprint_Node (Right_Opnd (Node));
1699
1700 when N_Op_Lt =>
1701 Sprint_Node (Left_Opnd (Node));
1702 Write_Operator (Node, " < ");
1703 Sprint_Node (Right_Opnd (Node));
1704
1705 when N_Op_Minus =>
1706 Write_Operator (Node, "-");
1707 Sprint_Node (Right_Opnd (Node));
1708
1709 when N_Op_Mod =>
1710 Sprint_Node (Left_Opnd (Node));
1711
1712 if Treat_Fixed_As_Integer (Node) then
1713 Write_Str (" #");
1714 end if;
1715
1716 Write_Operator (Node, " mod ");
1717 Sprint_Node (Right_Opnd (Node));
1718
1719 when N_Op_Multiply =>
1720 Sprint_Node (Left_Opnd (Node));
1721 Write_Char (' ');
1722 Process_TFAI_RR_Flags (Node);
1723 Write_Operator (Node, "* ");
1724 Sprint_Node (Right_Opnd (Node));
1725
1726 when N_Op_Ne =>
1727 Sprint_Node (Left_Opnd (Node));
1728 Write_Operator (Node, " /= ");
1729 Sprint_Node (Right_Opnd (Node));
1730
1731 when N_Op_Not =>
1732 Write_Operator (Node, "not ");
1733 Sprint_Node (Right_Opnd (Node));
1734
1735 when N_Op_Or =>
1736 Sprint_Node (Left_Opnd (Node));
1737 Write_Operator (Node, " or ");
1738 Sprint_Node (Right_Opnd (Node));
1739
1740 when N_Op_Plus =>
1741 Write_Operator (Node, "+");
1742 Sprint_Node (Right_Opnd (Node));
1743
1744 when N_Op_Rem =>
1745 Sprint_Node (Left_Opnd (Node));
1746
1747 if Treat_Fixed_As_Integer (Node) then
1748 Write_Str (" #");
1749 end if;
1750
1751 Write_Operator (Node, " rem ");
1752 Sprint_Node (Right_Opnd (Node));
1753
1754 when N_Op_Shift =>
1755 Set_Debug_Sloc;
1756 Write_Id (Node);
1757 Write_Char ('!');
1758 Write_Str_With_Col_Check ("(");
1759 Sprint_Node (Left_Opnd (Node));
1760 Write_Str (", ");
1761 Sprint_Node (Right_Opnd (Node));
1762 Write_Char (')');
1763
1764 when N_Op_Subtract =>
1765 Sprint_Node (Left_Opnd (Node));
1766 Write_Operator (Node, " - ");
1767 Sprint_Node (Right_Opnd (Node));
1768
1769 when N_Op_Xor =>
1770 Sprint_Node (Left_Opnd (Node));
1771 Write_Operator (Node, " xor ");
1772 Sprint_Node (Right_Opnd (Node));
1773
1774 when N_Operator_Symbol =>
1775 Write_Name_With_Col_Check_Sloc (Chars (Node));
1776
1777 when N_Ordinary_Fixed_Point_Definition =>
1778 Write_Str_With_Col_Check_Sloc ("delta ");
1779 Sprint_Node (Delta_Expression (Node));
1780 Sprint_Opt_Node (Real_Range_Specification (Node));
1781
1782 when N_Or_Else =>
1783 Sprint_Node (Left_Opnd (Node));
1784 Write_Str_Sloc (" or else ");
1785 Sprint_Node (Right_Opnd (Node));
1786
1787 when N_Others_Choice =>
1788 if All_Others (Node) then
1789 Write_Str_With_Col_Check ("all ");
1790 end if;
1791
1792 Write_Str_With_Col_Check_Sloc ("others");
1793
1794 when N_Package_Body =>
1795 Write_Indent;
1796 Write_Indent_Str_Sloc ("package body ");
1797 Sprint_Node (Defining_Unit_Name (Node));
1798 Write_Str (" is");
1799 Sprint_Indented_List (Declarations (Node));
1800
1801 if Present (Handled_Statement_Sequence (Node)) then
1802 Write_Indent_Str ("begin");
1803 Sprint_Node (Handled_Statement_Sequence (Node));
1804 end if;
1805
1806 Write_Indent_Str ("end ");
1807 Sprint_Node (Defining_Unit_Name (Node));
1808 Write_Char (';');
1809
1810 when N_Package_Body_Stub =>
1811 Write_Indent_Str_Sloc ("package body ");
1812 Sprint_Node (Defining_Identifier (Node));
1813 Write_Str_With_Col_Check (" is separate;");
1814
1815 when N_Package_Declaration =>
1816 Write_Indent;
1817 Write_Indent;
1818 Sprint_Node_Sloc (Specification (Node));
1819 Write_Char (';');
1820
1821 when N_Package_Instantiation =>
1822 Write_Indent;
1823 Write_Indent_Str_Sloc ("package ");
1824 Sprint_Node (Defining_Unit_Name (Node));
1825 Write_Str (" is new ");
1826 Sprint_Node (Name (Node));
1827 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
1828 Write_Char (';');
1829
1830 when N_Package_Renaming_Declaration =>
1831 Write_Indent_Str_Sloc ("package ");
1832 Sprint_Node (Defining_Unit_Name (Node));
1833 Write_Str_With_Col_Check (" renames ");
1834 Sprint_Node (Name (Node));
1835 Write_Char (';');
1836
1837 when N_Package_Specification =>
1838 Write_Str_With_Col_Check_Sloc ("package ");
1839 Sprint_Node (Defining_Unit_Name (Node));
1840 Write_Str (" is");
1841 Sprint_Indented_List (Visible_Declarations (Node));
1842
1843 if Present (Private_Declarations (Node)) then
1844 Write_Indent_Str ("private");
1845 Sprint_Indented_List (Private_Declarations (Node));
1846 end if;
1847
1848 Write_Indent_Str ("end ");
1849 Sprint_Node (Defining_Unit_Name (Node));
1850
1851 when N_Parameter_Association =>
1852 Sprint_Node_Sloc (Selector_Name (Node));
1853 Write_Str (" => ");
1854 Sprint_Node (Explicit_Actual_Parameter (Node));
1855
1856 when N_Parameter_Specification =>
1857 Set_Debug_Sloc;
1858
1859 if Write_Identifiers (Node) then
1860 Write_Str (" : ");
1861
1862 if In_Present (Node) then
1863 Write_Str_With_Col_Check ("in ");
1864 end if;
1865
1866 if Out_Present (Node) then
1867 Write_Str_With_Col_Check ("out ");
1868 end if;
1869
1870 Sprint_Node (Parameter_Type (Node));
1871
1872 if Present (Expression (Node)) then
1873 Write_Str (" := ");
1874 Sprint_Node (Expression (Node));
1875 end if;
1876 else
1877 Write_Str (", ");
1878 end if;
1879
1880 when N_Pragma =>
1881 Write_Indent_Str_Sloc ("pragma ");
1882 Write_Name_With_Col_Check (Chars (Node));
1883
1884 if Present (Pragma_Argument_Associations (Node)) then
1885 Sprint_Opt_Paren_Comma_List
1886 (Pragma_Argument_Associations (Node));
1887 end if;
1888
1889 Write_Char (';');
1890
1891 when N_Pragma_Argument_Association =>
1892 Set_Debug_Sloc;
1893
1894 if Chars (Node) /= No_Name then
1895 Write_Name_With_Col_Check (Chars (Node));
1896 Write_Str (" => ");
1897 end if;
1898
1899 Sprint_Node (Expression (Node));
1900
1901 when N_Private_Type_Declaration =>
1902 Write_Indent_Str_Sloc ("type ");
1903 Write_Id (Defining_Identifier (Node));
1904
1905 if Present (Discriminant_Specifications (Node)) then
1906 Write_Discr_Specs (Node);
1907 elsif Unknown_Discriminants_Present (Node) then
1908 Write_Str_With_Col_Check ("(<>)");
1909 end if;
1910
1911 Write_Str (" is ");
1912
1913 if Tagged_Present (Node) then
1914 Write_Str_With_Col_Check ("tagged ");
1915 end if;
1916
1917 if Limited_Present (Node) then
1918 Write_Str_With_Col_Check ("limited ");
1919 end if;
1920
1921 Write_Str_With_Col_Check ("private;");
1922
1923 when N_Private_Extension_Declaration =>
1924 Write_Indent_Str_Sloc ("type ");
1925 Write_Id (Defining_Identifier (Node));
1926
1927 if Present (Discriminant_Specifications (Node)) then
1928 Write_Discr_Specs (Node);
1929 elsif Unknown_Discriminants_Present (Node) then
1930 Write_Str_With_Col_Check ("(<>)");
1931 end if;
1932
1933 Write_Str_With_Col_Check (" is new ");
1934 Sprint_Node (Subtype_Indication (Node));
1935 Write_Str_With_Col_Check (" with private;");
1936
1937 when N_Procedure_Call_Statement =>
1938 Write_Indent;
1939 Set_Debug_Sloc;
1940 Sprint_Node (Name (Node));
1941 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node));
1942 Write_Char (';');
1943
1944 when N_Procedure_Instantiation =>
1945 Write_Indent_Str_Sloc ("procedure ");
1946 Sprint_Node (Defining_Unit_Name (Node));
1947 Write_Str_With_Col_Check (" is new ");
1948 Sprint_Node (Name (Node));
1949 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
1950 Write_Char (';');
1951
1952 when N_Procedure_Specification =>
1953 Write_Str_With_Col_Check_Sloc ("procedure ");
1954 Sprint_Node (Defining_Unit_Name (Node));
1955 Write_Param_Specs (Node);
1956
1957 when N_Protected_Body =>
1958 Write_Indent_Str_Sloc ("protected body ");
1959 Write_Id (Defining_Identifier (Node));
1960 Write_Str (" is");
1961 Sprint_Indented_List (Declarations (Node));
1962 Write_Indent_Str ("end ");
1963 Write_Id (Defining_Identifier (Node));
1964 Write_Char (';');
1965
1966 when N_Protected_Body_Stub =>
1967 Write_Indent_Str_Sloc ("protected body ");
1968 Write_Id (Defining_Identifier (Node));
1969 Write_Str_With_Col_Check (" is separate;");
1970
1971 when N_Protected_Definition =>
1972 Set_Debug_Sloc;
1973 Sprint_Indented_List (Visible_Declarations (Node));
1974
1975 if Present (Private_Declarations (Node)) then
1976 Write_Indent_Str ("private");
1977 Sprint_Indented_List (Private_Declarations (Node));
1978 end if;
1979
1980 Write_Indent_Str ("end ");
1981
1982 when N_Protected_Type_Declaration =>
1983 Write_Indent_Str_Sloc ("protected type ");
1984 Write_Id (Defining_Identifier (Node));
1985 Write_Discr_Specs (Node);
1986 Write_Str (" is");
1987 Sprint_Node (Protected_Definition (Node));
1988 Write_Id (Defining_Identifier (Node));
1989 Write_Char (';');
1990
1991 when N_Qualified_Expression =>
1992 Sprint_Node (Subtype_Mark (Node));
1993 Write_Char_Sloc (''');
1994 Sprint_Node (Expression (Node));
1995
1996 when N_Raise_Constraint_Error =>
1997
1998 -- This node can be used either as a subexpression or as a
1999 -- statement form. The following test is a reasonably reliable
2000 -- way to distinguish the two cases.
2001
2002 if Is_List_Member (Node)
2003 and then Nkind (Parent (Node)) not in N_Subexpr
2004 then
2005 Write_Indent;
2006 end if;
2007
2008 Write_Str_With_Col_Check_Sloc ("[constraint_error");
2009
2010 if Present (Condition (Node)) then
2011 Write_Str_With_Col_Check (" when ");
2012 Sprint_Node (Condition (Node));
2013 end if;
2014
2015 Write_Char (']');
2016
2017 when N_Raise_Program_Error =>
2018 Write_Indent;
2019 Write_Str_With_Col_Check_Sloc ("[program_error");
2020
2021 if Present (Condition (Node)) then
2022 Write_Str_With_Col_Check (" when ");
2023 Sprint_Node (Condition (Node));
2024 end if;
2025
2026 Write_Char (']');
2027
2028 when N_Raise_Storage_Error =>
2029 Write_Indent;
2030 Write_Str_With_Col_Check_Sloc ("[storage_error");
2031
2032 if Present (Condition (Node)) then
2033 Write_Str_With_Col_Check (" when ");
2034 Sprint_Node (Condition (Node));
2035 end if;
2036
2037 Write_Char (']');
2038
2039 when N_Raise_Statement =>
2040 Write_Indent_Str_Sloc ("raise ");
2041 Sprint_Node (Name (Node));
2042 Write_Char (';');
2043
2044 when N_Range =>
2045 Sprint_Node (Low_Bound (Node));
2046 Write_Str_Sloc (" .. ");
2047 Sprint_Node (High_Bound (Node));
2048
2049 when N_Range_Constraint =>
2050 Write_Str_With_Col_Check_Sloc ("range ");
2051 Sprint_Node (Range_Expression (Node));
2052
2053 when N_Real_Literal =>
2054 Write_Ureal_With_Col_Check_Sloc (Realval (Node));
2055
2056 when N_Real_Range_Specification =>
2057 Write_Str_With_Col_Check_Sloc ("range ");
2058 Sprint_Node (Low_Bound (Node));
2059 Write_Str (" .. ");
2060 Sprint_Node (High_Bound (Node));
2061
2062 when N_Record_Definition =>
2063 if Abstract_Present (Node) then
2064 Write_Str_With_Col_Check ("abstract ");
2065 end if;
2066
2067 if Tagged_Present (Node) then
2068 Write_Str_With_Col_Check ("tagged ");
2069 end if;
2070
2071 if Limited_Present (Node) then
2072 Write_Str_With_Col_Check ("limited ");
2073 end if;
2074
2075 if Null_Present (Node) then
2076 Write_Str_With_Col_Check_Sloc ("null record");
2077
2078 else
2079 Write_Str_With_Col_Check_Sloc ("record");
2080 Sprint_Node (Component_List (Node));
2081 Write_Indent_Str ("end record");
2082 end if;
2083
2084 when N_Record_Representation_Clause =>
2085 Write_Indent_Str_Sloc ("for ");
2086 Sprint_Node (Identifier (Node));
2087 Write_Str_With_Col_Check (" use record ");
2088
2089 if Present (Mod_Clause (Node)) then
2090 Sprint_Node (Mod_Clause (Node));
2091 end if;
2092
2093 Sprint_Indented_List (Component_Clauses (Node));
2094 Write_Indent_Str ("end record;");
2095
2096 when N_Reference =>
2097 Sprint_Node (Prefix (Node));
2098 Write_Str_With_Col_Check_Sloc ("'reference");
2099
2100 when N_Requeue_Statement =>
2101 Write_Indent_Str_Sloc ("requeue ");
2102 Sprint_Node (Name (Node));
2103
2104 if Abort_Present (Node) then
2105 Write_Str_With_Col_Check (" with abort");
2106 end if;
2107
2108 Write_Char (';');
2109
2110 when N_Return_Statement =>
2111 if Present (Expression (Node)) then
2112 Write_Indent_Str_Sloc ("return ");
2113 Sprint_Node (Expression (Node));
2114 Write_Char (';');
2115 else
2116 Write_Indent_Str_Sloc ("return;");
2117 end if;
2118
2119 when N_Selective_Accept =>
2120 Write_Indent_Str_Sloc ("select");
2121
2122 declare
2123 Alt_Node : Node_Id;
2124
2125 begin
2126 Alt_Node := First (Select_Alternatives (Node));
2127 loop
2128 Indent_Begin;
2129 Sprint_Node (Alt_Node);
2130 Indent_End;
2131 Next (Alt_Node);
2132 exit when No (Alt_Node);
2133 Write_Indent_Str ("or");
2134 end loop;
2135 end;
2136
2137 if Present (Else_Statements (Node)) then
2138 Write_Indent_Str ("else");
2139 Sprint_Indented_List (Else_Statements (Node));
2140 end if;
2141
2142 Write_Indent_Str ("end select;");
2143
2144 when N_Signed_Integer_Type_Definition =>
2145 Write_Str_With_Col_Check_Sloc ("range ");
2146 Sprint_Node (Low_Bound (Node));
2147 Write_Str (" .. ");
2148 Sprint_Node (High_Bound (Node));
2149
2150 when N_Single_Protected_Declaration =>
2151 Write_Indent_Str_Sloc ("protected ");
2152 Write_Id (Defining_Identifier (Node));
2153 Write_Str (" is");
2154 Sprint_Node (Protected_Definition (Node));
2155 Write_Id (Defining_Identifier (Node));
2156 Write_Char (';');
2157
2158 when N_Single_Task_Declaration =>
2159 Write_Indent_Str_Sloc ("task ");
2160 Write_Id (Defining_Identifier (Node));
2161
2162 if Present (Task_Definition (Node)) then
2163 Write_Str (" is");
2164 Sprint_Node (Task_Definition (Node));
2165 Write_Id (Defining_Identifier (Node));
2166 end if;
2167
2168 Write_Char (';');
2169
2170 when N_Selected_Component | N_Expanded_Name =>
2171 Sprint_Node (Prefix (Node));
2172 Write_Char_Sloc ('.');
2173 Sprint_Node (Selector_Name (Node));
2174
2175 when N_Slice =>
2176 Set_Debug_Sloc;
2177 Sprint_Node (Prefix (Node));
2178 Write_Str_With_Col_Check (" (");
2179 Sprint_Node (Discrete_Range (Node));
2180 Write_Char (')');
2181
2182 when N_String_Literal =>
2183 if String_Length (Strval (Node)) + Column > 75 then
2184 Write_Indent_Str (" ");
2185 end if;
2186
2187 Set_Debug_Sloc;
2188 Write_String_Table_Entry (Strval (Node));
2189
2190 when N_Subprogram_Body =>
2191 if Freeze_Indent = 0 then
2192 Write_Indent;
2193 end if;
2194
2195 Write_Indent;
2196 Sprint_Node_Sloc (Specification (Node));
2197 Write_Str (" is");
2198
2199 Sprint_Indented_List (Declarations (Node));
2200 Write_Indent_Str ("begin");
2201 Sprint_Node (Handled_Statement_Sequence (Node));
2202
2203 Write_Indent_Str ("end ");
2204 Sprint_Node (Defining_Unit_Name (Specification (Node)));
2205 Write_Char (';');
2206
2207 if Is_List_Member (Node)
2208 and then Present (Next (Node))
2209 and then Nkind (Next (Node)) /= N_Subprogram_Body
2210 then
2211 Write_Indent;
2212 end if;
2213
2214 when N_Subprogram_Body_Stub =>
2215 Write_Indent;
2216 Sprint_Node_Sloc (Specification (Node));
2217 Write_Str_With_Col_Check (" is separate;");
2218
2219 when N_Subprogram_Declaration =>
2220 Write_Indent;
2221 Sprint_Node_Sloc (Specification (Node));
2222 Write_Char (';');
2223
2224 when N_Subprogram_Info =>
2225 Sprint_Node (Identifier (Node));
2226 Write_Str_With_Col_Check_Sloc ("'subprogram_info");
2227
2228 when N_Subprogram_Renaming_Declaration =>
2229 Write_Indent;
2230 Sprint_Node (Specification (Node));
2231 Write_Str_With_Col_Check_Sloc (" renames ");
2232 Sprint_Node (Name (Node));
2233 Write_Char (';');
2234
2235 when N_Subtype_Declaration =>
2236 Write_Indent_Str_Sloc ("subtype ");
2237 Write_Id (Defining_Identifier (Node));
2238 Write_Str (" is ");
2239 Sprint_Node (Subtype_Indication (Node));
2240 Write_Char (';');
2241
2242 when N_Subtype_Indication =>
2243 Sprint_Node_Sloc (Subtype_Mark (Node));
2244 Write_Char (' ');
2245 Sprint_Node (Constraint (Node));
2246
2247 when N_Subunit =>
2248 Write_Indent_Str_Sloc ("separate (");
2249 Sprint_Node (Name (Node));
2250 Write_Char (')');
2251 Print_Eol;
2252 Sprint_Node (Proper_Body (Node));
2253
2254 when N_Task_Body =>
2255 Write_Indent_Str_Sloc ("task body ");
2256 Write_Id (Defining_Identifier (Node));
2257 Write_Str (" is");
2258 Sprint_Indented_List (Declarations (Node));
2259 Write_Indent_Str ("begin");
2260 Sprint_Node (Handled_Statement_Sequence (Node));
2261 Write_Indent_Str ("end ");
2262 Write_Id (Defining_Identifier (Node));
2263 Write_Char (';');
2264
2265 when N_Task_Body_Stub =>
2266 Write_Indent_Str_Sloc ("task body ");
2267 Write_Id (Defining_Identifier (Node));
2268 Write_Str_With_Col_Check (" is separate;");
2269
2270 when N_Task_Definition =>
2271 Set_Debug_Sloc;
2272 Sprint_Indented_List (Visible_Declarations (Node));
2273
2274 if Present (Private_Declarations (Node)) then
2275 Write_Indent_Str ("private");
2276 Sprint_Indented_List (Private_Declarations (Node));
2277 end if;
2278
2279 Write_Indent_Str ("end ");
2280
2281 when N_Task_Type_Declaration =>
2282 Write_Indent_Str_Sloc ("task type ");
2283 Write_Id (Defining_Identifier (Node));
2284 Write_Discr_Specs (Node);
2285 if Present (Task_Definition (Node)) then
2286 Write_Str (" is");
2287 Sprint_Node (Task_Definition (Node));
2288 Write_Id (Defining_Identifier (Node));
2289 end if;
2290
2291 Write_Char (';');
2292
2293 when N_Terminate_Alternative =>
2294 Sprint_Node_List (Pragmas_Before (Node));
2295
2296 Write_Indent;
2297
2298 if Present (Condition (Node)) then
2299 Write_Str_With_Col_Check ("when ");
2300 Sprint_Node (Condition (Node));
2301 Write_Str (" => ");
2302 end if;
2303
2304 Write_Str_With_Col_Check_Sloc ("terminate;");
2305 Sprint_Node_List (Pragmas_After (Node));
2306
2307 when N_Timed_Entry_Call =>
2308 Write_Indent_Str_Sloc ("select");
2309 Indent_Begin;
2310 Sprint_Node (Entry_Call_Alternative (Node));
2311 Indent_End;
2312 Write_Indent_Str ("or");
2313 Indent_Begin;
2314 Sprint_Node (Delay_Alternative (Node));
2315 Indent_End;
2316 Write_Indent_Str ("end select;");
2317
2318 when N_Triggering_Alternative =>
2319 Sprint_Node_List (Pragmas_Before (Node));
2320 Sprint_Node_Sloc (Triggering_Statement (Node));
2321 Sprint_Node_List (Statements (Node));
2322
2323 when N_Type_Conversion =>
2324 Set_Debug_Sloc;
2325 Sprint_Node (Subtype_Mark (Node));
2326 Col_Check (4);
2327
2328 if Conversion_OK (Node) then
2329 Write_Char ('?');
2330 end if;
2331
2332 if Float_Truncate (Node) then
2333 Write_Char ('^');
2334 end if;
2335
2336 if Rounded_Result (Node) then
2337 Write_Char ('@');
2338 end if;
2339
2340 Write_Char ('(');
2341 Sprint_Node (Expression (Node));
2342 Write_Char (')');
2343
2344 when N_Unchecked_Expression =>
2345 Col_Check (10);
2346 Write_Str ("`(");
2347 Sprint_Node_Sloc (Expression (Node));
2348 Write_Char (')');
2349
2350 when N_Unchecked_Type_Conversion =>
2351 Sprint_Node (Subtype_Mark (Node));
2352 Write_Char ('!');
2353 Write_Str_With_Col_Check ("(");
2354 Sprint_Node_Sloc (Expression (Node));
2355 Write_Char (')');
2356
2357 when N_Unconstrained_Array_Definition =>
2358 Write_Str_With_Col_Check_Sloc ("array (");
2359
2360 declare
2361 Node1 : Node_Id;
2362
2363 begin
2364 Node1 := First (Subtype_Marks (Node));
2365 loop
2366 Sprint_Node (Node1);
2367 Write_Str_With_Col_Check (" range <>");
2368 Next (Node1);
2369 exit when Node1 = Empty;
2370 Write_Str (", ");
2371 end loop;
2372 end;
2373
2374 Write_Str (") of ");
2375
2376 if Aliased_Present (Node) then
2377 Write_Str_With_Col_Check ("aliased ");
2378 end if;
2379
2380 Sprint_Node (Subtype_Indication (Node));
2381
2382 when N_Unused_At_Start | N_Unused_At_End =>
2383 Write_Indent_Str ("***** Error, unused node encountered *****");
2384 Print_Eol;
2385
2386 when N_Use_Package_Clause =>
2387 Write_Indent_Str_Sloc ("use ");
2388 Sprint_Comma_List (Names (Node));
2389 Write_Char (';');
2390
2391 when N_Use_Type_Clause =>
2392 Write_Indent_Str_Sloc ("use type ");
2393 Sprint_Comma_List (Subtype_Marks (Node));
2394 Write_Char (';');
2395
2396 when N_Validate_Unchecked_Conversion =>
2397 Write_Indent_Str_Sloc ("validate unchecked_conversion (");
2398 Sprint_Node (Source_Type (Node));
2399 Write_Str (", ");
2400 Sprint_Node (Target_Type (Node));
2401 Write_Str (");");
2402
2403 when N_Variant =>
2404 Write_Indent_Str_Sloc ("when ");
2405 Sprint_Bar_List (Discrete_Choices (Node));
2406 Write_Str (" => ");
2407 Sprint_Node (Component_List (Node));
2408
2409 when N_Variant_Part =>
2410 Indent_Begin;
2411 Write_Indent_Str_Sloc ("case ");
2412 Sprint_Node (Name (Node));
2413 Write_Str (" is ");
2414 Sprint_Indented_List (Variants (Node));
2415 Write_Indent_Str ("end case");
2416 Indent_End;
2417
2418 when N_With_Clause =>
2419
2420 -- Special test, if we are dumping the original tree only,
2421 -- then we want to eliminate the bogus with clauses that
2422 -- correspond to the non-existent children of Text_IO.
2423
2424 if Dump_Original_Only
2425 and then Is_Text_IO_Kludge_Unit (Name (Node))
2426 then
2427 null;
2428
2429 -- Normal case, output the with clause
2430
2431 else
2432 if First_Name (Node) or else not Dump_Original_Only then
2433 Write_Indent_Str ("with ");
2434 else
2435 Write_Str (", ");
2436 end if;
2437
2438 Sprint_Node_Sloc (Name (Node));
2439
2440 if Last_Name (Node) or else not Dump_Original_Only then
2441 Write_Char (';');
2442 end if;
2443 end if;
2444
2445 when N_With_Type_Clause =>
2446
2447 Write_Indent_Str ("with type ");
2448 Sprint_Node_Sloc (Name (Node));
2449
2450 if Tagged_Present (Node) then
2451 Write_Str (" is tagged;");
2452 else
2453 Write_Str (" is access;");
2454 end if;
2455
2456 end case;
2457
2458 if Nkind (Node) in N_Subexpr
2459 and then Do_Range_Check (Node)
2460 then
2461 Write_Str ("}");
2462 end if;
2463
2464 for J in 1 .. Paren_Count (Node) loop
2465 Write_Char (')');
2466 end loop;
2467
2468 pragma Assert (No (Debug_Node));
2469 Debug_Node := Save_Debug_Node;
2470 end Sprint_Node_Actual;
2471
2472 ----------------------
2473 -- Sprint_Node_List --
2474 ----------------------
2475
2476 procedure Sprint_Node_List (List : List_Id) is
2477 Node : Node_Id;
2478
2479 begin
2480 if Is_Non_Empty_List (List) then
2481 Node := First (List);
2482
2483 loop
2484 Sprint_Node (Node);
2485 Next (Node);
2486 exit when Node = Empty;
2487 end loop;
2488 end if;
2489 end Sprint_Node_List;
2490
2491 ----------------------
2492 -- Sprint_Node_Sloc --
2493 ----------------------
2494
2495 procedure Sprint_Node_Sloc (Node : Node_Id) is
2496 begin
2497 Sprint_Node (Node);
2498
2499 if Present (Debug_Node) then
2500 Set_Sloc (Debug_Node, Sloc (Node));
2501 Debug_Node := Empty;
2502 end if;
2503 end Sprint_Node_Sloc;
2504
2505 ---------------------
2506 -- Sprint_Opt_Node --
2507 ---------------------
2508
2509 procedure Sprint_Opt_Node (Node : Node_Id) is
2510 begin
2511 if Present (Node) then
2512 Write_Char (' ');
2513 Sprint_Node (Node);
2514 end if;
2515 end Sprint_Opt_Node;
2516
2517 --------------------------
2518 -- Sprint_Opt_Node_List --
2519 --------------------------
2520
2521 procedure Sprint_Opt_Node_List (List : List_Id) is
2522 begin
2523 if Present (List) then
2524 Sprint_Node_List (List);
2525 end if;
2526 end Sprint_Opt_Node_List;
2527
2528 ---------------------------------
2529 -- Sprint_Opt_Paren_Comma_List --
2530 ---------------------------------
2531
2532 procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is
2533 begin
2534 if Is_Non_Empty_List (List) then
2535 Write_Char (' ');
2536 Sprint_Paren_Comma_List (List);
2537 end if;
2538 end Sprint_Opt_Paren_Comma_List;
2539
2540 -----------------------------
2541 -- Sprint_Paren_Comma_List --
2542 -----------------------------
2543
2544 procedure Sprint_Paren_Comma_List (List : List_Id) is
2545 N : Node_Id;
2546 Node_Exists : Boolean := False;
2547
2548 begin
2549
2550 if Is_Non_Empty_List (List) then
2551
2552 if Dump_Original_Only then
2553 N := First (List);
2554
2555 while Present (N) loop
2556
2557 if not Is_Rewrite_Insertion (N) then
2558 Node_Exists := True;
2559 exit;
2560 end if;
2561
2562 Next (N);
2563 end loop;
2564
2565 if not Node_Exists then
2566 return;
2567 end if;
2568 end if;
2569
2570 Write_Str_With_Col_Check ("(");
2571 Sprint_Comma_List (List);
2572 Write_Char (')');
2573 end if;
2574 end Sprint_Paren_Comma_List;
2575
2576 ---------------------
2577 -- Write_Char_Sloc --
2578 ---------------------
2579
2580 procedure Write_Char_Sloc (C : Character) is
2581 begin
2582 if Debug_Generated_Code and then C /= ' ' then
2583 Set_Debug_Sloc;
2584 end if;
2585
2586 Write_Char (C);
2587 end Write_Char_Sloc;
2588
2589 ------------------------
2590 -- Write_Discr_Specs --
2591 ------------------------
2592
2593 procedure Write_Discr_Specs (N : Node_Id) is
2594 Specs : List_Id;
2595 Spec : Node_Id;
2596
2597 begin
2598 Specs := Discriminant_Specifications (N);
2599
2600 if Present (Specs) then
2601 Write_Str_With_Col_Check (" (");
2602 Spec := First (Specs);
2603
2604 loop
2605 Sprint_Node (Spec);
2606 Next (Spec);
2607 exit when Spec = Empty;
2608
2609 -- Add semicolon, unless we are printing original tree and the
2610 -- next specification is part of a list (but not the first
2611 -- element of that list)
2612
2613 if not Dump_Original_Only or else not Prev_Ids (Spec) then
2614 Write_Str ("; ");
2615 end if;
2616 end loop;
2617
2618 Write_Char (')');
2619 end if;
2620 end Write_Discr_Specs;
2621
2622 -----------------
2623 -- Write_Ekind --
2624 -----------------
2625
2626 procedure Write_Ekind (E : Entity_Id) is
2627 S : constant String := Entity_Kind'Image (Ekind (E));
2628
2629 begin
2630 Name_Len := S'Length;
2631 Name_Buffer (1 .. Name_Len) := S;
2632 Set_Casing (Mixed_Case);
2633 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
2634 end Write_Ekind;
2635
2636 --------------
2637 -- Write_Id --
2638 --------------
2639
2640 procedure Write_Id (N : Node_Id) is
2641 begin
2642 -- Case of a defining identifier
2643
2644 if Nkind (N) = N_Defining_Identifier then
2645
2646 -- If defining identifier has an interface name (and no
2647 -- address clause), then we output the interface name.
2648
2649 if (Is_Imported (N) or else Is_Exported (N))
2650 and then Present (Interface_Name (N))
2651 and then No (Address_Clause (N))
2652 then
2653 String_To_Name_Buffer (Strval (Interface_Name (N)));
2654 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
2655
2656 -- If no interface name (or inactive because there was
2657 -- an address clause), then just output the Chars name.
2658
2659 else
2660 Write_Name_With_Col_Check (Chars (N));
2661 end if;
2662
2663 -- Case of selector of an expanded name where the expanded name
2664 -- has an associated entity, output this entity.
2665
2666 elsif Nkind (Parent (N)) = N_Expanded_Name
2667 and then Selector_Name (Parent (N)) = N
2668 and then Present (Entity (Parent (N)))
2669 then
2670 Write_Id (Entity (Parent (N)));
2671
2672 -- For any other kind of node with an associated entity, output it.
2673
2674 elsif Nkind (N) in N_Has_Entity
2675 and then Present (Entity (N))
2676 then
2677 Write_Id (Entity (N));
2678
2679 -- All other cases, we just print the Chars field
2680
2681 else
2682 Write_Name_With_Col_Check (Chars (N));
2683 end if;
2684 end Write_Id;
2685
2686 -----------------------
2687 -- Write_Identifiers --
2688 -----------------------
2689
2690 function Write_Identifiers (Node : Node_Id) return Boolean is
2691 begin
2692 Sprint_Node (Defining_Identifier (Node));
2693
2694 -- The remainder of the declaration must be printed unless we are
2695 -- printing the original tree and this is not the last identifier
2696
2697 return
2698 not Dump_Original_Only or else not More_Ids (Node);
2699
2700 end Write_Identifiers;
2701
2702 ------------------------
2703 -- Write_Implicit_Def --
2704 ------------------------
2705
2706 procedure Write_Implicit_Def (E : Entity_Id) is
2707 Ind : Node_Id;
2708
2709 begin
2710 case Ekind (E) is
2711 when E_Array_Subtype =>
2712 Write_Str_With_Col_Check ("subtype ");
2713 Write_Id (E);
2714 Write_Str_With_Col_Check (" is ");
2715 Write_Id (Base_Type (E));
2716 Write_Str_With_Col_Check (" (");
2717
2718 Ind := First_Index (E);
2719
2720 while Present (Ind) loop
2721 Sprint_Node (Ind);
2722 Next_Index (Ind);
2723
2724 if Present (Ind) then
2725 Write_Str (", ");
2726 end if;
2727 end loop;
2728
2729 Write_Str (");");
2730
2731 when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
2732 Write_Str_With_Col_Check ("subtype ");
2733 Write_Id (E);
2734 Write_Str (" is ");
2735 Write_Id (Etype (E));
2736 Write_Str_With_Col_Check (" range ");
2737 Sprint_Node (Scalar_Range (E));
2738 Write_Str (";");
2739
2740 when others =>
2741 Write_Str_With_Col_Check ("type ");
2742 Write_Id (E);
2743 Write_Str_With_Col_Check (" is <");
2744 Write_Ekind (E);
2745 Write_Str (">;");
2746 end case;
2747
2748 end Write_Implicit_Def;
2749
2750 ------------------
2751 -- Write_Indent --
2752 ------------------
2753
2754 procedure Write_Indent is
2755 begin
2756 if Indent_Annull_Flag then
2757 Indent_Annull_Flag := False;
2758 else
2759 Print_Eol;
2760 for J in 1 .. Indent loop
2761 Write_Char (' ');
2762 end loop;
2763 end if;
2764 end Write_Indent;
2765
2766 ------------------------------
2767 -- Write_Indent_Identifiers --
2768 ------------------------------
2769
2770 function Write_Indent_Identifiers (Node : Node_Id) return Boolean is
2771 begin
2772 -- We need to start a new line for every node, except in the case
2773 -- where we are printing the original tree and this is not the first
2774 -- defining identifier in the list.
2775
2776 if not Dump_Original_Only or else not Prev_Ids (Node) then
2777 Write_Indent;
2778
2779 -- If printing original tree and this is not the first defining
2780 -- identifier in the list, then the previous call to this procedure
2781 -- printed only the name, and we add a comma to separate the names.
2782
2783 else
2784 Write_Str (", ");
2785 end if;
2786
2787 Sprint_Node (Defining_Identifier (Node));
2788
2789 -- The remainder of the declaration must be printed unless we are
2790 -- printing the original tree and this is not the last identifier
2791
2792 return
2793 not Dump_Original_Only or else not More_Ids (Node);
2794
2795 end Write_Indent_Identifiers;
2796
2797 -----------------------------------
2798 -- Write_Indent_Identifiers_Sloc --
2799 -----------------------------------
2800
2801 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is
2802 begin
2803 -- We need to start a new line for every node, except in the case
2804 -- where we are printing the original tree and this is not the first
2805 -- defining identifier in the list.
2806
2807 if not Dump_Original_Only or else not Prev_Ids (Node) then
2808 Write_Indent;
2809
2810 -- If printing original tree and this is not the first defining
2811 -- identifier in the list, then the previous call to this procedure
2812 -- printed only the name, and we add a comma to separate the names.
2813
2814 else
2815 Write_Str (", ");
2816 end if;
2817
2818 Set_Debug_Sloc;
2819 Sprint_Node (Defining_Identifier (Node));
2820
2821 -- The remainder of the declaration must be printed unless we are
2822 -- printing the original tree and this is not the last identifier
2823
2824 return
2825 not Dump_Original_Only or else not More_Ids (Node);
2826
2827 end Write_Indent_Identifiers_Sloc;
2828
2829 ----------------------
2830 -- Write_Indent_Str --
2831 ----------------------
2832
2833 procedure Write_Indent_Str (S : String) is
2834 begin
2835 Write_Indent;
2836 Write_Str (S);
2837 end Write_Indent_Str;
2838
2839 ---------------------------
2840 -- Write_Indent_Str_Sloc --
2841 ---------------------------
2842
2843 procedure Write_Indent_Str_Sloc (S : String) is
2844 begin
2845 Write_Indent;
2846 Write_Str_Sloc (S);
2847 end Write_Indent_Str_Sloc;
2848
2849 -------------------------------
2850 -- Write_Name_With_Col_Check --
2851 -------------------------------
2852
2853 procedure Write_Name_With_Col_Check (N : Name_Id) is
2854 J : Natural;
2855
2856 begin
2857 Get_Name_String (N);
2858
2859 -- Deal with -gnatI which replaces digits in an internal
2860 -- name by three dots (e.g. R7b becomes R...b).
2861
2862 if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then
2863
2864 J := 2;
2865 while J < Name_Len loop
2866 exit when Name_Buffer (J) not in 'A' .. 'Z';
2867 J := J + 1;
2868 end loop;
2869
2870 if Name_Buffer (J) in '0' .. '9' then
2871 Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1));
2872 Write_Str ("...");
2873
2874 while J <= Name_Len loop
2875 if Name_Buffer (J) not in '0' .. '9' then
2876 Write_Str (Name_Buffer (J .. Name_Len));
2877 exit;
2878
2879 else
2880 J := J + 1;
2881 end if;
2882 end loop;
2883
2884 return;
2885 end if;
2886 end if;
2887
2888 -- Fall through for normal case
2889
2890 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len));
2891 end Write_Name_With_Col_Check;
2892
2893 ------------------------------------
2894 -- Write_Name_With_Col_Check_Sloc --
2895 ------------------------------------
2896
2897 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is
2898 begin
2899 Get_Name_String (N);
2900 Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len));
2901 end Write_Name_With_Col_Check_Sloc;
2902
2903 --------------------
2904 -- Write_Operator --
2905 --------------------
2906
2907 procedure Write_Operator (N : Node_Id; S : String) is
2908 F : Natural := S'First;
2909 T : Natural := S'Last;
2910
2911 begin
2912 if S (F) = ' ' then
2913 Write_Char (' ');
2914 F := F + 1;
2915 end if;
2916
2917 if S (T) = ' ' then
2918 T := T - 1;
2919 end if;
2920
2921 if Do_Overflow_Check (N) then
2922 Write_Char ('{');
2923 Write_Str_Sloc (S (F .. T));
2924 Write_Char ('}');
2925 else
2926 Write_Str_Sloc (S);
2927 end if;
2928
2929 if S (S'Last) = ' ' then
2930 Write_Char (' ');
2931 end if;
2932 end Write_Operator;
2933
2934 -----------------------
2935 -- Write_Param_Specs --
2936 -----------------------
2937
2938 procedure Write_Param_Specs (N : Node_Id) is
2939 Specs : List_Id;
2940 Spec : Node_Id;
2941 Formal : Node_Id;
2942
2943 begin
2944 Specs := Parameter_Specifications (N);
2945
2946 if Is_Non_Empty_List (Specs) then
2947 Write_Str_With_Col_Check (" (");
2948 Spec := First (Specs);
2949
2950 loop
2951 Sprint_Node (Spec);
2952 Formal := Defining_Identifier (Spec);
2953 Next (Spec);
2954 exit when Spec = Empty;
2955
2956 -- Add semicolon, unless we are printing original tree and the
2957 -- next specification is part of a list (but not the first
2958 -- element of that list)
2959
2960 if not Dump_Original_Only or else not Prev_Ids (Spec) then
2961 Write_Str ("; ");
2962 end if;
2963 end loop;
2964
2965 -- Write out any extra formals
2966
2967 while Present (Extra_Formal (Formal)) loop
2968 Formal := Extra_Formal (Formal);
2969 Write_Str ("; ");
2970 Write_Name_With_Col_Check (Chars (Formal));
2971 Write_Str (" : ");
2972 Write_Name_With_Col_Check (Chars (Etype (Formal)));
2973 end loop;
2974
2975 Write_Char (')');
2976 end if;
2977 end Write_Param_Specs;
2978
2979 --------------------------
2980 -- Write_Rewrite_Str --
2981 --------------------------
2982
2983 procedure Write_Rewrite_Str (S : String) is
2984 begin
2985 if not Dump_Generated_Only then
2986 if S'Length = 3 and then S = ">>>" then
2987 Write_Str (">>>");
2988 else
2989 Write_Str_With_Col_Check (S);
2990 end if;
2991 end if;
2992 end Write_Rewrite_Str;
2993
2994 --------------------
2995 -- Write_Str_Sloc --
2996 --------------------
2997
2998 procedure Write_Str_Sloc (S : String) is
2999 begin
3000 for J in S'Range loop
3001 Write_Char_Sloc (S (J));
3002 end loop;
3003 end Write_Str_Sloc;
3004
3005 ------------------------------
3006 -- Write_Str_With_Col_Check --
3007 ------------------------------
3008
3009 procedure Write_Str_With_Col_Check (S : String) is
3010 begin
3011 if Int (S'Last) + Column > Line_Limit then
3012 Write_Indent_Str (" ");
3013
3014 if S (1) = ' ' then
3015 Write_Str (S (2 .. S'Length));
3016 else
3017 Write_Str (S);
3018 end if;
3019
3020 else
3021 Write_Str (S);
3022 end if;
3023 end Write_Str_With_Col_Check;
3024
3025 -----------------------------------
3026 -- Write_Str_With_Col_Check_Sloc --
3027 -----------------------------------
3028
3029 procedure Write_Str_With_Col_Check_Sloc (S : String) is
3030 begin
3031 if Int (S'Last) + Column > Line_Limit then
3032 Write_Indent_Str (" ");
3033
3034 if S (1) = ' ' then
3035 Write_Str_Sloc (S (2 .. S'Length));
3036 else
3037 Write_Str_Sloc (S);
3038 end if;
3039
3040 else
3041 Write_Str_Sloc (S);
3042 end if;
3043 end Write_Str_With_Col_Check_Sloc;
3044
3045 ------------------------------------
3046 -- Write_Uint_With_Col_Check_Sloc --
3047 ------------------------------------
3048
3049 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is
3050 begin
3051 Col_Check (UI_Decimal_Digits_Hi (U));
3052 Set_Debug_Sloc;
3053 UI_Write (U, Format);
3054 end Write_Uint_With_Col_Check_Sloc;
3055
3056 -------------------------------------
3057 -- Write_Ureal_With_Col_Check_Sloc --
3058 -------------------------------------
3059
3060 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is
3061 D : constant Uint := Denominator (U);
3062 N : constant Uint := Numerator (U);
3063
3064 begin
3065 Col_Check
3066 (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4);
3067 Set_Debug_Sloc;
3068 UR_Write (U);
3069 end Write_Ureal_With_Col_Check_Sloc;
3070
3071 end Sprint;
Mirror of the offical gcc git repository hosted at gcc.gnu.org