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