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