1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Csets
; use Csets
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
38 with Output
; use Output
;
39 with Rtsfind
; use Rtsfind
;
40 with Sem_Eval
; use Sem_Eval
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
44 with Sinfo
.Utils
; use Sinfo
.Utils
;
45 with Sinput
; use Sinput
;
46 with Sinput
.D
; use Sinput
.D
;
47 with Snames
; use Snames
;
48 with Stand
; use Stand
;
49 with Stringt
; use Stringt
;
50 with Uintp
; use Uintp
;
51 with Uname
; use Uname
;
52 with Urealp
; use Urealp
;
54 package body Sprint
is
55 Current_Source_File
: Source_File_Index
;
56 -- Index of source file whose generated code is being dumped
58 Dump_Node
: Node_Id
:= Empty
;
59 -- This is set to the current node, used for printing line numbers. In
60 -- Debug_Generated_Code mode, Dump_Node is set to the current node
61 -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
62 -- value. The call clears it back to Empty.
64 First_Debug_Sloc
: Source_Ptr
;
65 -- Sloc of first byte of the current output file if we are generating a
68 Debug_Sloc
: Source_Ptr
;
69 -- Sloc of first byte of line currently being written if we are
70 -- generating a source debug file.
72 Dump_Original_Only
: Boolean;
73 -- Set True if the -gnatdo (dump original tree) flag is set
75 Dump_Generated_Only
: Boolean;
76 -- Set True if the -gnatdG (dump generated tree) debug flag is set
77 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
79 Dump_Freeze_Null
: Boolean;
80 -- Set True if empty freeze nodes and non-source null statements output.
81 -- Note that freeze nodes containing freeze actions are always output,
82 -- as are freeze nodes for itypes, which in general have the effect of
83 -- causing elaboration of the itype.
85 Freeze_Indent
: Int
:= 0;
86 -- Keep track of freeze indent level (controls output of blank lines before
87 -- procedures within expression freeze actions). Relevant only if we are
88 -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
89 -- output these blank lines in any case.
92 -- Number of columns for current line output indentation
94 Indent_Annull_Flag
: Boolean := False;
95 -- Set True if subsequent Write_Indent call to be ignored, gets reset
96 -- by this call, so it is only active to suppress a single indent call.
98 Last_Line_Printed
: Physical_Line_Number
;
99 -- This keeps track of the physical line number of the last source line
100 -- that has been output. The value is only valid in Dump_Source_Text mode.
102 -------------------------------
103 -- Operator Precedence Table --
104 -------------------------------
106 -- This table is used to decide whether a subexpression needs to be
107 -- parenthesized. The rule is that if an operand of an operator (which
108 -- for this purpose includes AND THEN and OR ELSE) is itself an operator
109 -- with a lower precedence than the operator (or equal precedence if
110 -- appearing as the right operand), then parentheses are required.
112 Op_Prec
: constant array (N_Subexpr
) of Short_Short_Integer :=
145 procedure Sprint_Left_Opnd
(N
: Node_Id
);
146 -- Print left operand of operator, parenthesizing if necessary
148 procedure Sprint_Right_Opnd
(N
: Node_Id
);
149 -- Print right operand of operator, parenthesizing if necessary
151 -----------------------
152 -- Local Subprograms --
153 -----------------------
155 procedure Col_Check
(N
: Nat
);
156 -- Check that at least N characters remain on current line, and if not,
157 -- then start an extra line with two characters extra indentation for
158 -- continuing text on the next line.
160 procedure Extra_Blank_Line
;
161 -- In some situations we write extra blank lines to separate the generated
162 -- code to make it more readable. However, these extra blank lines are not
163 -- generated in Dump_Source_Text mode, since there the source text lines
164 -- output with preceding blank lines are quite sufficient as separators.
165 -- This procedure writes a blank line if Dump_Source_Text is False.
167 procedure Indent_Annull
;
168 -- Causes following call to Write_Indent to be ignored. This is used when
169 -- a higher level node wants to stop a lower level node from starting a
170 -- new line, when it would otherwise be inclined to do so (e.g. the case
171 -- of an accept statement called from an accept alternative with a guard)
173 procedure Indent_Begin
;
174 -- Increase indentation level
176 procedure Indent_End
;
177 -- Decrease indentation level
179 procedure Print_Debug_Line
(S
: String);
180 -- Used to print output lines in Debug_Generated_Code mode (this is used
181 -- as the argument for a call to Set_Special_Output in package Output).
183 procedure Set_Debug_Sloc
;
184 -- If Dump_Node is non-empty, this routine sets the appropriate value
185 -- in its Sloc field, from the current location in the debug source file
186 -- that is currently being written.
188 procedure Sprint_And_List
(List
: List_Id
);
189 -- Print the given list with items separated by vertical "and"
191 procedure Sprint_Aspect_Specifications
193 Semicolon
: Boolean);
194 -- Node is a declaration node that has aspect specifications (Has_Aspects
195 -- flag set True). It outputs the aspect specifications. For the case
196 -- of Semicolon = True, it is called after outputting the terminating
197 -- semicolon for the related node. The effect is to remove the semicolon
198 -- and print the aspect specifications followed by a terminating semicolon.
199 -- For the case of Semicolon False, no semicolon is removed or output, and
200 -- all the aspects are printed on a single line.
202 procedure Sprint_Bar_List
(List
: List_Id
);
203 -- Print the given list with items separated by vertical bars
205 procedure Sprint_End_Label
208 -- Print the end label for a Handled_Sequence_Of_Statements in a body.
209 -- If there is no end label, use the defining identifier of the enclosing
210 -- construct. If the end label is present, treat it as a reference to the
211 -- defining entity of the construct: this guarantees that it carries the
212 -- proper sloc information for debugging purposes.
214 procedure Sprint_Node_Actual
(Node
: Node_Id
);
215 -- This routine prints its node argument. It is a lower level routine than
216 -- Sprint_Node, in that it does not bother about rewritten trees.
218 procedure Sprint_Node_Sloc
(Node
: Node_Id
);
219 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
220 -- sets the Sloc of the current debug node to be a copy of the Sloc
221 -- of the sprinted node Node. Note that this is done after printing
222 -- Node, so that the Sloc is the proper updated value for the debug file.
224 procedure Update_Itype
(Node
: Node_Id
);
225 -- Update the Sloc of an itype that is not attached to the tree, when
226 -- debugging expanded code. This routine is called from nodes whose
227 -- type can be an Itype, such as defining_identifiers that may be of
228 -- an anonymous access type, or ranges in slices.
230 procedure Write_Char_Sloc
(C
: Character);
231 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
232 -- called to ensure that the current node has a proper Sloc set.
234 procedure Write_Condition_And_Reason
(Node
: Node_Id
);
235 -- Write Condition and Reason codes of Raise_xxx_Error node
237 procedure Write_Corresponding_Source
(S
: String);
238 -- If S is a string with a single keyword (possibly followed by a space),
239 -- and if the next non-comment non-blank source line matches this keyword,
240 -- then output all source lines up to this matching line.
242 procedure Write_Discr_Specs
(N
: Node_Id
);
243 -- Output discriminant specification for node, which is any of the type
244 -- declarations that can have discriminants.
246 procedure Write_Ekind
(E
: Entity_Id
);
247 -- Write the String corresponding to the Ekind without "E_"
249 procedure Write_Id
(N
: Node_Id
);
250 -- N is a node with a Chars field. This procedure writes the name that
251 -- will be used in the generated code associated with the name. For a
252 -- node with no associated entity, this is simply the Chars field. For
253 -- the case where there is an entity associated with the node, we print
254 -- the name associated with the entity (since it may have been encoded).
255 -- One other special case is that an entity has an active external name
256 -- (i.e. an external name present with no address clause), then this
257 -- external name is output. This procedure also deals with outputting
258 -- declarations of referenced itypes, if not output earlier.
260 function Write_Identifiers
(Node
: Node_Id
) return Boolean;
261 -- Handle node where the grammar has a list of defining identifiers, but
262 -- the tree has a separate declaration for each identifier. Handles the
263 -- printing of the defining identifier, and returns True if the type and
264 -- initialization information is to be printed, False if it is to be
265 -- skipped (the latter case happens when printing defining identifiers
266 -- other than the first in the original tree output case).
268 procedure Write_Implicit_Def
(E
: Entity_Id
);
269 pragma Warnings
(Off
, Write_Implicit_Def
);
270 -- Write the definition of the implicit type E according to its Ekind
271 -- For now a debugging procedure, but might be used in the future.
273 procedure Write_Indent
;
274 -- Start a new line and write indentation spacing
276 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean;
277 -- Like Write_Identifiers except that each new printed declaration
278 -- is at the start of a new line.
280 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean;
281 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
282 -- mode, the Sloc of the current debug node is set to point to the
283 -- first output identifier.
285 procedure Write_Indent_Str
(S
: String);
286 -- Start a new line and write indent spacing followed by given string
288 procedure Write_Indent_Str_Sloc
(S
: String);
289 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
290 -- the Sloc of the current node is set to the first non-blank character
293 procedure Write_Itype
(Typ
: Entity_Id
);
294 -- If Typ is an Itype that has not been written yet, write it. If Typ is
295 -- any other kind of entity or tree node, the call is ignored.
297 procedure Write_Name_With_Col_Check
(N
: Name_Id
);
298 -- Write name (using Write_Name) with initial column check, and possible
299 -- initial Write_Indent (to get new line) if current line is too full.
301 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
);
302 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
303 -- mode, sets Sloc of current debug node to first character of name.
305 procedure Write_Operator
(N
: Node_Id
; S
: String);
306 -- Like Write_Str_Sloc, used for operators, encloses the string in
307 -- characters {} if the Do_Overflow flag is set on the node N.
309 procedure Write_Param_Specs
(N
: Node_Id
);
310 -- Output parameter specifications for node N (which is a subprogram, or
311 -- entry or entry family or access-subprogram-definition, all of which
312 -- have a Parameter_Specifications field).
314 procedure Write_Rewrite_Str
(S
: String);
315 -- Writes out a string (typically containing <<< or >>>}) for a node
316 -- created by rewriting the tree. Suppressed if we are outputting the
317 -- generated code only, since in this case we don't specially mark nodes
318 -- created by rewriting).
320 procedure Write_Source_Line
(L
: Physical_Line_Number
);
321 -- If writing of interspersed source lines is enabled, then write the given
322 -- line from the source file, preceded by Eol, then an extra blank line if
323 -- the line has at least one blank, is not a comment and is not line one,
324 -- then "--" and the line number followed by period followed by text of the
325 -- source line (without terminating Eol). If interspersed source line
326 -- output not enabled, then the call has no effect.
328 procedure Write_Source_Lines
(L
: Physical_Line_Number
);
329 -- If writing of interspersed source lines is enabled, then writes source
330 -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
331 -- interspersed source line output not enabled, then call has no effect.
333 procedure Write_Str_Sloc
(S
: String);
334 -- Like Write_Str, but sets debug Sloc of current debug node to first
335 -- non-blank character if a current debug node is active.
337 procedure Write_Str_With_Col_Check
(S
: String);
338 -- Write string (using Write_Str) with initial column check, and possible
339 -- initial Write_Indent (to get new line) if current line is too full.
341 procedure Write_Str_With_Col_Check_Sloc
(S
: String);
342 -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug
343 -- node to first non-blank character if a current debug node is active.
345 procedure Write_Subprogram_Name
(N
: Node_Id
);
346 -- N is the Name field of a function call or procedure statement call.
347 -- The effect of the call is to output the name, preceded by a $ if the
348 -- call is identified as an implicit call to a run time routine.
350 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
);
351 -- Write Uint (using UI_Write) with initial column check, and possible
352 -- initial Write_Indent (to get new line) if current line is too full.
353 -- The format parameter determines the output format (see UI_Write).
355 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
);
356 -- Write Uint (using UI_Write) with initial column check, and possible
357 -- initial Write_Indent (to get new line) if current line is too full.
358 -- The format parameter determines the output format (see UI_Write).
359 -- In addition, in Debug_Generated_Code mode, sets the current node
360 -- Sloc to the first character of the output value.
362 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
);
363 -- Write Ureal (using same output format as UR_Write) with column checks
364 -- and a possible initial Write_Indent (to get new line) if current line
365 -- is too full. In addition, in Debug_Generated_Code mode, sets the
366 -- current node Sloc to the first character of the output value.
372 procedure Col_Check
(N
: Nat
) is
374 if N
+ Column
> Sprint_Line_Limit
then
375 Write_Indent_Str
(" ");
379 ----------------------
380 -- Extra_Blank_Line --
381 ----------------------
383 procedure Extra_Blank_Line
is
385 if not Dump_Source_Text
then
388 end Extra_Blank_Line
;
394 procedure Indent_Annull
is
396 Indent_Annull_Flag
:= True;
403 procedure Indent_Begin
is
405 Indent
:= Indent
+ 3;
412 procedure Indent_End
is
414 Indent
:= Indent
- 3;
421 procedure pg
(Arg
: Union_Id
) is
423 Dump_Generated_Only
:= True;
424 Dump_Original_Only
:= False;
425 Dump_Freeze_Null
:= True;
426 Current_Source_File
:= No_Source_File
;
430 if Arg
in List_Range
then
431 Sprint_Node_List
(List_Id
(Arg
), New_Lines
=> True);
433 elsif Arg
in Node_Range
then
434 Sprint_Node
(Node_Id
(Arg
));
448 procedure po
(Arg
: Union_Id
) is
450 Dump_Generated_Only
:= False;
451 Dump_Original_Only
:= True;
452 Dump_Freeze_Null
:= False;
453 Current_Source_File
:= No_Source_File
;
457 if Arg
in List_Range
then
458 Sprint_Node_List
(List_Id
(Arg
), New_Lines
=> True);
460 elsif Arg
in Node_Range
then
461 Sprint_Node
(Node_Id
(Arg
));
471 ----------------------
472 -- Print_Debug_Line --
473 ----------------------
475 procedure Print_Debug_Line
(S
: String) is
477 Write_Debug_Line
(S
, Debug_Sloc
);
478 end Print_Debug_Line
;
484 procedure ps
(Arg
: Union_Id
) is
486 Dump_Generated_Only
:= False;
487 Dump_Original_Only
:= False;
488 Dump_Freeze_Null
:= False;
489 Current_Source_File
:= No_Source_File
;
493 if Arg
in List_Range
then
494 Sprint_Node_List
(List_Id
(Arg
), New_Lines
=> True);
496 elsif Arg
in Node_Range
then
497 Sprint_Node
(Node_Id
(Arg
));
511 procedure Set_Debug_Sloc
is
513 if Debug_Generated_Code
and then Present
(Dump_Node
) then
515 Loc
: constant Source_Ptr
:= Sloc
(Dump_Node
);
518 -- Do not change the location of nodes defined in package Standard
519 -- and nodes of pragmas scanned by Targparm.
521 if Loc
<= Standard_Location
then
524 -- Update the location of a node which is part of the current .dg
525 -- output. This situation occurs in comma separated parameter
526 -- declarations since each parameter references the same parameter
527 -- type node (ie. obj1, obj2 : <param-type>).
529 -- Note: This case is needed here since we cannot use the routine
530 -- In_Extended_Main_Code_Unit with nodes whose location is a .dg
533 elsif Loc
>= First_Debug_Sloc
then
534 Set_Sloc
(Dump_Node
, Debug_Sloc
+ Source_Ptr
(Column
- 1));
536 -- Do not change the location of nodes which are not part of the
539 elsif not In_Extended_Main_Code_Unit
(Loc
) then
543 Set_Sloc
(Dump_Node
, Debug_Sloc
+ Source_Ptr
(Column
- 1));
547 -- We do not know the actual end location in the generated code and
548 -- it could be much closer than in the source code, so play safe.
550 if Nkind
(Dump_Node
) in N_Case_Statement | N_If_Statement
then
551 Set_End_Location
(Dump_Node
, Debug_Sloc
+ Source_Ptr
(Column
- 1));
562 procedure Source_Dump
is
565 -- Put underline under string we just printed
571 procedure Underline
is
572 Col
: constant Int
:= Column
;
577 while Col
> Column
loop
584 -- Start of processing for Source_Dump
587 Dump_Generated_Only
:= Debug_Flag_G
or
588 Print_Generated_Code
or
589 Debug_Generated_Code
;
590 Dump_Original_Only
:= Debug_Flag_O
;
591 Dump_Freeze_Null
:= Debug_Flag_S
or Dump_Generated_Only
;
593 -- Note that we turn off the tree dump flags immediately, before
594 -- starting the dump. This avoids generating two copies of the dump
595 -- if an abort occurs after printing the dump, and more importantly,
596 -- avoids an infinite loop if an abort occurs during the dump.
599 Current_Source_File
:= No_Source_File
;
600 Debug_Flag_Z
:= False;
603 Write_Str
("Source recreated from tree of Standard (spec)");
605 Sprint_Node
(Standard_Package_Node
);
610 if Debug_Flag_S
or Dump_Generated_Only
or Dump_Original_Only
then
611 Debug_Flag_G
:= False;
612 Debug_Flag_O
:= False;
613 Debug_Flag_S
:= False;
614 First_Debug_Sloc
:= No_Location
;
616 -- Dump requested units
618 for U
in Main_Unit
.. Last_Unit
loop
619 Current_Source_File
:= Source_Index
(U
);
621 -- Dump all units if -gnatdf set, otherwise dump only the source
622 -- files that are in the extended main source. Note that, if we
623 -- are generating debug files, generating that of the main unit
624 -- has an effect on the outcome of In_Extended_Main_Source_Unit
625 -- because slocs are rewritten, so we also test for equality of
626 -- Cunit_Entity to work around this effect.
629 or else In_Extended_Main_Source_Unit
(Cunit_Entity
(U
))
630 or else Cunit_Entity
(U
) = Cunit_Entity
(Main_Unit
)
632 -- If we are generating debug files, setup to write them
634 if Debug_Generated_Code
then
635 Set_Special_Output
(Print_Debug_Line
'Access);
636 Create_Debug_Source
(Source_Index
(U
), Debug_Sloc
);
637 First_Debug_Sloc
:= Debug_Sloc
;
638 Write_Source_Line
(1);
639 Last_Line_Printed
:= 1;
641 -- If this unit has the same entity as the main unit, for
642 -- example is the spec of a stand-alone instantiation of
643 -- a package and the main unit is the body, its debug file
644 -- will also be the same. Therefore, we need to print again
645 -- the main unit to have both units in the debug file.
648 and then Cunit_Entity
(U
) = Cunit_Entity
(Main_Unit
)
650 Sprint_Node
(Cunit
(Main_Unit
));
654 Sprint_Node
(Cunit
(U
));
655 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
658 Cancel_Special_Output
;
660 -- Normal output to standard output file
663 Write_Str
("Source recreated from tree for ");
664 Write_Unit_Name
(Unit_Name
(U
));
666 Write_Source_Line
(1);
667 Last_Line_Printed
:= 1;
668 Sprint_Node
(Cunit
(U
));
669 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
677 -- See above for the rationale, but we cannot do it earlier for them
679 Print_Generated_Code
:= False;
680 Debug_Generated_Code
:= False;
683 ---------------------
684 -- Sprint_And_List --
685 ---------------------
687 procedure Sprint_And_List
(List
: List_Id
) is
690 if Is_Non_Empty_List
(List
) then
691 Node
:= First
(List
);
695 exit when Node
= Empty
;
701 ----------------------------------
702 -- Sprint_Aspect_Specifications --
703 ----------------------------------
705 procedure Sprint_Aspect_Specifications
709 AS
: constant List_Id
:= Aspect_Specifications
(Node
);
714 Write_Erase_Char
(';');
715 Indent
:= Indent
+ 2;
718 Indent
:= Indent
+ 5;
721 Write_Str
(" with ");
726 Sprint_Node
(Identifier
(A
));
728 if Class_Present
(A
) then
729 Write_Str
("'Class");
732 if Present
(Expression
(A
)) then
734 Sprint_Node
(Expression
(A
));
748 Indent
:= Indent
- 7;
751 end Sprint_Aspect_Specifications
;
753 ---------------------
754 -- Sprint_Bar_List --
755 ---------------------
757 procedure Sprint_Bar_List
(List
: List_Id
) is
760 if Is_Non_Empty_List
(List
) then
761 Node
:= First
(List
);
765 exit when Node
= Empty
;
771 ----------------------
772 -- Sprint_End_Label --
773 ----------------------
775 procedure Sprint_End_Label
781 and then Present
(End_Label
(Node
))
782 and then Is_Entity_Name
(End_Label
(Node
))
784 Set_Entity
(End_Label
(Node
), Default
);
786 -- For a function whose name is an operator, use the qualified name
787 -- created for the defining entity.
789 if Nkind
(End_Label
(Node
)) = N_Operator_Symbol
then
790 Set_Chars
(End_Label
(Node
), Chars
(Default
));
793 Sprint_Node
(End_Label
(Node
));
795 Sprint_Node
(Default
);
797 end Sprint_End_Label
;
799 -----------------------
800 -- Sprint_Comma_List --
801 -----------------------
803 procedure Sprint_Comma_List
(List
: List_Id
) is
807 if Is_Non_Empty_List
(List
) then
808 Node
:= First
(List
);
812 exit when Node
= Empty
;
814 if not Is_Rewrite_Insertion
(Node
)
815 or else not Dump_Original_Only
821 end Sprint_Comma_List
;
823 --------------------------
824 -- Sprint_Indented_List --
825 --------------------------
827 procedure Sprint_Indented_List
(List
: List_Id
) is
830 Sprint_Node_List
(List
);
832 end Sprint_Indented_List
;
834 ---------------------
835 -- Sprint_Left_Opnd --
836 ---------------------
838 procedure Sprint_Left_Opnd
(N
: Node_Id
) is
839 Opnd
: constant Node_Id
:= Left_Opnd
(N
);
842 if Paren_Count
(Opnd
) /= 0
843 or else Op_Prec
(Nkind
(Opnd
)) >= Op_Prec
(Nkind
(N
))
852 end Sprint_Left_Opnd
;
858 procedure Sprint_Node
(Node
: Node_Id
) is
860 if Is_Rewrite_Insertion
(Node
) then
861 if not Dump_Original_Only
then
863 -- For special cases of nodes that always output <<< >>>
864 -- do not duplicate the output at this point.
866 if Nkind
(Node
) = N_Freeze_Entity
867 or else Nkind
(Node
) = N_Freeze_Generic_Entity
868 or else Nkind
(Node
) = N_Implicit_Label_Declaration
870 Sprint_Node_Actual
(Node
);
872 -- Normal case where <<< >>> may be required
875 Write_Rewrite_Str
("<<<");
876 Sprint_Node_Actual
(Node
);
877 Write_Rewrite_Str
(">>>");
881 elsif Is_Rewrite_Substitution
(Node
) then
883 -- Case of dump generated only
885 if Dump_Generated_Only
then
886 Sprint_Node_Actual
(Node
);
888 -- Case of dump original only
890 elsif Dump_Original_Only
then
891 Sprint_Node_Actual
(Original_Node
(Node
));
893 -- Case of both being dumped
896 Sprint_Node_Actual
(Original_Node
(Node
));
897 Write_Rewrite_Str
("<<<");
898 Sprint_Node_Actual
(Node
);
899 Write_Rewrite_Str
(">>>");
903 Sprint_Node_Actual
(Node
);
907 ------------------------
908 -- Sprint_Node_Actual --
909 ------------------------
911 procedure Sprint_Node_Actual
(Node
: Node_Id
) is
912 Save_Dump_Node
: constant Node_Id
:= Dump_Node
;
919 for J
in 1 .. Paren_Count
(Node
) loop
920 Write_Str_With_Col_Check
("(");
923 -- Setup current dump node
927 if Nkind
(Node
) in N_Subexpr
928 and then Do_Range_Check
(Node
)
930 Write_Str_With_Col_Check
("{");
933 -- Select print circuit based on node kind
936 when N_Abort_Statement
=>
937 Write_Indent_Str_Sloc
("abort ");
938 Sprint_Comma_List
(Names
(Node
));
941 when N_Abortable_Part
=>
943 Write_Str_Sloc
("abort ");
944 Sprint_Indented_List
(Statements
(Node
));
946 when N_Abstract_Subprogram_Declaration
=>
948 Sprint_Node
(Specification
(Node
));
949 Write_Str_With_Col_Check
(" is ");
950 Write_Str_Sloc
("abstract;");
952 when N_Accept_Alternative
=>
953 Sprint_Node_List
(Pragmas_Before
(Node
));
955 if Present
(Condition
(Node
)) then
956 Write_Indent_Str
("when ");
957 Sprint_Node
(Condition
(Node
));
962 Sprint_Node_Sloc
(Accept_Statement
(Node
));
963 Sprint_Node_List
(Statements
(Node
));
965 when N_Accept_Statement
=>
966 Write_Indent_Str_Sloc
("accept ");
967 Write_Id
(Entry_Direct_Name
(Node
));
969 if Present
(Entry_Index
(Node
)) then
970 Write_Str_With_Col_Check
(" (");
971 Sprint_Node
(Entry_Index
(Node
));
975 Write_Param_Specs
(Node
);
977 if Present
(Handled_Statement_Sequence
(Node
)) then
978 Write_Str_With_Col_Check
(" do");
979 Sprint_Node
(Handled_Statement_Sequence
(Node
));
980 Write_Indent_Str
("end ");
981 Write_Id
(Entry_Direct_Name
(Node
));
986 when N_Access_Definition
=>
990 if Present
(Access_To_Subprogram_Definition
(Node
)) then
991 Sprint_Node
(Access_To_Subprogram_Definition
(Node
));
995 if Null_Exclusion_Present
(Node
) then
996 Write_Str
("not null ");
999 Write_Str_With_Col_Check_Sloc
("access ");
1001 if All_Present
(Node
) then
1003 elsif Constant_Present
(Node
) then
1004 Write_Str
("constant ");
1007 Sprint_Node
(Subtype_Mark
(Node
));
1010 when N_Access_Function_Definition
=>
1012 -- Ada 2005 (AI-231)
1014 if Null_Exclusion_Present
(Node
) then
1015 Write_Str
("not null ");
1018 Write_Str_With_Col_Check_Sloc
("access ");
1020 if Protected_Present
(Node
) then
1021 Write_Str_With_Col_Check
("protected ");
1024 Write_Str_With_Col_Check
("function");
1025 Write_Param_Specs
(Node
);
1026 Write_Str_With_Col_Check
(" return ");
1027 Sprint_Node
(Result_Definition
(Node
));
1029 when N_Access_Procedure_Definition
=>
1031 -- Ada 2005 (AI-231)
1033 if Null_Exclusion_Present
(Node
) then
1034 Write_Str
("not null ");
1037 Write_Str_With_Col_Check_Sloc
("access ");
1039 if Protected_Present
(Node
) then
1040 Write_Str_With_Col_Check
("protected ");
1043 Write_Str_With_Col_Check
("procedure");
1044 Write_Param_Specs
(Node
);
1046 when N_Access_To_Object_Definition
=>
1047 Write_Str_With_Col_Check_Sloc
("access ");
1049 if All_Present
(Node
) then
1050 Write_Str_With_Col_Check
("all ");
1051 elsif Constant_Present
(Node
) then
1052 Write_Str_With_Col_Check
("constant ");
1055 -- Ada 2005 (AI-231)
1057 if Null_Exclusion_Present
(Node
) then
1058 Write_Str
("not null ");
1061 Sprint_Node
(Subtype_Indication
(Node
));
1064 if Null_Record_Present
(Node
) then
1065 Write_Str_With_Col_Check_Sloc
("(null record)");
1068 Write_Str_With_Col_Check_Sloc
("(");
1070 if Present
(Expressions
(Node
)) then
1071 Sprint_Comma_List
(Expressions
(Node
));
1073 if not Is_Empty_List
(Component_Associations
(Node
)) then
1078 if not Is_Empty_List
(Component_Associations
(Node
)) then
1085 Nd
:= First
(Component_Associations
(Node
));
1093 if not Is_Rewrite_Insertion
(Nd
)
1094 or else not Dump_Original_Only
1108 Write_Str_With_Col_Check_Sloc
("new ");
1110 -- Ada 2005 (AI-231)
1112 if Null_Exclusion_Present
(Node
) then
1113 Write_Str
("not null ");
1116 Sprint_Node
(Expression
(Node
));
1118 if Present
(Storage_Pool
(Node
)) then
1119 Write_Str_With_Col_Check
("[storage_pool = ");
1120 Sprint_Node
(Storage_Pool
(Node
));
1124 if Present
(Procedure_To_Call
(Node
)) then
1125 Write_Str_With_Col_Check
("[procedure_to_call = ");
1126 Sprint_Node
(Procedure_To_Call
(Node
));
1131 Sprint_Left_Opnd
(Node
);
1132 Write_Str_Sloc
(" and then ");
1133 Sprint_Right_Opnd
(Node
);
1135 -- Note: the following code for N_Aspect_Specification is not
1136 -- normally used, since we deal with aspects as part of a
1137 -- declaration, but it is here in case we deliberately try
1138 -- to print an N_Aspect_Specification node (e.g. from GDB).
1140 when N_Aspect_Specification
=>
1141 Sprint_Node
(Identifier
(Node
));
1143 Sprint_Node
(Expression
(Node
));
1145 when N_Assignment_Statement
=>
1147 Sprint_Node
(Name
(Node
));
1148 Write_Str_Sloc
(" := ");
1149 Sprint_Node
(Expression
(Node
));
1152 when N_Asynchronous_Select
=>
1153 Write_Indent_Str_Sloc
("select");
1155 Sprint_Node
(Triggering_Alternative
(Node
));
1158 -- Note: let the printing of Abortable_Part handle outputting
1159 -- the ABORT keyword, so that the Sloc can be set correctly.
1161 Write_Indent_Str
("then ");
1162 Sprint_Node
(Abortable_Part
(Node
));
1163 Write_Indent_Str
("end select;");
1166 Write_Indent_Str_Sloc
("for ");
1167 Write_Id
(Identifier
(Node
));
1168 Write_Str_With_Col_Check
(" use at ");
1169 Sprint_Node
(Expression
(Node
));
1172 when N_Attribute_Definition_Clause
=>
1173 Write_Indent_Str_Sloc
("for ");
1174 Sprint_Node
(Name
(Node
));
1176 Write_Name_With_Col_Check
(Chars
(Node
));
1177 Write_Str_With_Col_Check
(" use ");
1178 Sprint_Node
(Expression
(Node
));
1181 when N_Attribute_Reference
=>
1182 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
1186 Sprint_Node
(Prefix
(Node
));
1187 Write_Char_Sloc
(''');
1188 Write_Name_With_Col_Check
(Attribute_Name
(Node
));
1189 Sprint_Paren_Comma_List
(Expressions
(Node
));
1191 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
1195 when N_Block_Statement
=>
1198 if Present
(Identifier
(Node
))
1199 and then (not Has_Created_Identifier
(Node
)
1200 or else not Dump_Original_Only
)
1202 Write_Rewrite_Str
("<<<");
1203 Write_Id
(Identifier
(Node
));
1205 Write_Rewrite_Str
(">>>");
1208 if Present
(Declarations
(Node
)) then
1209 Write_Str_With_Col_Check_Sloc
("declare");
1210 Sprint_Indented_List
(Declarations
(Node
));
1214 Write_Str_With_Col_Check_Sloc
("begin");
1215 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1216 Write_Indent_Str
("end");
1218 if Present
(Identifier
(Node
))
1219 and then (not Has_Created_Identifier
(Node
)
1220 or else not Dump_Original_Only
)
1222 Write_Rewrite_Str
("<<<");
1224 Write_Id
(Identifier
(Node
));
1225 Write_Rewrite_Str
(">>>");
1230 when N_Call_Marker
=>
1233 -- Enable the following code for debugging purposes only
1235 -- Write_Indent_Str ("#");
1236 -- Write_Id (Target (Node));
1237 -- Write_Char ('#');
1239 when N_Case_Expression
=>
1241 Has_Parens
: constant Boolean := Paren_Count
(Node
) > 0;
1245 -- The syntax for case_expression does not include parentheses,
1246 -- but sometimes parentheses are required, so unconditionally
1247 -- generate them here unless already present.
1249 if not Has_Parens
then
1253 Write_Str_With_Col_Check_Sloc
("case ");
1254 Sprint_Node
(Expression
(Node
));
1255 Write_Str_With_Col_Check
(" is");
1257 Alt
:= First
(Alternatives
(Node
));
1265 if not Has_Parens
then
1270 when N_Case_Expression_Alternative
=>
1271 Write_Str_With_Col_Check
(" when ");
1272 Sprint_Bar_List
(Discrete_Choices
(Node
));
1274 Sprint_Node
(Expression
(Node
));
1276 when N_Case_Statement
=>
1277 Write_Indent_Str_Sloc
("case ");
1278 Sprint_Node
(Expression
(Node
));
1280 Sprint_Indented_List
(Alternatives
(Node
));
1281 Write_Indent_Str
("end case;");
1283 when N_Case_Statement_Alternative
=>
1284 Write_Indent_Str_Sloc
("when ");
1285 Sprint_Bar_List
(Discrete_Choices
(Node
));
1287 Sprint_Indented_List
(Statements
(Node
));
1289 when N_Character_Literal
=>
1290 if Column
> Sprint_Line_Limit
- 2 then
1291 Write_Indent_Str
(" ");
1294 Write_Char_Sloc
(''');
1295 Write_Char_Code
(UI_To_CC
(Char_Literal_Value
(Node
)));
1298 when N_Code_Statement
=>
1301 Sprint_Node
(Expression
(Node
));
1304 when N_Compilation_Unit
=>
1305 Sprint_Node_List
(Context_Items
(Node
));
1306 Sprint_Opt_Node_List
(Declarations
(Aux_Decls_Node
(Node
)));
1308 if Private_Present
(Node
) then
1309 Write_Indent_Str
("private ");
1313 Sprint_Node_Sloc
(Unit
(Node
));
1315 if Present
(Actions
(Aux_Decls_Node
(Node
)))
1317 Present
(Pragmas_After
(Aux_Decls_Node
(Node
)))
1322 Sprint_Opt_Node_List
(Actions
(Aux_Decls_Node
(Node
)));
1323 Sprint_Opt_Node_List
(Pragmas_After
(Aux_Decls_Node
(Node
)));
1325 when N_Compilation_Unit_Aux
=>
1326 null; -- nothing to do, never used, see above
1328 when N_Component_Association
=>
1330 Sprint_Bar_List
(Choices
(Node
));
1333 -- Ada 2005 (AI-287): Print the box if present
1335 if Box_Present
(Node
) then
1336 Write_Str_With_Col_Check
("<>");
1338 Sprint_Node
(Expression
(Node
));
1341 when N_Iterated_Component_Association
=>
1343 Write_Str
(" for ");
1344 Write_Id
(Defining_Identifier
(Node
));
1346 Sprint_Bar_List
(Discrete_Choices
(Node
));
1348 Sprint_Node
(Expression
(Node
));
1350 when N_Iterated_Element_Association
=>
1352 if Present
(Iterator_Specification
(Node
)) then
1353 Sprint_Node
(Iterator_Specification
(Node
));
1355 Sprint_Node
(Loop_Parameter_Specification
(Node
));
1358 if Present
(Key_Expression
(Node
)) then
1359 Write_Str
(" use ");
1360 Sprint_Node
(Key_Expression
(Node
));
1364 Sprint_Node
(Expression
(Node
));
1366 when N_Component_Clause
=>
1368 Sprint_Node
(Component_Name
(Node
));
1369 Write_Str_Sloc
(" at ");
1370 Sprint_Node
(Position
(Node
));
1372 Write_Str_With_Col_Check
("range ");
1373 Sprint_Node
(First_Bit
(Node
));
1375 Sprint_Node
(Last_Bit
(Node
));
1378 when N_Component_Definition
=>
1381 -- Ada 2005 (AI-230): Access definition components
1383 if Present
(Access_Definition
(Node
)) then
1384 Sprint_Node
(Access_Definition
(Node
));
1386 elsif Present
(Subtype_Indication
(Node
)) then
1387 if Aliased_Present
(Node
) then
1388 Write_Str_With_Col_Check
("aliased ");
1391 -- Ada 2005 (AI-231)
1393 if Null_Exclusion_Present
(Node
) then
1394 Write_Str
(" not null ");
1397 Sprint_Node
(Subtype_Indication
(Node
));
1400 Write_Str
(" ??? ");
1403 when N_Component_Declaration
=>
1404 if Write_Indent_Identifiers_Sloc
(Node
) then
1406 Sprint_Node
(Component_Definition
(Node
));
1408 if Present
(Expression
(Node
)) then
1410 Sprint_Node
(Expression
(Node
));
1416 when N_Component_List
=>
1417 if Null_Present
(Node
) then
1419 Write_Indent_Str_Sloc
("null");
1425 Sprint_Indented_List
(Component_Items
(Node
));
1426 Sprint_Node
(Variant_Part
(Node
));
1429 when N_Compound_Statement
=>
1430 Write_Indent_Str
("do");
1432 Sprint_Node_List
(Actions
(Node
));
1434 Write_Indent_Str
("end;");
1436 when N_Conditional_Entry_Call
=>
1437 Write_Indent_Str_Sloc
("select");
1439 Sprint_Node
(Entry_Call_Alternative
(Node
));
1441 Write_Indent_Str
("else");
1442 Sprint_Indented_List
(Else_Statements
(Node
));
1443 Write_Indent_Str
("end select;");
1445 when N_Constrained_Array_Definition
=>
1446 Write_Str_With_Col_Check_Sloc
("array ");
1447 Sprint_Paren_Comma_List
(Discrete_Subtype_Definitions
(Node
));
1450 Sprint_Node
(Component_Definition
(Node
));
1452 -- A contract node should not appear in the tree. It is a semantic
1453 -- node attached to entry and [generic] subprogram entities. But we
1454 -- still provide meaningful output, in case called from the debugger.
1462 Write_Str
("N_Contract node");
1465 Write_Indent_Str
("Pre_Post_Conditions");
1468 P
:= Pre_Post_Conditions
(Node
);
1469 while Present
(P
) loop
1471 P
:= Next_Pragma
(P
);
1477 Write_Indent_Str
("Contract_Test_Cases");
1480 P
:= Contract_Test_Cases
(Node
);
1481 while Present
(P
) loop
1483 P
:= Next_Pragma
(P
);
1489 Write_Indent_Str
("Classifications");
1492 P
:= Classifications
(Node
);
1493 while Present
(P
) loop
1495 P
:= Next_Pragma
(P
);
1503 when N_Decimal_Fixed_Point_Definition
=>
1504 Write_Str_With_Col_Check_Sloc
("delta ");
1505 Sprint_Node
(Delta_Expression
(Node
));
1506 Write_Str_With_Col_Check
(" digits ");
1507 Sprint_Node
(Digits_Expression
(Node
));
1508 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1510 when N_Defining_Character_Literal
=>
1511 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1513 when N_Defining_Identifier
=>
1517 when N_Defining_Operator_Symbol
=>
1518 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1520 when N_Defining_Program_Unit_Name
=>
1522 Sprint_Node
(Name
(Node
));
1524 Write_Id
(Defining_Identifier
(Node
));
1526 when N_Delay_Alternative
=>
1527 Sprint_Node_List
(Pragmas_Before
(Node
));
1529 if Present
(Condition
(Node
)) then
1531 Write_Str_With_Col_Check
("when ");
1532 Sprint_Node
(Condition
(Node
));
1537 Sprint_Node_Sloc
(Delay_Statement
(Node
));
1538 Sprint_Node_List
(Statements
(Node
));
1540 when N_Delay_Relative_Statement
=>
1541 Write_Indent_Str_Sloc
("delay ");
1542 Sprint_Node
(Expression
(Node
));
1545 when N_Delay_Until_Statement
=>
1546 Write_Indent_Str_Sloc
("delay until ");
1547 Sprint_Node
(Expression
(Node
));
1550 when N_Delta_Constraint
=>
1551 Write_Str_With_Col_Check_Sloc
("delta ");
1552 Sprint_Node
(Delta_Expression
(Node
));
1553 Sprint_Opt_Node
(Range_Constraint
(Node
));
1555 when N_Derived_Type_Definition
=>
1556 if Abstract_Present
(Node
) then
1557 Write_Str_With_Col_Check
("abstract ");
1560 Write_Str_With_Col_Check
("new ");
1562 -- Ada 2005 (AI-231)
1564 if Null_Exclusion_Present
(Node
) then
1565 Write_Str_With_Col_Check
("not null ");
1568 Sprint_Node
(Subtype_Indication
(Node
));
1570 if Present
(Interface_List
(Node
)) then
1571 Write_Str_With_Col_Check
(" and ");
1572 Sprint_And_List
(Interface_List
(Node
));
1573 Write_Str_With_Col_Check
(" with ");
1576 if Present
(Record_Extension_Part
(Node
)) then
1577 if No
(Interface_List
(Node
)) then
1578 Write_Str_With_Col_Check
(" with ");
1581 Sprint_Node
(Record_Extension_Part
(Node
));
1584 when N_Designator
=>
1585 Sprint_Node
(Name
(Node
));
1586 Write_Char_Sloc
('.');
1587 Write_Id
(Identifier
(Node
));
1589 when N_Digits_Constraint
=>
1590 Write_Str_With_Col_Check_Sloc
("digits ");
1591 Sprint_Node
(Digits_Expression
(Node
));
1592 Sprint_Opt_Node
(Range_Constraint
(Node
));
1594 when N_Discriminant_Association
=>
1597 if Present
(Selector_Names
(Node
)) then
1598 Sprint_Bar_List
(Selector_Names
(Node
));
1603 Sprint_Node
(Expression
(Node
));
1605 when N_Discriminant_Specification
=>
1608 if Write_Identifiers
(Node
) then
1611 if Null_Exclusion_Present
(Node
) then
1612 Write_Str
("not null ");
1615 Sprint_Node
(Discriminant_Type
(Node
));
1617 if Present
(Expression
(Node
)) then
1619 Sprint_Node
(Expression
(Node
));
1625 when N_Elsif_Part
=>
1626 Write_Indent_Str_Sloc
("elsif ");
1627 Sprint_Node
(Condition
(Node
));
1628 Write_Str_With_Col_Check
(" then");
1629 Sprint_Indented_List
(Then_Statements
(Node
));
1634 when N_Entry_Body
=>
1635 Write_Indent_Str_Sloc
("entry ");
1636 Write_Id
(Defining_Identifier
(Node
));
1637 Sprint_Node
(Entry_Body_Formal_Part
(Node
));
1638 Write_Str_With_Col_Check
(" is");
1639 Sprint_Indented_List
(Declarations
(Node
));
1640 Write_Indent_Str
("begin");
1641 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1642 Write_Indent_Str
("end ");
1643 Write_Id
(Defining_Identifier
(Node
));
1646 when N_Entry_Body_Formal_Part
=>
1647 if Present
(Entry_Index_Specification
(Node
)) then
1648 Write_Str_With_Col_Check_Sloc
(" (");
1649 Sprint_Node
(Entry_Index_Specification
(Node
));
1653 Write_Param_Specs
(Node
);
1654 Write_Str_With_Col_Check_Sloc
(" when ");
1655 Sprint_Node
(Condition
(Node
));
1657 when N_Entry_Call_Alternative
=>
1658 Sprint_Node_List
(Pragmas_Before
(Node
));
1659 Sprint_Node_Sloc
(Entry_Call_Statement
(Node
));
1660 Sprint_Node_List
(Statements
(Node
));
1662 when N_Entry_Call_Statement
=>
1664 Sprint_Node_Sloc
(Name
(Node
));
1665 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
1668 when N_Entry_Declaration
=>
1669 Write_Indent_Str_Sloc
("entry ");
1670 Write_Id
(Defining_Identifier
(Node
));
1672 if Present
(Discrete_Subtype_Definition
(Node
)) then
1673 Write_Str_With_Col_Check
(" (");
1674 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1678 Write_Param_Specs
(Node
);
1681 when N_Entry_Index_Specification
=>
1682 Write_Str_With_Col_Check_Sloc
("for ");
1683 Write_Id
(Defining_Identifier
(Node
));
1684 Write_Str_With_Col_Check
(" in ");
1685 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1687 when N_Enumeration_Representation_Clause
=>
1688 Write_Indent_Str_Sloc
("for ");
1689 Write_Id
(Identifier
(Node
));
1690 Write_Str_With_Col_Check
(" use ");
1691 Sprint_Node
(Array_Aggregate
(Node
));
1694 when N_Enumeration_Type_Definition
=>
1697 -- Skip attempt to print Literals field if it's not there and
1698 -- we are in package Standard (case of Character, which is
1699 -- handled specially (without an explicit literals list).
1701 if Sloc
(Node
) > Standard_Location
1702 or else Present
(Literals
(Node
))
1704 Sprint_Paren_Comma_List
(Literals
(Node
));
1708 Write_Str_With_Col_Check_Sloc
("<error>");
1710 when N_Exception_Declaration
=>
1711 if Write_Indent_Identifiers
(Node
) then
1712 Write_Str_With_Col_Check
(" : ");
1714 if Is_Statically_Allocated
(Defining_Identifier
(Node
)) then
1715 Write_Str_With_Col_Check
("static ");
1718 Write_Str_Sloc
("exception");
1720 if Present
(Expression
(Node
)) then
1722 Sprint_Node
(Expression
(Node
));
1728 when N_Exception_Handler
=>
1729 Write_Indent_Str_Sloc
("when ");
1731 if Present
(Choice_Parameter
(Node
)) then
1732 Sprint_Node
(Choice_Parameter
(Node
));
1736 Sprint_Bar_List
(Exception_Choices
(Node
));
1738 Sprint_Indented_List
(Statements
(Node
));
1740 when N_Exception_Renaming_Declaration
=>
1743 Sprint_Node
(Defining_Identifier
(Node
));
1744 Write_Str_With_Col_Check
(" : exception renames ");
1745 Sprint_Node
(Name
(Node
));
1748 when N_Exit_Statement
=>
1749 Write_Indent_Str_Sloc
("exit");
1750 Sprint_Opt_Node
(Name
(Node
));
1752 if Present
(Condition
(Node
)) then
1753 Write_Str_With_Col_Check
(" when ");
1754 Sprint_Node
(Condition
(Node
));
1759 when N_Expanded_Name
=>
1760 Sprint_Node
(Prefix
(Node
));
1761 Write_Char_Sloc
('.');
1762 Sprint_Node
(Selector_Name
(Node
));
1764 when N_Explicit_Dereference
=>
1765 Sprint_Node
(Prefix
(Node
));
1766 Write_Char_Sloc
('.');
1767 Write_Str_Sloc
("all");
1769 when N_Expression_With_Actions
=>
1771 Write_Indent_Str_Sloc
("do ");
1773 Sprint_Node_List
(Actions
(Node
));
1776 Write_Str_With_Col_Check_Sloc
("in ");
1777 Sprint_Node
(Expression
(Node
));
1778 Write_Str_With_Col_Check
(" end");
1782 when N_Expression_Function
=>
1784 Sprint_Node_Sloc
(Specification
(Node
));
1788 Sprint_Node
(Expression
(Node
));
1792 when N_Extended_Return_Statement
=>
1793 Write_Indent_Str_Sloc
("return ");
1794 Sprint_Node_List
(Return_Object_Declarations
(Node
));
1796 if Present
(Handled_Statement_Sequence
(Node
)) then
1797 Write_Str_With_Col_Check
(" do");
1798 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1799 Write_Indent_Str
("end return");
1802 if Present
(Storage_Pool
(Node
)) then
1803 Write_Str_With_Col_Check
("[storage_pool = ");
1804 Sprint_Node
(Storage_Pool
(Node
));
1808 if Present
(Procedure_To_Call
(Node
)) then
1809 Write_Str_With_Col_Check
("[procedure_to_call = ");
1810 Sprint_Node
(Procedure_To_Call
(Node
));
1816 when N_Delta_Aggregate
=>
1817 Write_Str_With_Col_Check_Sloc
("(");
1818 Sprint_Node
(Expression
(Node
));
1819 Write_Str_With_Col_Check
(" with delta ");
1820 Sprint_Comma_List
(Component_Associations
(Node
));
1823 when N_Extension_Aggregate
=>
1824 Write_Str_With_Col_Check_Sloc
("(");
1825 Sprint_Node
(Ancestor_Part
(Node
));
1826 Write_Str_With_Col_Check
(" with ");
1828 if Null_Record_Present
(Node
) then
1829 Write_Str_With_Col_Check
("null record");
1831 if Present
(Expressions
(Node
)) then
1832 Sprint_Comma_List
(Expressions
(Node
));
1834 if Present
(Component_Associations
(Node
)) then
1839 if Present
(Component_Associations
(Node
)) then
1840 Sprint_Comma_List
(Component_Associations
(Node
));
1846 when N_Floating_Point_Definition
=>
1847 Write_Str_With_Col_Check_Sloc
("digits ");
1848 Sprint_Node
(Digits_Expression
(Node
));
1849 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1851 when N_Formal_Decimal_Fixed_Point_Definition
=>
1852 Write_Str_With_Col_Check_Sloc
("delta <> digits <>");
1854 when N_Formal_Derived_Type_Definition
=>
1855 Write_Str_With_Col_Check_Sloc
("new ");
1856 Sprint_Node
(Subtype_Mark
(Node
));
1858 if Present
(Interface_List
(Node
)) then
1859 Write_Str_With_Col_Check
(" and ");
1860 Sprint_And_List
(Interface_List
(Node
));
1863 if Private_Present
(Node
) then
1864 Write_Str_With_Col_Check
(" with private");
1867 when N_Formal_Abstract_Subprogram_Declaration
=>
1868 Write_Indent_Str_Sloc
("with ");
1869 Sprint_Node
(Specification
(Node
));
1871 Write_Str_With_Col_Check
(" is abstract");
1873 if Box_Present
(Node
) then
1874 Write_Str_With_Col_Check
(" <>");
1875 elsif Present
(Default_Name
(Node
)) then
1876 Write_Str_With_Col_Check
(" ");
1877 Sprint_Node
(Default_Name
(Node
));
1882 when N_Formal_Concrete_Subprogram_Declaration
=>
1883 Write_Indent_Str_Sloc
("with ");
1884 Sprint_Node
(Specification
(Node
));
1886 if Box_Present
(Node
) then
1887 Write_Str_With_Col_Check
(" is <>");
1888 elsif Present
(Default_Name
(Node
)) then
1889 Write_Str_With_Col_Check
(" is ");
1890 Sprint_Node
(Default_Name
(Node
));
1895 when N_Formal_Discrete_Type_Definition
=>
1896 Write_Str_With_Col_Check_Sloc
("<>");
1898 when N_Formal_Floating_Point_Definition
=>
1899 Write_Str_With_Col_Check_Sloc
("digits <>");
1901 when N_Formal_Modular_Type_Definition
=>
1902 Write_Str_With_Col_Check_Sloc
("mod <>");
1904 when N_Formal_Object_Declaration
=>
1907 if Write_Indent_Identifiers
(Node
) then
1910 if In_Present
(Node
) then
1911 Write_Str_With_Col_Check
("in ");
1914 if Out_Present
(Node
) then
1915 Write_Str_With_Col_Check
("out ");
1918 if Present
(Subtype_Mark
(Node
)) then
1920 -- Ada 2005 (AI-423): Formal object with null exclusion
1922 if Null_Exclusion_Present
(Node
) then
1923 Write_Str
("not null ");
1926 Sprint_Node
(Subtype_Mark
(Node
));
1928 -- Ada 2005 (AI-423): Formal object with access definition
1931 pragma Assert
(Present
(Access_Definition
(Node
)));
1933 Sprint_Node
(Access_Definition
(Node
));
1936 if Present
(Default_Expression
(Node
)) then
1938 Sprint_Node
(Default_Expression
(Node
));
1944 when N_Formal_Ordinary_Fixed_Point_Definition
=>
1945 Write_Str_With_Col_Check_Sloc
("delta <>");
1947 when N_Formal_Package_Declaration
=>
1948 Write_Indent_Str_Sloc
("with package ");
1949 Write_Id
(Defining_Identifier
(Node
));
1950 Write_Str_With_Col_Check
(" is new ");
1951 Sprint_Node
(Name
(Node
));
1952 Write_Str_With_Col_Check
(" (<>);");
1954 when N_Formal_Private_Type_Definition
=>
1955 if Abstract_Present
(Node
) then
1956 Write_Str_With_Col_Check
("abstract ");
1959 if Tagged_Present
(Node
) then
1960 Write_Str_With_Col_Check
("tagged ");
1963 if Limited_Present
(Node
) then
1964 Write_Str_With_Col_Check
("limited ");
1967 Write_Str_With_Col_Check_Sloc
("private");
1969 when N_Formal_Incomplete_Type_Definition
=>
1970 if Tagged_Present
(Node
) then
1971 Write_Str_With_Col_Check
("is tagged ");
1974 when N_Formal_Signed_Integer_Type_Definition
=>
1975 Write_Str_With_Col_Check_Sloc
("range <>");
1977 when N_Formal_Type_Declaration
=>
1978 Write_Indent_Str_Sloc
("type ");
1979 Write_Id
(Defining_Identifier
(Node
));
1981 if Present
(Discriminant_Specifications
(Node
)) then
1982 Write_Discr_Specs
(Node
);
1983 elsif Unknown_Discriminants_Present
(Node
) then
1984 Write_Str_With_Col_Check
("(<>)");
1987 if Nkind
(Formal_Type_Definition
(Node
)) /=
1988 N_Formal_Incomplete_Type_Definition
1990 Write_Str_With_Col_Check
(" is ");
1993 Sprint_Node
(Formal_Type_Definition
(Node
));
1996 when N_Free_Statement
=>
1997 Write_Indent_Str_Sloc
("free ");
1998 Sprint_Node
(Expression
(Node
));
2000 if Present
(Storage_Pool
(Node
)) then
2001 Write_Str_With_Col_Check
("[storage_pool = ");
2002 Sprint_Node
(Storage_Pool
(Node
));
2006 if Present
(Procedure_To_Call
(Node
)) then
2007 Write_Str_With_Col_Check
("[procedure_to_call = ");
2008 Sprint_Node
(Procedure_To_Call
(Node
));
2014 when N_Freeze_Entity
=>
2015 if Dump_Original_Only
then
2018 -- A freeze node is output if it has some effect (i.e. non-empty
2019 -- actions, or freeze node for an itype, which causes elaboration
2020 -- of the itype), and is also always output if Dump_Freeze_Null
2023 elsif Present
(Actions
(Node
))
2024 or else Is_Itype
(Entity
(Node
))
2025 or else Dump_Freeze_Null
2028 Write_Rewrite_Str
("<<<");
2029 Write_Str_With_Col_Check_Sloc
("freeze ");
2030 Write_Id
(Entity
(Node
));
2033 if No
(Actions
(Node
)) then
2037 -- Output freeze actions. We increment Freeze_Indent during
2038 -- this output to avoid generating extra blank lines before
2039 -- any procedures included in the freeze actions.
2041 Freeze_Indent
:= Freeze_Indent
+ 1;
2042 Sprint_Indented_List
(Actions
(Node
));
2043 Freeze_Indent
:= Freeze_Indent
- 1;
2044 Write_Indent_Str
("]");
2047 Write_Rewrite_Str
(">>>");
2050 when N_Freeze_Generic_Entity
=>
2051 if Dump_Original_Only
then
2056 Write_Str_With_Col_Check_Sloc
("freeze_generic ");
2057 Write_Id
(Entity
(Node
));
2060 when N_Full_Type_Declaration
=>
2061 Write_Indent_Str_Sloc
("type ");
2062 Sprint_Node
(Defining_Identifier
(Node
));
2063 Write_Discr_Specs
(Node
);
2064 Write_Str_With_Col_Check
(" is ");
2065 Sprint_Node
(Type_Definition
(Node
));
2068 when N_Function_Call
=>
2070 Write_Subprogram_Name
(Name
(Node
));
2071 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
2073 when N_Function_Instantiation
=>
2074 Write_Indent_Str_Sloc
("function ");
2075 Sprint_Node
(Defining_Unit_Name
(Node
));
2076 Write_Str_With_Col_Check
(" is new ");
2077 Sprint_Node
(Name
(Node
));
2078 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2081 when N_Function_Specification
=>
2082 Write_Str_With_Col_Check_Sloc
("function ");
2083 Sprint_Node
(Defining_Unit_Name
(Node
));
2084 Write_Param_Specs
(Node
);
2085 Write_Str_With_Col_Check
(" return ");
2087 -- Ada 2005 (AI-231)
2089 if Nkind
(Result_Definition
(Node
)) /= N_Access_Definition
2090 and then Null_Exclusion_Present
(Node
)
2092 Write_Str
(" not null ");
2095 Sprint_Node
(Result_Definition
(Node
));
2097 when N_Generic_Association
=>
2100 if Present
(Selector_Name
(Node
)) then
2101 Sprint_Node
(Selector_Name
(Node
));
2105 Sprint_Node
(Explicit_Generic_Actual_Parameter
(Node
));
2107 when N_Generic_Function_Renaming_Declaration
=>
2108 Write_Indent_Str_Sloc
("generic function ");
2109 Sprint_Node
(Defining_Unit_Name
(Node
));
2110 Write_Str_With_Col_Check
(" renames ");
2111 Sprint_Node
(Name
(Node
));
2114 when N_Generic_Declaration
=>
2116 Write_Indent_Str_Sloc
("generic ");
2117 Sprint_Indented_List
(Generic_Formal_Declarations
(Node
));
2119 Sprint_Node
(Specification
(Node
));
2122 when N_Generic_Package_Renaming_Declaration
=>
2123 Write_Indent_Str_Sloc
("generic package ");
2124 Sprint_Node
(Defining_Unit_Name
(Node
));
2125 Write_Str_With_Col_Check
(" renames ");
2126 Sprint_Node
(Name
(Node
));
2129 when N_Generic_Procedure_Renaming_Declaration
=>
2130 Write_Indent_Str_Sloc
("generic procedure ");
2131 Sprint_Node
(Defining_Unit_Name
(Node
));
2132 Write_Str_With_Col_Check
(" renames ");
2133 Sprint_Node
(Name
(Node
));
2136 when N_Goto_Statement
=>
2137 Write_Indent_Str_Sloc
("goto ");
2138 Sprint_Node
(Name
(Node
));
2141 if Nkind
(Next
(Node
)) = N_Label
then
2145 when N_Goto_When_Statement
=>
2146 Write_Indent_Str_Sloc
("goto ");
2147 Sprint_Node
(Name
(Node
));
2148 Write_Str
(" when ");
2149 Sprint_Node
(Condition
(Node
));
2152 when N_Handled_Sequence_Of_Statements
=>
2154 Sprint_Indented_List
(Statements
(Node
));
2156 if Present
(Exception_Handlers
(Node
)) then
2157 Write_Indent_Str
("exception");
2159 Sprint_Node_List
(Exception_Handlers
(Node
));
2163 if Present
(At_End_Proc
(Node
)) then
2164 Write_Indent_Str
("at end");
2167 Sprint_Node
(At_End_Proc
(Node
));
2172 when N_Identifier
=>
2176 when N_If_Expression
=>
2178 Has_Parens
: constant Boolean := Paren_Count
(Node
) > 0;
2179 Condition
: constant Node_Id
:= First
(Expressions
(Node
));
2180 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2183 -- The syntax for if_expression does not include parentheses,
2184 -- but sometimes parentheses are required, so unconditionally
2185 -- generate them here unless already present.
2187 if not Has_Parens
then
2191 Write_Str_With_Col_Check_Sloc
("if ");
2192 Sprint_Node
(Condition
);
2193 Write_Str_With_Col_Check
(" then ");
2195 -- Defense against junk here
2197 if Present
(Then_Expr
) then
2198 Sprint_Node
(Then_Expr
);
2200 if Present
(Next
(Then_Expr
)) then
2201 Write_Str_With_Col_Check
(" else ");
2202 Sprint_Node
(Next
(Then_Expr
));
2206 if not Has_Parens
then
2211 when N_If_Statement
=>
2212 Write_Indent_Str_Sloc
("if ");
2213 Sprint_Node
(Condition
(Node
));
2214 Write_Str_With_Col_Check
(" then");
2215 Sprint_Indented_List
(Then_Statements
(Node
));
2216 Sprint_Opt_Node_List
(Elsif_Parts
(Node
));
2218 if Present
(Else_Statements
(Node
)) then
2219 Write_Indent_Str
("else");
2220 Sprint_Indented_List
(Else_Statements
(Node
));
2223 Write_Indent_Str
("end if;");
2225 when N_Implicit_Label_Declaration
=>
2226 if not Dump_Original_Only
then
2228 Write_Rewrite_Str
("<<<");
2230 Write_Id
(Defining_Identifier
(Node
));
2232 Write_Str_With_Col_Check
("label");
2233 Write_Rewrite_Str
(">>>");
2237 Sprint_Left_Opnd
(Node
);
2238 Write_Str_Sloc
(" in ");
2240 if Present
(Right_Opnd
(Node
)) then
2241 Sprint_Right_Opnd
(Node
);
2243 Sprint_Bar_List
(Alternatives
(Node
));
2246 when N_Incomplete_Type_Declaration
=>
2247 Write_Indent_Str_Sloc
("type ");
2248 Write_Id
(Defining_Identifier
(Node
));
2250 if Present
(Discriminant_Specifications
(Node
)) then
2251 Write_Discr_Specs
(Node
);
2252 elsif Unknown_Discriminants_Present
(Node
) then
2253 Write_Str_With_Col_Check
("(<>)");
2258 when N_Index_Or_Discriminant_Constraint
=>
2260 Sprint_Paren_Comma_List
(Constraints
(Node
));
2262 when N_Indexed_Component
=>
2263 Sprint_Node_Sloc
(Prefix
(Node
));
2264 Sprint_Opt_Paren_Comma_List
(Expressions
(Node
));
2266 when N_Integer_Literal
=>
2267 if Print_In_Hex
(Node
) then
2268 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Hex
);
2270 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Auto
);
2273 when N_Iteration_Scheme
=>
2274 if Present
(Condition
(Node
)) then
2275 Write_Str_With_Col_Check_Sloc
("while ");
2276 Sprint_Node
(Condition
(Node
));
2278 Write_Str_With_Col_Check_Sloc
("for ");
2280 if Present
(Iterator_Specification
(Node
)) then
2281 Sprint_Node
(Iterator_Specification
(Node
));
2283 Sprint_Node
(Loop_Parameter_Specification
(Node
));
2289 when N_Iterator_Specification
=>
2291 Write_Id
(Defining_Identifier
(Node
));
2293 if Present
(Subtype_Indication
(Node
)) then
2294 Write_Str_With_Col_Check
(" : ");
2295 Sprint_Node
(Subtype_Indication
(Node
));
2298 if Of_Present
(Node
) then
2299 Write_Str_With_Col_Check
(" of ");
2301 Write_Str_With_Col_Check
(" in ");
2304 if Reverse_Present
(Node
) then
2305 Write_Str_With_Col_Check
("reverse ");
2308 Sprint_Node
(Name
(Node
));
2310 when N_Itype_Reference
=>
2311 Write_Indent_Str_Sloc
("reference ");
2312 Write_Id
(Itype
(Node
));
2315 Write_Indent_Str_Sloc
("<<");
2316 Write_Id
(Identifier
(Node
));
2319 when N_Loop_Parameter_Specification
=>
2321 Write_Id
(Defining_Identifier
(Node
));
2322 Write_Str_With_Col_Check
(" in ");
2324 if Reverse_Present
(Node
) then
2325 Write_Str_With_Col_Check
("reverse ");
2328 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
2330 when N_Loop_Statement
=>
2333 if Present
(Identifier
(Node
))
2334 and then (not Has_Created_Identifier
(Node
)
2335 or else not Dump_Original_Only
)
2337 Write_Rewrite_Str
("<<<");
2338 Write_Id
(Identifier
(Node
));
2340 Write_Rewrite_Str
(">>>");
2341 Sprint_Node
(Iteration_Scheme
(Node
));
2342 Write_Str_With_Col_Check_Sloc
("loop");
2343 Sprint_Indented_List
(Statements
(Node
));
2344 Write_Indent_Str
("end loop ");
2345 Write_Rewrite_Str
("<<<");
2346 Write_Id
(Identifier
(Node
));
2347 Write_Rewrite_Str
(">>>");
2351 Sprint_Node
(Iteration_Scheme
(Node
));
2352 Write_Str_With_Col_Check_Sloc
("loop");
2353 Sprint_Indented_List
(Statements
(Node
));
2354 Write_Indent_Str
("end loop;");
2357 when N_Mod_Clause
=>
2358 Sprint_Node_List
(Pragmas_Before
(Node
));
2359 Write_Str_With_Col_Check_Sloc
("at mod ");
2360 Sprint_Node
(Expression
(Node
));
2362 when N_Modular_Type_Definition
=>
2363 Write_Str_With_Col_Check_Sloc
("mod ");
2364 Sprint_Node
(Expression
(Node
));
2367 Sprint_Left_Opnd
(Node
);
2368 Write_Str_Sloc
(" not in ");
2370 if Present
(Right_Opnd
(Node
)) then
2371 Sprint_Right_Opnd
(Node
);
2373 Sprint_Bar_List
(Alternatives
(Node
));
2377 Write_Str_With_Col_Check_Sloc
("null");
2379 when N_Null_Statement
=>
2380 if Comes_From_Source
(Node
)
2381 or else Dump_Freeze_Null
2382 or else not Is_List_Member
(Node
)
2383 or else (No
(Prev
(Node
)) and then No
(Next
(Node
)))
2385 Write_Indent_Str_Sloc
("null;");
2388 when N_Number_Declaration
=>
2391 if Write_Indent_Identifiers
(Node
) then
2392 Write_Str_With_Col_Check
(" : constant ");
2394 Sprint_Node
(Expression
(Node
));
2398 when N_Object_Declaration
=>
2401 if Write_Indent_Identifiers
(Node
) then
2403 Def_Id
: constant Entity_Id
:= Defining_Identifier
(Node
);
2406 Write_Str_With_Col_Check
(" : ");
2408 if Is_Statically_Allocated
(Def_Id
) then
2409 Write_Str_With_Col_Check
("static ");
2412 if Aliased_Present
(Node
) then
2413 Write_Str_With_Col_Check
("aliased ");
2416 if Constant_Present
(Node
) then
2417 Write_Str_With_Col_Check
("constant ");
2420 -- Ada 2005 (AI-231)
2422 if Null_Exclusion_Present
(Node
) then
2423 Write_Str_With_Col_Check
("not null ");
2426 -- Print type. We used to print the Object_Definition from
2427 -- the node, but it is much more useful to print the Etype
2428 -- of the defining identifier for the case where the nominal
2429 -- type is an unconstrained array type. For example, this
2430 -- will be a clear reference to the Itype with the bounds
2431 -- in the case of a type like String. The object after
2432 -- all is constrained, even if its nominal subtype is
2436 Odef
: constant Node_Id
:= Object_Definition
(Node
);
2439 if Nkind
(Odef
) = N_Identifier
2440 and then Present
(Etype
(Odef
))
2441 and then Is_Array_Type
(Etype
(Odef
))
2442 and then not Is_Constrained
(Etype
(Odef
))
2443 and then Present
(Etype
(Def_Id
))
2445 Sprint_Node
(Etype
(Def_Id
));
2447 -- In other cases, the nominal type is fine to print
2454 if Present
(Expression
(Node
))
2455 and then Expression
(Node
) /= Error
2456 and then not No_Initialization
(Node
)
2459 Sprint_Node
(Expression
(Node
));
2464 -- Handle implicit importation and implicit exportation of
2465 -- object declarations:
2466 -- $pragma import (Convention_Id, Def_Id, "...");
2467 -- $pragma export (Convention_Id, Def_Id, "...");
2469 if Is_Internal
(Def_Id
)
2470 and then Present
(Interface_Name
(Def_Id
))
2472 Write_Indent_Str_Sloc
("$pragma ");
2474 if Is_Imported
(Def_Id
) then
2475 Write_Str
("import (");
2477 else pragma Assert
(Is_Exported
(Def_Id
));
2478 Write_Str
("export (");
2482 Prefix
: constant String := "Convention_";
2483 S
: constant String := Convention
(Def_Id
)'Img;
2486 Name_Len
:= S
'Last - Prefix
'Last;
2487 Name_Buffer
(1 .. Name_Len
) :=
2488 S
(Prefix
'Last + 1 .. S
'Last);
2489 Set_Casing
(All_Lower_Case
);
2490 Write_Str
(Name_Buffer
(1 .. Name_Len
));
2496 Write_String_Table_Entry
2497 (Strval
(Interface_Name
(Def_Id
)));
2503 when N_Object_Renaming_Declaration
=>
2506 Sprint_Node
(Defining_Identifier
(Node
));
2508 -- Ada 2005 (AI-230): Access renamings
2510 if Present
(Access_Definition
(Node
)) then
2512 Sprint_Node
(Access_Definition
(Node
));
2514 elsif Present
(Subtype_Mark
(Node
)) then
2517 -- Ada 2005 (AI-423): Object renaming with a null exclusion
2519 if Null_Exclusion_Present
(Node
) then
2520 Write_Str
("not null ");
2523 Sprint_Node
(Subtype_Mark
(Node
));
2525 -- AI12-0275: Object_Renaming_Declaration without explicit subtype
2527 elsif Ada_Version
>= Ada_2022
then
2531 Write_Str
(" : ??? ");
2534 Write_Str_With_Col_Check
(" renames ");
2535 Sprint_Node
(Name
(Node
));
2539 Write_Operator
(Node
, "abs ");
2540 Sprint_Right_Opnd
(Node
);
2543 Sprint_Left_Opnd
(Node
);
2544 Write_Operator
(Node
, " + ");
2545 Sprint_Right_Opnd
(Node
);
2548 Sprint_Left_Opnd
(Node
);
2549 Write_Operator
(Node
, " and ");
2550 Sprint_Right_Opnd
(Node
);
2553 Sprint_Left_Opnd
(Node
);
2554 Write_Operator
(Node
, " & ");
2555 Sprint_Right_Opnd
(Node
);
2558 Sprint_Left_Opnd
(Node
);
2560 if Rounded_Result
(Node
) then
2563 Write_Operator
(Node
, "/ ");
2564 Sprint_Right_Opnd
(Node
);
2567 Sprint_Left_Opnd
(Node
);
2568 Write_Operator
(Node
, " = ");
2569 Sprint_Right_Opnd
(Node
);
2572 Sprint_Left_Opnd
(Node
);
2573 Write_Operator
(Node
, " ** ");
2574 Sprint_Right_Opnd
(Node
);
2577 Sprint_Left_Opnd
(Node
);
2578 Write_Operator
(Node
, " >= ");
2579 Sprint_Right_Opnd
(Node
);
2582 Sprint_Left_Opnd
(Node
);
2583 Write_Operator
(Node
, " > ");
2584 Sprint_Right_Opnd
(Node
);
2587 Sprint_Left_Opnd
(Node
);
2588 Write_Operator
(Node
, " <= ");
2589 Sprint_Right_Opnd
(Node
);
2592 Sprint_Left_Opnd
(Node
);
2593 Write_Operator
(Node
, " < ");
2594 Sprint_Right_Opnd
(Node
);
2597 Write_Operator
(Node
, "-");
2598 Sprint_Right_Opnd
(Node
);
2601 Sprint_Left_Opnd
(Node
);
2602 Write_Operator
(Node
, " mod ");
2603 Sprint_Right_Opnd
(Node
);
2605 when N_Op_Multiply
=>
2606 Sprint_Left_Opnd
(Node
);
2608 if Rounded_Result
(Node
) then
2611 Write_Operator
(Node
, "* ");
2612 Sprint_Right_Opnd
(Node
);
2615 Sprint_Left_Opnd
(Node
);
2616 Write_Operator
(Node
, " /= ");
2617 Sprint_Right_Opnd
(Node
);
2620 Write_Operator
(Node
, "not ");
2621 Sprint_Right_Opnd
(Node
);
2624 Sprint_Left_Opnd
(Node
);
2625 Write_Operator
(Node
, " or ");
2626 Sprint_Right_Opnd
(Node
);
2629 Write_Operator
(Node
, "+");
2630 Sprint_Right_Opnd
(Node
);
2633 Sprint_Left_Opnd
(Node
);
2634 Write_Operator
(Node
, " rem ");
2635 Sprint_Right_Opnd
(Node
);
2641 Write_Str_With_Col_Check
("(");
2642 Sprint_Node
(Left_Opnd
(Node
));
2644 Sprint_Node
(Right_Opnd
(Node
));
2647 when N_Op_Subtract
=>
2648 Sprint_Left_Opnd
(Node
);
2649 Write_Operator
(Node
, " - ");
2650 Sprint_Right_Opnd
(Node
);
2653 Sprint_Left_Opnd
(Node
);
2654 Write_Operator
(Node
, " xor ");
2655 Sprint_Right_Opnd
(Node
);
2657 when N_Operator_Symbol
=>
2658 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
2660 when N_Ordinary_Fixed_Point_Definition
=>
2661 Write_Str_With_Col_Check_Sloc
("delta ");
2662 Sprint_Node
(Delta_Expression
(Node
));
2663 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
2666 Sprint_Left_Opnd
(Node
);
2667 Write_Str_Sloc
(" or else ");
2668 Sprint_Right_Opnd
(Node
);
2670 when N_Others_Choice
=>
2671 if All_Others
(Node
) then
2672 Write_Str_With_Col_Check
("all ");
2675 Write_Str_With_Col_Check_Sloc
("others");
2677 when N_Package_Body
=>
2679 Write_Indent_Str_Sloc
("package body ");
2680 Sprint_Node
(Defining_Unit_Name
(Node
));
2682 Sprint_Indented_List
(Declarations
(Node
));
2684 if Present
(Handled_Statement_Sequence
(Node
)) then
2685 Write_Indent_Str
("begin");
2686 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2689 Write_Indent_Str
("end ");
2691 (Handled_Statement_Sequence
(Node
), Defining_Unit_Name
(Node
));
2694 when N_Package_Body_Stub
=>
2695 Write_Indent_Str_Sloc
("package body ");
2696 Sprint_Node
(Defining_Identifier
(Node
));
2697 Write_Str_With_Col_Check
(" is separate;");
2699 when N_Package_Declaration
=>
2702 Sprint_Node_Sloc
(Specification
(Node
));
2705 -- If this is an instantiation, get the aspects from the original
2706 -- instantiation node.
2708 if Is_Generic_Instance
(Defining_Entity
(Node
))
2709 and then Has_Aspects
2710 (Package_Instantiation
(Defining_Entity
(Node
)))
2712 Sprint_Aspect_Specifications
2713 (Package_Instantiation
(Defining_Entity
(Node
)),
2717 when N_Package_Instantiation
=>
2719 Write_Indent_Str_Sloc
("package ");
2720 Sprint_Node
(Defining_Unit_Name
(Node
));
2721 Write_Str
(" is new ");
2722 Sprint_Node
(Name
(Node
));
2723 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2726 when N_Package_Renaming_Declaration
=>
2727 Write_Indent_Str_Sloc
("package ");
2728 Sprint_Node
(Defining_Unit_Name
(Node
));
2729 Write_Str_With_Col_Check
(" renames ");
2730 Sprint_Node
(Name
(Node
));
2733 when N_Package_Specification
=>
2734 Write_Str_With_Col_Check_Sloc
("package ");
2735 Sprint_Node
(Defining_Unit_Name
(Node
));
2737 if Nkind
(Parent
(Node
)) = N_Generic_Package_Declaration
2738 and then Has_Aspects
(Parent
(Node
))
2740 Sprint_Aspect_Specifications
2741 (Parent
(Node
), Semicolon
=> False);
2743 -- An instantiation is rewritten as a package declaration, but
2744 -- the aspects belong to the instantiation node.
2746 elsif Nkind
(Parent
(Node
)) = N_Package_Declaration
then
2748 Pack
: constant Entity_Id
:= Defining_Entity
(Node
);
2751 if not Is_Generic_Instance
(Pack
) then
2752 if Has_Aspects
(Parent
(Node
)) then
2753 Sprint_Aspect_Specifications
2754 (Parent
(Node
), Semicolon
=> False);
2761 Sprint_Indented_List
(Visible_Declarations
(Node
));
2763 if Present
(Private_Declarations
(Node
)) then
2764 Write_Indent_Str
("private");
2765 Sprint_Indented_List
(Private_Declarations
(Node
));
2768 Write_Indent_Str
("end ");
2769 Sprint_Node
(Defining_Unit_Name
(Node
));
2771 when N_Parameter_Association
=>
2772 Sprint_Node_Sloc
(Selector_Name
(Node
));
2774 Sprint_Node
(Explicit_Actual_Parameter
(Node
));
2776 when N_Parameter_Specification
=>
2779 if Write_Identifiers
(Node
) then
2782 if In_Present
(Node
) then
2783 Write_Str_With_Col_Check
("in ");
2786 if Out_Present
(Node
) then
2787 Write_Str_With_Col_Check
("out ");
2790 -- Ada 2005 (AI-231): Parameter specification may carry null
2791 -- exclusion. Do not print it now if this is an access formal,
2792 -- it is emitted when the access definition is displayed.
2794 if Null_Exclusion_Present
(Node
)
2795 and then Nkind
(Parameter_Type
(Node
)) /= N_Access_Definition
2797 Write_Str
("not null ");
2800 if Aliased_Present
(Node
) then
2801 Write_Str
("aliased ");
2804 Sprint_Node
(Parameter_Type
(Node
));
2806 if Present
(Expression
(Node
)) then
2808 Sprint_Node
(Expression
(Node
));
2814 when N_Pop_Constraint_Error_Label
=>
2815 Write_Indent_Str
("%pop_constraint_error_label");
2817 when N_Pop_Program_Error_Label
=>
2818 Write_Indent_Str
("%pop_program_error_label");
2820 when N_Pop_Storage_Error_Label
=>
2821 Write_Indent_Str
("%pop_storage_error_label");
2823 when N_Private_Extension_Declaration
=>
2824 Write_Indent_Str_Sloc
("type ");
2825 Write_Id
(Defining_Identifier
(Node
));
2827 if Present
(Discriminant_Specifications
(Node
)) then
2828 Write_Discr_Specs
(Node
);
2829 elsif Unknown_Discriminants_Present
(Node
) then
2830 Write_Str_With_Col_Check
("(<>)");
2833 Write_Str_With_Col_Check
(" is new ");
2834 Sprint_Node
(Subtype_Indication
(Node
));
2836 if Present
(Interface_List
(Node
)) then
2837 Write_Str_With_Col_Check
(" and ");
2838 Sprint_And_List
(Interface_List
(Node
));
2841 Write_Str_With_Col_Check
(" with private;");
2843 when N_Private_Type_Declaration
=>
2844 Write_Indent_Str_Sloc
("type ");
2845 Write_Id
(Defining_Identifier
(Node
));
2847 if Present
(Discriminant_Specifications
(Node
)) then
2848 Write_Discr_Specs
(Node
);
2849 elsif Unknown_Discriminants_Present
(Node
) then
2850 Write_Str_With_Col_Check
("(<>)");
2855 if Tagged_Present
(Node
) then
2856 Write_Str_With_Col_Check
("tagged ");
2859 if Limited_Present
(Node
) then
2860 Write_Str_With_Col_Check
("limited ");
2863 Write_Str_With_Col_Check
("private;");
2865 when N_Push_Constraint_Error_Label
=>
2866 Write_Indent_Str
("%push_constraint_error_label (");
2868 if Present
(Exception_Label
(Node
)) then
2869 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2874 when N_Push_Program_Error_Label
=>
2875 Write_Indent_Str
("%push_program_error_label (");
2877 if Present
(Exception_Label
(Node
)) then
2878 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2883 when N_Push_Storage_Error_Label
=>
2884 Write_Indent_Str
("%push_storage_error_label (");
2886 if Present
(Exception_Label
(Node
)) then
2887 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2893 Write_Indent_Str_Sloc
("pragma ");
2894 Write_Name_With_Col_Check
(Pragma_Name_Unmapped
(Node
));
2896 if Present
(Pragma_Argument_Associations
(Node
)) then
2897 Sprint_Opt_Paren_Comma_List
2898 (Pragma_Argument_Associations
(Node
));
2903 when N_Pragma_Argument_Association
=>
2906 if Chars
(Node
) /= No_Name
then
2907 Write_Name_With_Col_Check
(Chars
(Node
));
2911 Sprint_Node
(Expression
(Node
));
2913 when N_Procedure_Call_Statement
=>
2916 Write_Subprogram_Name
(Name
(Node
));
2917 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
2920 when N_Procedure_Instantiation
=>
2921 Write_Indent_Str_Sloc
("procedure ");
2922 Sprint_Node
(Defining_Unit_Name
(Node
));
2923 Write_Str_With_Col_Check
(" is new ");
2924 Sprint_Node
(Name
(Node
));
2925 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2928 when N_Procedure_Specification
=>
2929 Write_Str_With_Col_Check_Sloc
("procedure ");
2930 Sprint_Node
(Defining_Unit_Name
(Node
));
2931 Write_Param_Specs
(Node
);
2933 when N_Protected_Body
=>
2934 Write_Indent_Str_Sloc
("protected body ");
2935 Write_Id
(Defining_Identifier
(Node
));
2937 Sprint_Indented_List
(Declarations
(Node
));
2938 Write_Indent_Str
("end ");
2939 Write_Id
(Defining_Identifier
(Node
));
2942 when N_Protected_Body_Stub
=>
2943 Write_Indent_Str_Sloc
("protected body ");
2944 Write_Id
(Defining_Identifier
(Node
));
2945 Write_Str_With_Col_Check
(" is separate;");
2947 when N_Protected_Definition
=>
2949 Sprint_Indented_List
(Visible_Declarations
(Node
));
2951 if Present
(Private_Declarations
(Node
)) then
2952 Write_Indent_Str
("private");
2953 Sprint_Indented_List
(Private_Declarations
(Node
));
2956 Write_Indent_Str
("end ");
2958 when N_Protected_Type_Declaration
=>
2959 Write_Indent_Str_Sloc
("protected type ");
2960 Sprint_Node
(Defining_Identifier
(Node
));
2961 Write_Discr_Specs
(Node
);
2963 if Present
(Interface_List
(Node
)) then
2964 Write_Str
(" is new ");
2965 Sprint_And_List
(Interface_List
(Node
));
2966 Write_Str
(" with ");
2971 Sprint_Node
(Protected_Definition
(Node
));
2972 Write_Id
(Defining_Identifier
(Node
));
2975 when N_Qualified_Expression
=>
2976 Sprint_Node
(Subtype_Mark
(Node
));
2977 Write_Char_Sloc
(''');
2979 -- Print expression, make sure we have at least one level of
2980 -- parentheses around the expression. For cases of qualified
2981 -- expressions in the source, this is always the case, but
2982 -- for generated qualifications, there may be no explicit
2983 -- parentheses present.
2985 if Paren_Count
(Expression
(Node
)) /= 0 then
2986 Sprint_Node
(Expression
(Node
));
2990 Sprint_Node
(Expression
(Node
));
2992 -- Odd case, for the qualified expressions used in machine
2993 -- code the argument may be a procedure call, resulting in
2994 -- a junk semicolon before the right parent, get rid of it.
2996 Write_Erase_Char
(';');
2998 -- Now we can add the terminating right paren
3003 when N_Quantified_Expression
=>
3006 if All_Present
(Node
) then
3007 Write_Str
(" all ");
3009 Write_Str
(" some ");
3012 if Present
(Iterator_Specification
(Node
)) then
3013 Sprint_Node
(Iterator_Specification
(Node
));
3015 Sprint_Node
(Loop_Parameter_Specification
(Node
));
3019 Sprint_Node
(Condition
(Node
));
3021 when N_Raise_Expression
=>
3023 Has_Parens
: constant Boolean := Paren_Count
(Node
) > 0;
3026 -- The syntax for raise_expression does not include parentheses
3027 -- but sometimes parentheses are required, so unconditionally
3028 -- generate them here unless already present.
3030 if not Has_Parens
then
3034 Write_Str_With_Col_Check_Sloc
("raise ");
3035 Sprint_Node
(Name
(Node
));
3037 if Present
(Expression
(Node
)) then
3038 Write_Str_With_Col_Check
(" with ");
3039 Sprint_Node
(Expression
(Node
));
3042 if not Has_Parens
then
3047 when N_Raise_Constraint_Error
=>
3049 -- This node can be used either as a subexpression or as a
3050 -- statement form. The following test is a reasonably reliable
3051 -- way to distinguish the two cases.
3053 if Is_List_Member
(Node
)
3054 and then Nkind
(Parent
(Node
)) not in N_Subexpr
3059 Write_Str_With_Col_Check_Sloc
("[constraint_error");
3060 Write_Condition_And_Reason
(Node
);
3062 when N_Raise_Program_Error
=>
3064 -- This node can be used either as a subexpression or as a
3065 -- statement form. The following test is a reasonably reliable
3066 -- way to distinguish the two cases.
3068 if Is_List_Member
(Node
)
3069 and then Nkind
(Parent
(Node
)) not in N_Subexpr
3074 Write_Str_With_Col_Check_Sloc
("[program_error");
3075 Write_Condition_And_Reason
(Node
);
3077 when N_Raise_Storage_Error
=>
3079 -- This node can be used either as a subexpression or as a
3080 -- statement form. The following test is a reasonably reliable
3081 -- way to distinguish the two cases.
3083 if Is_List_Member
(Node
)
3084 and then Nkind
(Parent
(Node
)) not in N_Subexpr
3089 Write_Str_With_Col_Check_Sloc
("[storage_error");
3090 Write_Condition_And_Reason
(Node
);
3092 when N_Raise_Statement
=>
3093 Write_Indent_Str_Sloc
("raise ");
3094 Sprint_Node
(Name
(Node
));
3096 if Present
(Expression
(Node
)) then
3097 Write_Str_With_Col_Check_Sloc
(" with ");
3098 Sprint_Node
(Expression
(Node
));
3103 when N_Raise_When_Statement
=>
3104 Write_Indent_Str_Sloc
("raise ");
3105 Sprint_Node
(Name
(Node
));
3106 Write_Str
(" when ");
3107 Sprint_Node
(Condition
(Node
));
3109 if Present
(Expression
(Node
)) then
3110 Write_Str_With_Col_Check_Sloc
(" with ");
3111 Sprint_Node
(Expression
(Node
));
3117 Sprint_Node
(Low_Bound
(Node
));
3118 Write_Str_Sloc
(" .. ");
3119 if Present
(Etype
(Node
))
3120 and then Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Node
))
3124 Sprint_Node
(High_Bound
(Node
));
3126 Update_Itype
(Node
);
3128 when N_Range_Constraint
=>
3129 Write_Str_With_Col_Check_Sloc
("range ");
3130 Sprint_Node
(Range_Expression
(Node
));
3132 when N_Real_Literal
=>
3133 Write_Ureal_With_Col_Check_Sloc
(Realval
(Node
));
3135 when N_Real_Range_Specification
=>
3136 Write_Str_With_Col_Check_Sloc
("range ");
3137 Sprint_Node
(Low_Bound
(Node
));
3139 Sprint_Node
(High_Bound
(Node
));
3141 when N_Record_Definition
=>
3142 if Abstract_Present
(Node
) then
3143 Write_Str_With_Col_Check
("abstract ");
3146 if Tagged_Present
(Node
) then
3147 Write_Str_With_Col_Check
("tagged ");
3150 if Limited_Present
(Node
) then
3151 Write_Str_With_Col_Check
("limited ");
3154 if Null_Present
(Node
) then
3155 Write_Str_With_Col_Check_Sloc
("null record");
3158 Write_Str_With_Col_Check_Sloc
("record");
3159 Sprint_Node
(Component_List
(Node
));
3160 Write_Indent_Str
("end record");
3163 when N_Record_Representation_Clause
=>
3164 Write_Indent_Str_Sloc
("for ");
3165 Sprint_Node
(Identifier
(Node
));
3166 Write_Str_With_Col_Check
(" use record ");
3168 if Present
(Mod_Clause
(Node
)) then
3169 Sprint_Node
(Mod_Clause
(Node
));
3172 Sprint_Indented_List
(Component_Clauses
(Node
));
3173 Write_Indent_Str
("end record;");
3176 Sprint_Node
(Prefix
(Node
));
3177 Write_Str_With_Col_Check_Sloc
("'reference");
3179 when N_Requeue_Statement
=>
3180 Write_Indent_Str_Sloc
("requeue ");
3181 Sprint_Node
(Name
(Node
));
3183 if Abort_Present
(Node
) then
3184 Write_Str_With_Col_Check
(" with abort");
3189 when N_Return_When_Statement
=>
3190 Write_Indent_Str_Sloc
("return ");
3191 Sprint_Node
(Expression
(Node
));
3192 Write_Str
(" when ");
3193 Sprint_Node
(Condition
(Node
));
3196 when N_SCIL_Dispatch_Table_Tag_Init
=>
3197 Write_Indent_Str
("[N_SCIL_Dispatch_Table_Tag_Init]");
3199 when N_SCIL_Dispatching_Call
=>
3200 Write_Indent_Str
("[N_SCIL_Dispatching_Node]");
3202 when N_SCIL_Membership_Test
=>
3203 Write_Indent_Str
("[N_SCIL_Membership_Test]");
3205 when N_Simple_Return_Statement
=>
3206 if Present
(Expression
(Node
)) then
3207 Write_Indent_Str_Sloc
("return ");
3208 Sprint_Node
(Expression
(Node
));
3210 Write_Indent_Str_Sloc
("return");
3213 if Present
(Storage_Pool
(Node
)) then
3214 Write_Str_With_Col_Check
("[storage_pool = ");
3215 Sprint_Node
(Storage_Pool
(Node
));
3219 if Present
(Procedure_To_Call
(Node
)) then
3220 Write_Str_With_Col_Check
("[procedure_to_call = ");
3221 Sprint_Node
(Procedure_To_Call
(Node
));
3227 when N_Selective_Accept
=>
3228 Write_Indent_Str_Sloc
("select");
3233 Alt_Node
:= First
(Select_Alternatives
(Node
));
3236 Sprint_Node
(Alt_Node
);
3239 exit when No
(Alt_Node
);
3240 Write_Indent_Str
("or");
3244 if Present
(Else_Statements
(Node
)) then
3245 Write_Indent_Str
("else");
3246 Sprint_Indented_List
(Else_Statements
(Node
));
3249 Write_Indent_Str
("end select;");
3251 when N_Signed_Integer_Type_Definition
=>
3252 Write_Str_With_Col_Check_Sloc
("range ");
3253 Sprint_Node
(Low_Bound
(Node
));
3255 Sprint_Node
(High_Bound
(Node
));
3257 when N_Single_Protected_Declaration
=>
3258 Write_Indent_Str_Sloc
("protected ");
3259 Write_Id
(Defining_Identifier
(Node
));
3261 Sprint_Node
(Protected_Definition
(Node
));
3262 Write_Id
(Defining_Identifier
(Node
));
3265 when N_Single_Task_Declaration
=>
3266 Write_Indent_Str_Sloc
("task ");
3267 Sprint_Node
(Defining_Identifier
(Node
));
3269 if Present
(Task_Definition
(Node
)) then
3271 Sprint_Node
(Task_Definition
(Node
));
3276 when N_Selected_Component
=>
3277 Sprint_Node
(Prefix
(Node
));
3278 Write_Char_Sloc
('.');
3279 Sprint_Node
(Selector_Name
(Node
));
3283 Sprint_Node
(Prefix
(Node
));
3284 Write_Str_With_Col_Check
(" (");
3285 Sprint_Node
(Discrete_Range
(Node
));
3288 when N_String_Literal
=>
3289 if String_Length
(Strval
(Node
)) + Column
> Sprint_Line_Limit
then
3290 Write_Indent_Str
(" ");
3294 Write_String_Table_Entry
(Strval
(Node
));
3296 when N_Subprogram_Body
=>
3298 -- Output extra blank line unless we are in freeze actions
3300 if Freeze_Indent
= 0 then
3306 if Present
(Corresponding_Spec
(Node
)) then
3307 Sprint_Node_Sloc
(Parent
(Corresponding_Spec
(Node
)));
3309 Sprint_Node_Sloc
(Specification
(Node
));
3314 Sprint_Indented_List
(Declarations
(Node
));
3315 Write_Indent_Str
("begin");
3316 Sprint_Node
(Handled_Statement_Sequence
(Node
));
3318 Write_Indent_Str
("end ");
3321 (Handled_Statement_Sequence
(Node
),
3322 Defining_Unit_Name
(Specification
(Node
)));
3325 if Is_List_Member
(Node
)
3326 and then Present
(Next
(Node
))
3327 and then Nkind
(Next
(Node
)) /= N_Subprogram_Body
3332 when N_Subprogram_Body_Stub
=>
3334 Sprint_Node_Sloc
(Specification
(Node
));
3335 Write_Str_With_Col_Check
(" is separate;");
3337 when N_Subprogram_Declaration
=>
3339 Sprint_Node_Sloc
(Specification
(Node
));
3341 if Nkind
(Specification
(Node
)) = N_Procedure_Specification
3342 and then Null_Present
(Specification
(Node
))
3344 Write_Str_With_Col_Check
(" is null");
3349 when N_Subprogram_Renaming_Declaration
=>
3351 Sprint_Node
(Specification
(Node
));
3352 Write_Str_With_Col_Check_Sloc
(" renames ");
3353 Sprint_Node
(Name
(Node
));
3356 when N_Subtype_Declaration
=>
3357 Write_Indent_Str_Sloc
("subtype ");
3358 Sprint_Node
(Defining_Identifier
(Node
));
3361 -- Ada 2005 (AI-231)
3363 if Null_Exclusion_Present
(Node
) then
3364 Write_Str
("not null ");
3367 Sprint_Node
(Subtype_Indication
(Node
));
3370 when N_Subtype_Indication
=>
3371 Sprint_Node_Sloc
(Subtype_Mark
(Node
));
3373 Sprint_Node
(Constraint
(Node
));
3376 Write_Indent_Str_Sloc
("separate (");
3377 Sprint_Node
(Name
(Node
));
3380 Sprint_Node
(Proper_Body
(Node
));
3382 when N_Target_Name
=>
3386 Write_Indent_Str_Sloc
("task body ");
3387 Write_Id
(Defining_Identifier
(Node
));
3389 Sprint_Indented_List
(Declarations
(Node
));
3390 Write_Indent_Str
("begin");
3391 Sprint_Node
(Handled_Statement_Sequence
(Node
));
3392 Write_Indent_Str
("end ");
3394 (Handled_Statement_Sequence
(Node
), Defining_Identifier
(Node
));
3397 when N_Task_Body_Stub
=>
3398 Write_Indent_Str_Sloc
("task body ");
3399 Write_Id
(Defining_Identifier
(Node
));
3400 Write_Str_With_Col_Check
(" is separate;");
3402 when N_Task_Definition
=>
3404 Sprint_Indented_List
(Visible_Declarations
(Node
));
3406 if Present
(Private_Declarations
(Node
)) then
3407 Write_Indent_Str
("private");
3408 Sprint_Indented_List
(Private_Declarations
(Node
));
3411 Write_Indent_Str
("end ");
3412 Sprint_End_Label
(Node
, Defining_Identifier
(Parent
(Node
)));
3414 when N_Task_Type_Declaration
=>
3415 Write_Indent_Str_Sloc
("task type ");
3416 Sprint_Node
(Defining_Identifier
(Node
));
3417 Write_Discr_Specs
(Node
);
3419 if Present
(Interface_List
(Node
)) then
3420 Write_Str
(" is new ");
3421 Sprint_And_List
(Interface_List
(Node
));
3424 if Present
(Task_Definition
(Node
)) then
3425 if No
(Interface_List
(Node
)) then
3428 Write_Str
(" with ");
3431 Sprint_Node
(Task_Definition
(Node
));
3436 when N_Terminate_Alternative
=>
3437 Sprint_Node_List
(Pragmas_Before
(Node
));
3440 if Present
(Condition
(Node
)) then
3441 Write_Str_With_Col_Check
("when ");
3442 Sprint_Node
(Condition
(Node
));
3446 Write_Str_With_Col_Check_Sloc
("terminate;");
3447 Sprint_Node_List
(Pragmas_After
(Node
));
3449 when N_Timed_Entry_Call
=>
3450 Write_Indent_Str_Sloc
("select");
3452 Sprint_Node
(Entry_Call_Alternative
(Node
));
3454 Write_Indent_Str
("or");
3456 Sprint_Node
(Delay_Alternative
(Node
));
3458 Write_Indent_Str
("end select;");
3460 when N_Triggering_Alternative
=>
3461 Sprint_Node_List
(Pragmas_Before
(Node
));
3462 Sprint_Node_Sloc
(Triggering_Statement
(Node
));
3463 Sprint_Node_List
(Statements
(Node
));
3465 when N_Type_Conversion
=>
3467 Sprint_Node
(Subtype_Mark
(Node
));
3470 if Conversion_OK
(Node
) then
3474 if Float_Truncate
(Node
) then
3478 if Rounded_Result
(Node
) then
3483 Sprint_Node
(Expression
(Node
));
3486 when N_Unchecked_Expression
=>
3489 Sprint_Node_Sloc
(Expression
(Node
));
3492 when N_Unchecked_Type_Conversion
=>
3493 Sprint_Node
(Subtype_Mark
(Node
));
3495 Write_Str_With_Col_Check
("(");
3496 Sprint_Node_Sloc
(Expression
(Node
));
3499 when N_Unconstrained_Array_Definition
=>
3500 Write_Str_With_Col_Check_Sloc
("array (");
3505 Node1
:= First
(Subtype_Marks
(Node
));
3507 Sprint_Node
(Node1
);
3508 Write_Str_With_Col_Check
(" range <>");
3510 exit when Node1
= Empty
;
3515 Write_Str
(") of ");
3516 Sprint_Node
(Component_Definition
(Node
));
3518 when N_Unused_At_Start | N_Unused_At_End
=>
3519 Write_Indent_Str
("***** Error, unused node encountered *****");
3522 when N_Use_Package_Clause
=>
3523 Write_Indent_Str_Sloc
("use ");
3524 Sprint_Node_Sloc
(Name
(Node
));
3527 when N_Use_Type_Clause
=>
3528 Write_Indent_Str_Sloc
("use type ");
3529 Sprint_Node_Sloc
(Subtype_Mark
(Node
));
3532 when N_Validate_Unchecked_Conversion
=>
3533 Write_Indent_Str_Sloc
("validate unchecked_conversion (");
3534 Sprint_Node
(Source_Type
(Node
));
3536 Sprint_Node
(Target_Type
(Node
));
3539 when N_Variable_Reference_Marker
=>
3542 -- Enable the following code for debugging purposes only
3544 -- if Is_Read (Node) and then Is_Write (Node) then
3545 -- Write_Indent_Str ("rw#");
3547 -- elsif Is_Read (Node) then
3548 -- Write_Indent_Str ("r#");
3551 -- pragma Assert (Is_Write (Node));
3552 -- Write_Indent_Str ("w#");
3555 -- Write_Id (Target (Node));
3556 -- Write_Char ('#');
3559 Write_Indent_Str_Sloc
("when ");
3560 Sprint_Bar_List
(Discrete_Choices
(Node
));
3562 Sprint_Node
(Component_List
(Node
));
3564 when N_Variant_Part
=>
3566 Write_Indent_Str_Sloc
("case ");
3567 Sprint_Node
(Name
(Node
));
3569 Sprint_Indented_List
(Variants
(Node
));
3570 Write_Indent_Str
("end case");
3573 when N_With_Clause
=>
3575 -- Special test, if we are dumping the original tree only,
3576 -- then we want to eliminate the bogus with clauses that
3577 -- correspond to the non-existent children of Text_IO.
3579 if Dump_Original_Only
3580 and then Is_Text_IO_Special_Unit
(Name
(Node
))
3584 -- Normal case, output the with clause
3587 if First_Name
(Node
) or else not Dump_Original_Only
then
3589 -- Ada 2005 (AI-50217): Print limited with_clauses
3591 if Private_Present
(Node
) and Limited_Present
(Node
) then
3592 Write_Indent_Str
("limited private with ");
3594 elsif Private_Present
(Node
) then
3595 Write_Indent_Str
("private with ");
3597 elsif Limited_Present
(Node
) then
3598 Write_Indent_Str
("limited with ");
3601 Write_Indent_Str
("with ");
3608 Sprint_Node_Sloc
(Name
(Node
));
3610 if Last_Name
(Node
) or else not Dump_Original_Only
then
3616 -- Print aspects, except for special case of package declaration,
3617 -- where the aspects are printed inside the package specification.
3619 if Has_Aspects
(Node
)
3620 and then Nkind
(Node
) not in
3621 N_Generic_Package_Declaration | N_Package_Declaration
3622 and then not Is_Empty_List
(Aspect_Specifications
(Node
))
3624 Sprint_Aspect_Specifications
(Node
, Semicolon
=> True);
3627 if Nkind
(Node
) in N_Subexpr
and then Do_Range_Check
(Node
) then
3631 for J
in 1 .. Paren_Count
(Node
) loop
3635 Dump_Node
:= Save_Dump_Node
;
3636 end Sprint_Node_Actual
;
3638 ----------------------
3639 -- Sprint_Node_List --
3640 ----------------------
3642 procedure Sprint_Node_List
(List
: List_Id
; New_Lines
: Boolean := False) is
3646 if Is_Non_Empty_List
(List
) then
3647 Node
:= First
(List
);
3652 exit when Node
= Empty
;
3656 if New_Lines
and then Column
/= 1 then
3659 end Sprint_Node_List
;
3661 ----------------------
3662 -- Sprint_Node_Sloc --
3663 ----------------------
3665 procedure Sprint_Node_Sloc
(Node
: Node_Id
) is
3669 if Debug_Generated_Code
and then Present
(Dump_Node
) then
3670 Set_Sloc
(Dump_Node
, Sloc
(Node
));
3673 end Sprint_Node_Sloc
;
3675 ---------------------
3676 -- Sprint_Opt_Node --
3677 ---------------------
3679 procedure Sprint_Opt_Node
(Node
: Node_Id
) is
3681 if Present
(Node
) then
3685 end Sprint_Opt_Node
;
3687 --------------------------
3688 -- Sprint_Opt_Node_List --
3689 --------------------------
3691 procedure Sprint_Opt_Node_List
(List
: List_Id
) is
3693 if Present
(List
) then
3694 Sprint_Node_List
(List
);
3696 end Sprint_Opt_Node_List
;
3698 ---------------------------------
3699 -- Sprint_Opt_Paren_Comma_List --
3700 ---------------------------------
3702 procedure Sprint_Opt_Paren_Comma_List
(List
: List_Id
) is
3704 if Is_Non_Empty_List
(List
) then
3706 Sprint_Paren_Comma_List
(List
);
3708 end Sprint_Opt_Paren_Comma_List
;
3710 -----------------------------
3711 -- Sprint_Paren_Comma_List --
3712 -----------------------------
3714 procedure Sprint_Paren_Comma_List
(List
: List_Id
) is
3716 Node_Exists
: Boolean := False;
3720 if Is_Non_Empty_List
(List
) then
3722 if Dump_Original_Only
then
3724 while Present
(N
) loop
3725 if not Is_Rewrite_Insertion
(N
) then
3726 Node_Exists
:= True;
3733 if not Node_Exists
then
3738 Write_Str_With_Col_Check
("(");
3739 Sprint_Comma_List
(List
);
3742 end Sprint_Paren_Comma_List
;
3744 ----------------------
3745 -- Sprint_Right_Opnd --
3746 ----------------------
3748 procedure Sprint_Right_Opnd
(N
: Node_Id
) is
3749 Opnd
: constant Node_Id
:= Right_Opnd
(N
);
3752 if Paren_Count
(Opnd
) /= 0
3753 or else Op_Prec
(Nkind
(Opnd
)) > Op_Prec
(Nkind
(N
))
3762 end Sprint_Right_Opnd
;
3768 procedure Update_Itype
(Node
: Node_Id
) is
3770 if Present
(Etype
(Node
))
3771 and then Is_Itype
(Etype
(Node
))
3772 and then Debug_Generated_Code
3774 Set_Sloc
(Etype
(Node
), Sloc
(Node
));
3778 ---------------------
3779 -- Write_Char_Sloc --
3780 ---------------------
3782 procedure Write_Char_Sloc
(C
: Character) is
3784 if Debug_Generated_Code
and then C
/= ' ' then
3789 end Write_Char_Sloc
;
3791 --------------------------------
3792 -- Write_Condition_And_Reason --
3793 --------------------------------
3795 procedure Write_Condition_And_Reason
(Node
: Node_Id
) is
3796 Cond
: constant Node_Id
:= Condition
(Node
);
3797 Image
: constant String := RT_Exception_Code
'Image
3798 (RT_Exception_Code
'Val
3799 (UI_To_Int
(Reason
(Node
))));
3802 if Present
(Cond
) then
3804 -- If condition is a single entity, or NOT with a single entity,
3805 -- output all on one line, since it will likely fit just fine.
3807 if Is_Entity_Name
(Cond
)
3808 or else (Nkind
(Cond
) = N_Op_Not
3809 and then Is_Entity_Name
(Right_Opnd
(Cond
)))
3811 Write_Str_With_Col_Check
(" when ");
3815 -- Otherwise for more complex condition, multiple lines
3818 Write_Str_With_Col_Check
(" when");
3819 Indent
:= Indent
+ 2;
3823 Indent
:= Indent
- 2;
3826 -- If no condition, just need a space (all on one line)
3836 for J
in 4 .. Image
'Last loop
3837 if Image
(J
) = '_' then
3840 Write_Char
(Fold_Lower
(Image
(J
)));
3845 end Write_Condition_And_Reason
;
3847 --------------------------------
3848 -- Write_Corresponding_Source --
3849 --------------------------------
3851 procedure Write_Corresponding_Source
(S
: String) is
3853 Src
: Source_Buffer_Ptr
;
3856 -- Ignore if there is no current source file, or we're not in dump
3857 -- source text mode, or if in freeze actions.
3859 if Current_Source_File
> No_Source_File
3860 and then Dump_Source_Text
3861 and then Freeze_Indent
= 0
3864 -- Ignore null string
3870 -- Ignore space or semicolon at end of given string
3872 if S
(S
'Last) = ' ' or else S
(S
'Last) = ';' then
3873 Write_Corresponding_Source
(S
(S
'First .. S
'Last - 1));
3877 -- Loop to look at next lines not yet printed in source file
3880 Last_Line_Printed
+ 1 .. Last_Source_Line
(Current_Source_File
)
3882 Src
:= Source_Text
(Current_Source_File
);
3883 Loc
:= Line_Start
(L
, Current_Source_File
);
3885 -- If comment, keep looking
3887 if Src
(Loc
.. Loc
+ 1) = "--" then
3890 -- Search to first non-blank
3893 while Src
(Loc
) not in Line_Terminator
loop
3897 if Src
(Loc
) /= ' ' and then Src
(Loc
) /= ASCII
.HT
then
3899 -- Loop through characters in string to see if we match
3901 for J
in S
'Range loop
3903 -- If mismatch, then not the case we are looking for
3905 if Src
(Loc
) /= S
(J
) then
3912 -- If we fall through, string matched, if white space or
3913 -- semicolon after the matched string, this is the case
3914 -- we are looking for.
3916 if Src
(Loc
) in Line_Terminator
3917 or else Src
(Loc
) = ' '
3918 or else Src
(Loc
) = ASCII
.HT
3919 or else Src
(Loc
) = ';'
3921 -- So output source lines up to and including this one
3923 Write_Source_Lines
(L
);
3932 -- Line was all blanks, or a comment line, keep looking
3936 end Write_Corresponding_Source
;
3938 -----------------------
3939 -- Write_Discr_Specs --
3940 -----------------------
3942 procedure Write_Discr_Specs
(N
: Node_Id
) is
3947 Specs
:= Discriminant_Specifications
(N
);
3949 if Present
(Specs
) then
3950 Write_Str_With_Col_Check
(" (");
3951 Spec
:= First
(Specs
);
3956 exit when Spec
= Empty
;
3958 -- Add semicolon, unless we are printing original tree and the
3959 -- next specification is part of a list (but not the first
3960 -- element of that list)
3962 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
3969 end Write_Discr_Specs
;
3975 procedure Write_Ekind
(E
: Entity_Id
) is
3976 S
: constant String := Entity_Kind
'Image (Ekind
(E
));
3979 Name_Len
:= S
'Length;
3980 Name_Buffer
(1 .. Name_Len
) := S
;
3981 Set_Casing
(Mixed_Case
);
3982 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3989 procedure Write_Id
(N
: Node_Id
) is
3991 -- Deal with outputting Itype
3993 -- Note: if we are printing the full tree with -gnatds, then we may
3994 -- end up picking up the Associated_Node link from a generic template
3995 -- here which overlaps the Entity field, but as documented, Write_Itype
3996 -- is defended against junk calls.
3998 if Nkind
(N
) in N_Entity
then
4000 elsif Nkind
(N
) in N_Has_Entity
then
4001 Write_Itype
(Entity
(N
));
4004 -- Case of a defining identifier
4006 if Nkind
(N
) = N_Defining_Identifier
then
4008 -- If defining identifier has an interface name (and no
4009 -- address clause), then we output the interface name.
4011 if (Is_Imported
(N
) or else Is_Exported
(N
))
4012 and then Present
(Interface_Name
(N
))
4013 and then No
(Address_Clause
(N
))
4015 String_To_Name_Buffer
(Strval
(Interface_Name
(N
)));
4016 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
4018 -- If no interface name (or inactive because there was
4019 -- an address clause), then just output the Chars name.
4022 Write_Name_With_Col_Check
(Chars
(N
));
4025 -- Case of selector of an expanded name where the expanded name
4026 -- has an associated entity, output this entity. Check that the
4027 -- entity or associated node is of the right kind, see above.
4029 elsif Nkind
(Parent
(N
)) = N_Expanded_Name
4030 and then Selector_Name
(Parent
(N
)) = N
4031 and then Present
(Entity_Or_Associated_Node
(Parent
(N
)))
4032 and then Nkind
(Entity
(Parent
(N
))) in N_Entity
4034 Write_Id
(Entity
(Parent
(N
)));
4036 -- For any other node with an associated entity, output it
4038 elsif Nkind
(N
) in N_Has_Entity
4039 and then Present
(Entity_Or_Associated_Node
(N
))
4040 and then Nkind
(Entity_Or_Associated_Node
(N
)) in N_Entity
4042 Write_Id
(Entity
(N
));
4044 -- All other cases, we just print the Chars field
4047 Write_Name_With_Col_Check
(Chars
(N
));
4051 -----------------------
4052 -- Write_Identifiers --
4053 -----------------------
4055 function Write_Identifiers
(Node
: Node_Id
) return Boolean is
4057 Sprint_Node
(Defining_Identifier
(Node
));
4058 Update_Itype
(Defining_Identifier
(Node
));
4060 -- The remainder of the declaration must be printed unless we are
4061 -- printing the original tree and this is not the last identifier
4064 not Dump_Original_Only
or else not More_Ids
(Node
);
4066 end Write_Identifiers
;
4068 ------------------------
4069 -- Write_Implicit_Def --
4070 ------------------------
4072 procedure Write_Implicit_Def
(E
: Entity_Id
) is
4077 when E_Array_Subtype
=>
4078 Write_Str_With_Col_Check
("subtype ");
4080 Write_Str_With_Col_Check
(" is ");
4081 Write_Id
(Base_Type
(E
));
4082 Write_Str_With_Col_Check
(" (");
4084 Ind
:= First_Index
(E
);
4085 while Present
(Ind
) loop
4089 if Present
(Ind
) then
4096 when E_Enumeration_Subtype
4097 | E_Signed_Integer_Subtype
4099 Write_Str_With_Col_Check
("subtype ");
4102 Write_Id
(Etype
(E
));
4103 Write_Str_With_Col_Check
(" range ");
4104 Sprint_Node
(Scalar_Range
(E
));
4108 Write_Str_With_Col_Check
("type ");
4110 Write_Str_With_Col_Check
(" is <");
4114 end Write_Implicit_Def
;
4120 procedure Write_Indent
is
4121 Loc
: constant Source_Ptr
:= Sloc
(Dump_Node
);
4124 if Indent_Annull_Flag
then
4125 Indent_Annull_Flag
:= False;
4127 -- Deal with Dump_Source_Text output. Note that we ignore implicit
4128 -- label declarations, since they typically have the sloc of the
4129 -- corresponding label, which really messes up the -gnatL output.
4132 and then Loc
> No_Location
4133 and then Nkind
(Dump_Node
) /= N_Implicit_Label_Declaration
4135 if Get_Source_File_Index
(Loc
) = Current_Source_File
then
4137 (Get_Physical_Line_Number
(Sloc
(Dump_Node
)));
4143 for J
in 1 .. Indent
loop
4149 ------------------------------
4150 -- Write_Indent_Identifiers --
4151 ------------------------------
4153 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean is
4155 -- We need to start a new line for every node, except in the case
4156 -- where we are printing the original tree and this is not the first
4157 -- defining identifier in the list.
4159 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
4162 -- If printing original tree and this is not the first defining
4163 -- identifier in the list, then the previous call to this procedure
4164 -- printed only the name, and we add a comma to separate the names.
4170 Sprint_Node
(Defining_Identifier
(Node
));
4172 -- The remainder of the declaration must be printed unless we are
4173 -- printing the original tree and this is not the last identifier
4176 not Dump_Original_Only
or else not More_Ids
(Node
);
4177 end Write_Indent_Identifiers
;
4179 -----------------------------------
4180 -- Write_Indent_Identifiers_Sloc --
4181 -----------------------------------
4183 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean is
4185 -- We need to start a new line for every node, except in the case
4186 -- where we are printing the original tree and this is not the first
4187 -- defining identifier in the list.
4189 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
4192 -- If printing original tree and this is not the first defining
4193 -- identifier in the list, then the previous call to this procedure
4194 -- printed only the name, and we add a comma to separate the names.
4201 Sprint_Node
(Defining_Identifier
(Node
));
4203 -- The remainder of the declaration must be printed unless we are
4204 -- printing the original tree and this is not the last identifier
4206 return not Dump_Original_Only
or else not More_Ids
(Node
);
4207 end Write_Indent_Identifiers_Sloc
;
4209 ----------------------
4210 -- Write_Indent_Str --
4211 ----------------------
4213 procedure Write_Indent_Str
(S
: String) is
4215 Write_Corresponding_Source
(S
);
4218 end Write_Indent_Str
;
4220 ---------------------------
4221 -- Write_Indent_Str_Sloc --
4222 ---------------------------
4224 procedure Write_Indent_Str_Sloc
(S
: String) is
4226 Write_Corresponding_Source
(S
);
4229 end Write_Indent_Str_Sloc
;
4235 procedure Write_Itype
(Typ
: Entity_Id
) is
4237 procedure Write_Header
(T
: Boolean := True);
4238 -- Write type if T is True, subtype if T is false
4244 procedure Write_Header
(T
: Boolean := True) is
4247 Write_Str
("[type ");
4249 Write_Str
("[subtype ");
4252 Write_Name_With_Col_Check
(Chars
(Typ
));
4256 -- Start of processing for Write_Itype
4259 if Nkind
(Typ
) in N_Entity
4260 and then Is_Itype
(Typ
)
4261 and then not Itype_Printed
(Typ
)
4263 -- Itype to be printed
4266 B
: constant Entity_Id
:= Etype
(Typ
);
4267 P
: constant Node_Id
:= Parent
(Typ
);
4268 S
: constant Saved_Output_Buffer
:= Save_Output_Buffer
;
4269 -- Save current output buffer
4271 Old_Sloc
: Source_Ptr
;
4272 -- Save sloc of related node, so it is not modified when
4273 -- printing with -gnatD.
4278 -- Write indentation at start of line
4280 for J
in 1 .. Indent
loop
4284 -- If we have a constructed declaration for the itype, print it
4287 and then Nkind
(P
) in N_Declaration
4288 and then Defining_Entity
(P
) = Typ
4290 -- We must set Itype_Printed true before the recursive call to
4291 -- print the node, otherwise we get an infinite recursion.
4293 Set_Itype_Printed
(Typ
, True);
4295 -- Write the declaration enclosed in [], avoiding new line
4296 -- at start of declaration, and semicolon at end.
4298 -- Note: The itype may be imported from another unit, in which
4299 -- case we do not want to modify the Sloc of the declaration.
4300 -- Otherwise the itype may appear to be in the current unit,
4301 -- and the back-end will reject a reference out of scope.
4304 Indent_Annull_Flag
:= True;
4305 Old_Sloc
:= Sloc
(P
);
4307 Set_Sloc
(P
, Old_Sloc
);
4308 Write_Erase_Char
(';');
4310 -- If no constructed declaration, then we have to concoct the
4311 -- source corresponding to the type entity that we have at hand.
4316 -- Access types and subtypes
4319 Write_Header
(Ekind
(Typ
) = E_Access_Type
);
4321 if Can_Never_Be_Null
(Typ
) then
4322 Write_Str
("not null ");
4325 Write_Str
("access ");
4327 if Is_Access_Constant
(Typ
) then
4328 Write_Str
("constant ");
4331 Write_Id
(Directly_Designated_Type
(Typ
));
4335 when E_Array_Type
=>
4337 Write_Str
("array (");
4339 X
:= First_Index
(Typ
);
4343 if not Is_Constrained
(Typ
) then
4344 Write_Str
(" range <>");
4352 Write_Str
(") of ");
4353 X
:= Component_Type
(Typ
);
4355 -- Preserve sloc of component type, which is defined
4356 -- elsewhere than the itype (see comment above).
4358 Old_Sloc
:= Sloc
(X
);
4360 Set_Sloc
(X
, Old_Sloc
);
4364 -- Preserve Sloc of index subtypes, as above
4366 when E_Array_Subtype
=>
4367 Write_Header
(False);
4368 Write_Id
(Etype
(Typ
));
4371 X
:= First_Index
(Typ
);
4373 Old_Sloc
:= Sloc
(X
);
4375 Set_Sloc
(X
, Old_Sloc
);
4383 -- Signed integer types, and modular integer subtypes,
4384 -- and also enumeration subtypes.
4386 when E_Enumeration_Subtype
4387 | E_Modular_Integer_Subtype
4388 | E_Signed_Integer_Subtype
4389 | E_Signed_Integer_Type
4391 Write_Header
(Ekind
(Typ
) = E_Signed_Integer_Type
);
4393 if Ekind
(Typ
) = E_Signed_Integer_Type
then
4399 -- Print bounds if different from base type
4402 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
4403 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
4408 -- B can either be a scalar type, in which case the
4409 -- declaration of Typ may constrain it with different
4410 -- bounds, or a private type, in which case we know
4411 -- that the declaration of Typ cannot have a scalar
4414 if Is_Scalar_Type
(B
) then
4415 BL
:= Type_Low_Bound
(B
);
4416 BH
:= Type_High_Bound
(B
);
4424 and then Nkind
(L
) = N_Integer_Literal
4425 and then Nkind
(H
) = N_Integer_Literal
4426 and then Nkind
(BL
) = N_Integer_Literal
4427 and then Nkind
(BH
) = N_Integer_Literal
4428 and then UI_Eq
(Intval
(L
), Intval
(BL
))
4429 and then UI_Eq
(Intval
(H
), Intval
(BH
)))
4434 Write_Str
(" range ");
4441 -- Modular integer types
4443 when E_Modular_Integer_Type
=>
4447 if No
(Modulus
(Typ
)) then
4448 Write_Uint_With_Col_Check
(Uint_0
, Auto
);
4450 Write_Uint_With_Col_Check
(Modulus
(Typ
), Auto
);
4453 -- Floating-point types and subtypes
4455 when E_Floating_Point_Subtype
4456 | E_Floating_Point_Type
4458 Write_Header
(Ekind
(Typ
) = E_Floating_Point_Type
);
4460 if Ekind
(Typ
) = E_Floating_Point_Type
then
4466 if Digits_Value
(Typ
) /= Digits_Value
(B
) then
4467 Write_Str
(" digits ");
4468 Write_Uint_With_Col_Check
4469 (Digits_Value
(Typ
), Decimal
);
4472 -- Print bounds if not different from base type
4475 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
4476 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
4477 BL
: constant Node_Id
:= Type_Low_Bound
(B
);
4478 BH
: constant Node_Id
:= Type_High_Bound
(B
);
4482 and then Nkind
(L
) = N_Real_Literal
4483 and then Nkind
(H
) = N_Real_Literal
4484 and then Nkind
(BL
) = N_Real_Literal
4485 and then Nkind
(BH
) = N_Real_Literal
4486 and then UR_Eq
(Realval
(L
), Realval
(BL
))
4487 and then UR_Eq
(Realval
(H
), Realval
(BH
))
4492 Write_Str
(" range ");
4499 -- Ordinary fixed-point types and subtypes
4501 when E_Ordinary_Fixed_Point_Subtype
4502 | E_Ordinary_Fixed_Point_Type
4504 Write_Header
(Ekind
(Typ
) = E_Ordinary_Fixed_Point_Type
);
4506 Write_Str
("delta ");
4507 Write_Ureal_With_Col_Check_Sloc
(Delta_Value
(Typ
));
4508 Write_Str
(" range ");
4509 Sprint_Node
(Type_Low_Bound
(Typ
));
4511 Sprint_Node
(Type_High_Bound
(Typ
));
4513 -- Decimal fixed-point types and subtypes
4515 when E_Decimal_Fixed_Point_Subtype
4516 | E_Decimal_Fixed_Point_Type
4518 Write_Header
(Ekind
(Typ
) = E_Decimal_Fixed_Point_Type
);
4520 Write_Str
("delta ");
4521 Write_Ureal_With_Col_Check_Sloc
(Delta_Value
(Typ
));
4522 Write_Str
(" digits ");
4523 Write_Uint_With_Col_Check
(Digits_Value
(Typ
), Decimal
);
4527 when E_Record_Subtype
4528 | E_Record_Subtype_With_Private
4530 Write_Header
(False);
4531 Write_Str
("record");
4537 C
:= First_Entity
(Typ
);
4538 while Present
(C
) loop
4542 Write_Id
(Etype
(C
));
4548 Write_Indent_Str
(" end record");
4552 when E_Class_Wide_Subtype
4555 Write_Header
(Ekind
(Typ
) = E_Class_Wide_Type
);
4556 Write_Name_With_Col_Check
(Chars
(Etype
(Typ
)));
4557 Write_Str
("'Class");
4561 when E_Subprogram_Type
=>
4564 if Etype
(Typ
) = Standard_Void_Type
then
4565 Write_Str
("procedure");
4567 Write_Str
("function");
4570 if Present
(First_Entity
(Typ
)) then
4577 Param
:= First_Entity
(Typ
);
4582 if Ekind
(Param
) = E_In_Out_Parameter
then
4583 Write_Str
("in out ");
4584 elsif Ekind
(Param
) = E_Out_Parameter
then
4588 Write_Id
(Etype
(Param
));
4589 Next_Entity
(Param
);
4590 exit when No
(Param
);
4594 if Present
(Extra_Formals
(Typ
)) then
4595 Param
:= Extra_Formals
(Typ
);
4597 while Present
(Param
) loop
4601 Write_Id
(Etype
(Param
));
4603 Param
:= Extra_Formal
(Param
);
4610 elsif Present
(Extra_Formals
(Typ
)) then
4617 Param
:= Extra_Formals
(Typ
);
4619 while Present
(Param
) loop
4622 Write_Id
(Etype
(Param
));
4624 if Present
(Extra_Formal
(Param
)) then
4628 Param
:= Extra_Formal
(Param
);
4635 if Etype
(Typ
) /= Standard_Void_Type
then
4636 Write_Str
(" return ");
4637 Write_Id
(Etype
(Typ
));
4640 when E_String_Literal_Subtype
=>
4642 L
: constant Uint
:=
4643 Expr_Value
(String_Literal_Low_Bound
(Typ
));
4644 Len
: constant Uint
:=
4645 String_Literal_Length
(Typ
);
4647 Write_Header
(False);
4648 Write_Str
("String (");
4649 Write_Int
(UI_To_Int
(L
));
4651 Write_Int
(UI_To_Int
(L
+ Len
) - 1);
4655 -- For all other Itypes, print a triple ? (fill in later
4659 Write_Header
(True);
4664 -- Add terminating bracket and restore output buffer
4668 Restore_Output_Buffer
(S
);
4671 Set_Itype_Printed
(Typ
);
4675 -------------------------------
4676 -- Write_Name_With_Col_Check --
4677 -------------------------------
4679 procedure Write_Name_With_Col_Check
(N
: Name_Id
) is
4685 -- Avoid crashing on invalid Name_Ids
4687 if not Is_Valid_Name
(N
) then
4688 Write_Str
("<invalid name ");
4689 Write_Int
(Int
(N
));
4694 Get_Name_String
(N
);
4696 -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4697 -- upper case letter, nnn is one or more digits and b is a lower case
4698 -- letter by C...b, so that listings do not depend on serial numbers.
4700 if Debug_Flag_II
then
4702 while J
< Name_Len
- 1 loop
4703 if Name_Buffer
(J
) in 'A' .. 'Z'
4704 and then Name_Buffer
(J
+ 1) in '0' .. '9'
4707 while K
< Name_Len
loop
4708 exit when Name_Buffer
(K
) not in '0' .. '9';
4712 if Name_Buffer
(K
) in 'a' .. 'z' then
4713 L
:= Name_Len
- K
+ 1;
4715 Name_Buffer
(J
+ 4 .. J
+ L
+ 3) :=
4716 Name_Buffer
(K
.. Name_Len
);
4717 Name_Buffer
(J
+ 1 .. J
+ 3) := "...";
4718 Name_Len
:= J
+ L
+ 3;
4731 -- Fall through for normal case
4733 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
4734 end Write_Name_With_Col_Check
;
4736 ------------------------------------
4737 -- Write_Name_With_Col_Check_Sloc --
4738 ------------------------------------
4740 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
) is
4742 -- Avoid crashing on invalid Name_Ids
4744 if not Is_Valid_Name
(N
) then
4745 Write_Str
("<invalid name ");
4746 Write_Int
(Int
(N
));
4751 Get_Name_String
(N
);
4752 Write_Str_With_Col_Check_Sloc
(Name_Buffer
(1 .. Name_Len
));
4753 end Write_Name_With_Col_Check_Sloc
;
4755 --------------------
4756 -- Write_Operator --
4757 --------------------
4759 procedure Write_Operator
(N
: Node_Id
; S
: String) is
4760 F
: Natural := S
'First;
4761 T
: Natural := S
'Last;
4764 -- If no overflow check, just write string out, and we are done
4766 if not Do_Overflow_Check
(N
) then
4769 -- If overflow check, we want to surround the operator with curly
4770 -- brackets, but not include spaces within the brackets.
4783 Write_Str_Sloc
(S
(F
.. T
));
4786 if S
(S
'Last) = ' ' then
4792 -----------------------
4793 -- Write_Param_Specs --
4794 -----------------------
4796 procedure Write_Param_Specs
(N
: Node_Id
) is
4797 Specs
: constant List_Id
:= Parameter_Specifications
(N
);
4798 Specs_Present
: constant Boolean := Is_Non_Empty_List
(Specs
);
4805 Output
: Boolean := False;
4806 -- Set true if we output at least one parameter
4809 -- Write out explicit specs from Parameter_Specifications list
4811 if Specs_Present
then
4812 Write_Str_With_Col_Check
(" (");
4815 Spec
:= First
(Specs
);
4818 Formal
:= Defining_Identifier
(Spec
);
4820 exit when Spec
= Empty
;
4822 -- Add semicolon, unless we are printing original tree and the
4823 -- next specification is part of a list (but not the first element
4826 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
4832 -- See if we have extra formals
4834 if Nkind
(N
) in N_Function_Specification | N_Procedure_Specification
then
4835 Ent
:= Defining_Entity
(N
);
4837 -- Loop to write extra formals (if any)
4839 if Present
(Ent
) and then Is_Subprogram
(Ent
) then
4840 Extras
:= Extra_Formals
(Ent
);
4842 if Present
(Extras
) then
4843 if not Specs_Present
then
4844 Write_Str_With_Col_Check
(" (");
4849 while Present
(Formal
) loop
4850 if Specs_Present
or else Formal
/= Extras
then
4854 Write_Name_With_Col_Check
(Chars
(Formal
));
4856 Write_Name_With_Col_Check
(Chars
(Etype
(Formal
)));
4857 Formal
:= Extra_Formal
(Formal
);
4866 end Write_Param_Specs
;
4868 -----------------------
4869 -- Write_Rewrite_Str --
4870 -----------------------
4872 procedure Write_Rewrite_Str
(S
: String) is
4874 if not Dump_Generated_Only
then
4875 if S
'Length = 3 and then S
= ">>>" then
4878 Write_Str_With_Col_Check
(S
);
4881 end Write_Rewrite_Str
;
4883 -----------------------
4884 -- Write_Source_Line --
4885 -----------------------
4887 procedure Write_Source_Line
(L
: Physical_Line_Number
) is
4889 Src
: Source_Buffer_Ptr
;
4893 if Dump_Source_Text
then
4894 Src
:= Source_Text
(Current_Source_File
);
4895 Loc
:= Line_Start
(L
, Current_Source_File
);
4898 -- See if line is a comment line, if not, and if not line one,
4899 -- precede with blank line.
4902 while Src
(Scn
) = ' ' or else Src
(Scn
) = ASCII
.HT
loop
4906 if (Src
(Scn
) in Line_Terminator
4907 or else Src
(Scn
.. Scn
+ 1) /= "--")
4913 -- Now write the source text of the line
4916 Write_Int
(Int
(L
));
4919 -- We need to check for EOF here, in case the last line of the source
4920 -- file does not have a Line_Terminator.
4922 while Src
(Loc
) not in Line_Terminator | EOF
loop
4923 Write_Char
(Src
(Loc
));
4927 end Write_Source_Line
;
4929 ------------------------
4930 -- Write_Source_Lines --
4931 ------------------------
4933 procedure Write_Source_Lines
(L
: Physical_Line_Number
) is
4935 while Last_Line_Printed
< L
loop
4936 Last_Line_Printed
:= Last_Line_Printed
+ 1;
4937 Write_Source_Line
(Last_Line_Printed
);
4939 end Write_Source_Lines
;
4941 --------------------
4942 -- Write_Str_Sloc --
4943 --------------------
4945 procedure Write_Str_Sloc
(S
: String) is
4947 for J
in S
'Range loop
4948 Write_Char_Sloc
(S
(J
));
4952 ------------------------------
4953 -- Write_Str_With_Col_Check --
4954 ------------------------------
4956 procedure Write_Str_With_Col_Check
(S
: String) is
4958 if Int
(S
'Last) + Column
> Sprint_Line_Limit
then
4959 Write_Indent_Str
(" ");
4961 if S
(S
'First) = ' ' then
4962 Write_Str
(S
(S
'First + 1 .. S
'Last));
4970 end Write_Str_With_Col_Check
;
4972 -----------------------------------
4973 -- Write_Str_With_Col_Check_Sloc --
4974 -----------------------------------
4976 procedure Write_Str_With_Col_Check_Sloc
(S
: String) is
4978 if Int
(S
'Last) + Column
> Sprint_Line_Limit
then
4979 Write_Indent_Str
(" ");
4981 if S
(S
'First) = ' ' then
4982 Write_Str_Sloc
(S
(S
'First + 1 .. S
'Last));
4990 end Write_Str_With_Col_Check_Sloc
;
4992 ---------------------------
4993 -- Write_Subprogram_Name --
4994 ---------------------------
4996 procedure Write_Subprogram_Name
(N
: Node_Id
) is
4998 if not Comes_From_Source
(N
)
4999 and then Is_Entity_Name
(N
)
5002 Ent
: constant Entity_Id
:= Entity
(N
);
5004 if not In_Extended_Main_Source_Unit
(Ent
)
5005 and then In_Predefined_Unit
(Ent
)
5007 -- Run-time routine name, output name with a preceding dollar
5008 -- making sure that we do not get a line split between them.
5010 Col_Check
(Length_Of_Name
(Chars
(Ent
)) + 1);
5012 Write_Name
(Chars
(Ent
));
5018 -- Normal case, not a run-time routine name
5021 end Write_Subprogram_Name
;
5023 -------------------------------
5024 -- Write_Uint_With_Col_Check --
5025 -------------------------------
5027 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
) is
5029 Col_Check
(UI_Decimal_Digits_Hi
(U
));
5030 UI_Write
(U
, Format
);
5031 end Write_Uint_With_Col_Check
;
5033 ------------------------------------
5034 -- Write_Uint_With_Col_Check_Sloc --
5035 ------------------------------------
5037 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
) is
5039 Col_Check
(UI_Decimal_Digits_Hi
(U
));
5041 UI_Write
(U
, Format
);
5042 end Write_Uint_With_Col_Check_Sloc
;
5044 -------------------------------------
5045 -- Write_Ureal_With_Col_Check_Sloc --
5046 -------------------------------------
5048 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
) is
5049 D
: constant Uint
:= Denominator
(U
);
5050 N
: constant Uint
:= Numerator
(U
);
5052 Col_Check
(UI_Decimal_Digits_Hi
(D
) + UI_Decimal_Digits_Hi
(N
) + 4);
5054 UR_Write
(U
, Brackets
=> True);
5055 end Write_Ureal_With_Col_Check_Sloc
;