1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Csets
; use Csets
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Fname
; use Fname
;
33 with Namet
; use Namet
;
34 with Nlists
; use Nlists
;
36 with Output
; use Output
;
37 with Rtsfind
; use Rtsfind
;
38 with Sem_Eval
; use Sem_Eval
;
39 with Sem_Util
; use Sem_Util
;
40 with Sinfo
; use Sinfo
;
41 with Sinput
; use Sinput
;
42 with Sinput
.D
; use Sinput
.D
;
43 with Snames
; use Snames
;
44 with Stand
; use Stand
;
45 with Stringt
; use Stringt
;
46 with Uintp
; use Uintp
;
47 with Uname
; use Uname
;
48 with Urealp
; use Urealp
;
50 package body Sprint
is
51 Current_Source_File
: Source_File_Index
;
52 -- Index of source file whose generated code is being dumped
54 Dump_Node
: Node_Id
:= Empty
;
55 -- This is set to the current node, used for printing line numbers. In
56 -- Debug_Generated_Code mode, Dump_Node is set to the current node
57 -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
58 -- value. The call clears it back to Empty.
60 Debug_Sloc
: Source_Ptr
;
61 -- Sloc of first byte of line currently being written if we are
62 -- generating a source debug file.
64 Dump_Original_Only
: Boolean;
65 -- Set True if the -gnatdo (dump original tree) flag is set
67 Dump_Generated_Only
: Boolean;
68 -- Set True if the -gnatG (dump generated tree) debug flag is set
69 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
71 Dump_Freeze_Null
: Boolean;
72 -- Set True if freeze nodes and non-source null statements output
74 Freeze_Indent
: Int
:= 0;
75 -- Keep track of freeze indent level (controls output of blank lines before
76 -- procedures within expression freeze actions). Relevant only if we are
77 -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
78 -- output these blank lines in any case.
81 -- Number of columns for current line output indentation
83 Indent_Annull_Flag
: Boolean := False;
84 -- Set True if subsequent Write_Indent call to be ignored, gets reset
85 -- by this call, so it is only active to suppress a single indent call.
87 Last_Line_Printed
: Physical_Line_Number
;
88 -- This keeps track of the physical line number of the last source line
89 -- that has been output. The value is only valid in Dump_Source_Text mode.
91 -------------------------------
92 -- Operator Precedence Table --
93 -------------------------------
95 -- This table is used to decide whether a subexpression needs to be
96 -- parenthesized. The rule is that if an operand of an operator (which
97 -- for this purpose includes AND THEN and OR ELSE) is itself an operator
98 -- with a lower precedence than the operator (or equal precedence if
99 -- appearing as the right operand), then parentheses are required.
101 Op_Prec
: constant array (N_Subexpr
) of Short_Short_Integer :=
134 procedure Sprint_Left_Opnd
(N
: Node_Id
);
135 -- Print left operand of operator, parenthesizing if necessary
137 procedure Sprint_Right_Opnd
(N
: Node_Id
);
138 -- Print right operand of operator, parenthesizing if necessary
140 -----------------------
141 -- Local Subprograms --
142 -----------------------
144 procedure Col_Check
(N
: Nat
);
145 -- Check that at least N characters remain on current line, and if not,
146 -- then start an extra line with two characters extra indentation for
147 -- continuing text on the next line.
149 procedure Extra_Blank_Line
;
150 -- In some situations we write extra blank lines to separate the generated
151 -- code to make it more readable. However, these extra blank lines are not
152 -- generated in Dump_Source_Text mode, since there the source text lines
153 -- output with preceding blank lines are quite sufficient as separators.
154 -- This procedure writes a blank line if Dump_Source_Text is False.
156 procedure Indent_Annull
;
157 -- Causes following call to Write_Indent to be ignored. This is used when
158 -- a higher level node wants to stop a lower level node from starting a
159 -- new line, when it would otherwise be inclined to do so (e.g. the case
160 -- of an accept statement called from an accept alternative with a guard)
162 procedure Indent_Begin
;
163 -- Increase indentation level
165 procedure Indent_End
;
166 -- Decrease indentation level
168 procedure Print_Debug_Line
(S
: String);
169 -- Used to print output lines in Debug_Generated_Code mode (this is used
170 -- as the argument for a call to Set_Special_Output in package Output).
172 procedure Process_TFAI_RR_Flags
(Nod
: Node_Id
);
173 -- Given a divide, multiplication or division node, check the flags
174 -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
175 -- appropriate special syntax characters (# and @).
177 procedure Set_Debug_Sloc
;
178 -- If Dump_Node is non-empty, this routine sets the appropriate value
179 -- in its Sloc field, from the current location in the debug source file
180 -- that is currently being written.
182 procedure Sprint_And_List
(List
: List_Id
);
183 -- Print the given list with items separated by vertical "and"
185 procedure Sprint_Bar_List
(List
: List_Id
);
186 -- Print the given list with items separated by vertical bars
188 procedure Sprint_End_Label
191 -- Print the end label for a Handled_Sequence_Of_Statements in a body.
192 -- If there is not end label, use the defining identifier of the enclosing
193 -- construct. If the end label is present, treat it as a reference to the
194 -- defining entity of the construct: this guarantees that it carries the
195 -- proper sloc information for debugging purposes.
197 procedure Sprint_Node_Actual
(Node
: Node_Id
);
198 -- This routine prints its node argument. It is a lower level routine than
199 -- Sprint_Node, in that it does not bother about rewritten trees.
201 procedure Sprint_Node_Sloc
(Node
: Node_Id
);
202 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
203 -- sets the Sloc of the current debug node to be a copy of the Sloc
204 -- of the sprinted node Node. Note that this is done after printing
205 -- Node, so that the Sloc is the proper updated value for the debug file.
207 procedure Update_Itype
(Node
: Node_Id
);
208 -- Update the Sloc of an itype that is not attached to the tree, when
209 -- debugging expanded code. This routine is called from nodes whose
210 -- type can be an Itype, such as defining_identifiers that may be of
211 -- an anonymous access type, or ranges in slices.
213 procedure Write_Char_Sloc
(C
: Character);
214 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
215 -- called to ensure that the current node has a proper Sloc set.
217 procedure Write_Condition_And_Reason
(Node
: Node_Id
);
218 -- Write Condition and Reason codes of Raise_xxx_Error node
220 procedure Write_Corresponding_Source
(S
: String);
221 -- If S is a string with a single keyword (possibly followed by a space),
222 -- and if the next non-comment non-blank source line matches this keyword,
223 -- then output all source lines up to this matching line.
225 procedure Write_Discr_Specs
(N
: Node_Id
);
226 -- Output discriminant specification for node, which is any of the type
227 -- declarations that can have discriminants.
229 procedure Write_Ekind
(E
: Entity_Id
);
230 -- Write the String corresponding to the Ekind without "E_"
232 procedure Write_Id
(N
: Node_Id
);
233 -- N is a node with a Chars field. This procedure writes the name that
234 -- will be used in the generated code associated with the name. For a
235 -- node with no associated entity, this is simply the Chars field. For
236 -- the case where there is an entity associated with the node, we print
237 -- the name associated with the entity (since it may have been encoded).
238 -- One other special case is that an entity has an active external name
239 -- (i.e. an external name present with no address clause), then this
240 -- external name is output. This procedure also deals with outputting
241 -- declarations of referenced itypes, if not output earlier.
243 function Write_Identifiers
(Node
: Node_Id
) return Boolean;
244 -- Handle node where the grammar has a list of defining identifiers, but
245 -- the tree has a separate declaration for each identifier. Handles the
246 -- printing of the defining identifier, and returns True if the type and
247 -- initialization information is to be printed, False if it is to be
248 -- skipped (the latter case happens when printing defining identifiers
249 -- other than the first in the original tree output case).
251 procedure Write_Implicit_Def
(E
: Entity_Id
);
252 pragma Warnings
(Off
, Write_Implicit_Def
);
253 -- Write the definition of the implicit type E according to its Ekind
254 -- For now a debugging procedure, but might be used in the future.
256 procedure Write_Indent
;
257 -- Start a new line and write indentation spacing
259 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean;
260 -- Like Write_Identifiers except that each new printed declaration
261 -- is at the start of a new line.
263 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean;
264 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
265 -- mode, the Sloc of the current debug node is set to point to the
266 -- first output identifier.
268 procedure Write_Indent_Str
(S
: String);
269 -- Start a new line and write indent spacing followed by given string
271 procedure Write_Indent_Str_Sloc
(S
: String);
272 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
273 -- the Sloc of the current node is set to the first non-blank character
276 procedure Write_Itype
(Typ
: Entity_Id
);
277 -- If Typ is an Itype that has not been written yet, write it. If Typ is
278 -- any other kind of entity or tree node, the call is ignored.
280 procedure Write_Name_With_Col_Check
(N
: Name_Id
);
281 -- Write name (using Write_Name) with initial column check, and possible
282 -- initial Write_Indent (to get new line) if current line is too full.
284 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
);
285 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
286 -- mode, sets Sloc of current debug node to first character of name.
288 procedure Write_Operator
(N
: Node_Id
; S
: String);
289 -- Like Write_Str_Sloc, used for operators, encloses the string in
290 -- characters {} if the Do_Overflow flag is set on the node N.
292 procedure Write_Param_Specs
(N
: Node_Id
);
293 -- Output parameter specifications for node (which is either a function
294 -- or procedure specification with a Parameter_Specifications field)
296 procedure Write_Rewrite_Str
(S
: String);
297 -- Writes out a string (typically containing <<< or >>>}) for a node
298 -- created by rewriting the tree. Suppressed if we are outputting the
299 -- generated code only, since in this case we don't specially mark nodes
300 -- created by rewriting).
302 procedure Write_Source_Line
(L
: Physical_Line_Number
);
303 -- If writing of interspersed source lines is enabled, then write the given
304 -- line from the source file, preceded by Eol, then an extra blank line if
305 -- the line has at least one blank, is not a comment and is not line one,
306 -- then "--" and the line number followed by period followed by text of the
307 -- source line (without terminating Eol). If interspersed source line
308 -- output not enabled, then the call has no effect.
310 procedure Write_Source_Lines
(L
: Physical_Line_Number
);
311 -- If writing of interspersed source lines is enabled, then writes source
312 -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
313 -- interspersed source line output not enabled, then call has no effect.
315 procedure Write_Str_Sloc
(S
: String);
316 -- Like Write_Str, but sets debug Sloc of current debug node to first
317 -- non-blank character if a current debug node is active.
319 procedure Write_Str_With_Col_Check
(S
: String);
320 -- Write string (using Write_Str) with initial column check, and possible
321 -- initial Write_Indent (to get new line) if current line is too full.
323 procedure Write_Str_With_Col_Check_Sloc
(S
: String);
324 -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug
325 -- node to first non-blank character if a current debug node is active.
327 procedure Write_Subprogram_Name
(N
: Node_Id
);
328 -- N is the Name field of a function call or procedure statement call.
329 -- The effect of the call is to output the name, preceded by a $ if the
330 -- call is identified as an implicit call to a run time routine.
332 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
);
333 -- Write Uint (using UI_Write) with initial column check, and possible
334 -- initial Write_Indent (to get new line) if current line is too full.
335 -- The format parameter determines the output format (see UI_Write).
337 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
);
338 -- Write Uint (using UI_Write) with initial column check, and possible
339 -- initial Write_Indent (to get new line) if current line is too full.
340 -- The format parameter determines the output format (see UI_Write).
341 -- In addition, in Debug_Generated_Code mode, sets the current node
342 -- Sloc to the first character of the output value.
344 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
);
345 -- Write Ureal (using same output format as UR_Write) with column checks
346 -- and a possible initial Write_Indent (to get new line) if current line
347 -- is too full. In addition, in Debug_Generated_Code mode, sets the
348 -- current node Sloc to the first character of the output value.
354 procedure Col_Check
(N
: Nat
) is
356 if N
+ Column
> Sprint_Line_Limit
then
357 Write_Indent_Str
(" ");
361 ----------------------
362 -- Extra_Blank_Line --
363 ----------------------
365 procedure Extra_Blank_Line
is
367 if not Dump_Source_Text
then
370 end Extra_Blank_Line
;
376 procedure Indent_Annull
is
378 Indent_Annull_Flag
:= True;
385 procedure Indent_Begin
is
387 Indent
:= Indent
+ 3;
394 procedure Indent_End
is
396 Indent
:= Indent
- 3;
403 procedure pg
(Arg
: Union_Id
) is
405 Dump_Generated_Only
:= True;
406 Dump_Original_Only
:= False;
407 Current_Source_File
:= No_Source_File
;
409 if Arg
in List_Range
then
410 Sprint_Node_List
(List_Id
(Arg
));
412 elsif Arg
in Node_Range
then
413 Sprint_Node
(Node_Id
(Arg
));
426 procedure po
(Arg
: Union_Id
) is
428 Dump_Generated_Only
:= False;
429 Dump_Original_Only
:= True;
430 Current_Source_File
:= No_Source_File
;
432 if Arg
in List_Range
then
433 Sprint_Node_List
(List_Id
(Arg
));
435 elsif Arg
in Node_Range
then
436 Sprint_Node
(Node_Id
(Arg
));
445 ----------------------
446 -- Print_Debug_Line --
447 ----------------------
449 procedure Print_Debug_Line
(S
: String) is
451 Write_Debug_Line
(S
, Debug_Sloc
);
452 end Print_Debug_Line
;
454 ---------------------------
455 -- Process_TFAI_RR_Flags --
456 ---------------------------
458 procedure Process_TFAI_RR_Flags
(Nod
: Node_Id
) is
460 if Treat_Fixed_As_Integer
(Nod
) then
464 if Rounded_Result
(Nod
) then
467 end Process_TFAI_RR_Flags
;
473 procedure ps
(Arg
: Union_Id
) is
475 Dump_Generated_Only
:= False;
476 Dump_Original_Only
:= False;
477 Current_Source_File
:= No_Source_File
;
479 if Arg
in List_Range
then
480 Sprint_Node_List
(List_Id
(Arg
));
482 elsif Arg
in Node_Range
then
483 Sprint_Node
(Node_Id
(Arg
));
496 procedure Set_Debug_Sloc
is
498 if Debug_Generated_Code
and then Present
(Dump_Node
) then
499 Set_Sloc
(Dump_Node
, Debug_Sloc
+ Source_Ptr
(Column
- 1));
508 procedure Source_Dump
is
511 -- Put underline under string we just printed
517 procedure Underline
is
518 Col
: constant Int
:= Column
;
523 while Col
> Column
loop
530 -- Start of processing for Source_Dump
533 Dump_Generated_Only
:= Debug_Flag_G
or
534 Print_Generated_Code
or
535 Debug_Generated_Code
;
536 Dump_Original_Only
:= Debug_Flag_O
;
537 Dump_Freeze_Null
:= Debug_Flag_S
or Debug_Flag_G
;
539 -- Note that we turn off the tree dump flags immediately, before
540 -- starting the dump. This avoids generating two copies of the dump
541 -- if an abort occurs after printing the dump, and more importantly,
542 -- avoids an infinite loop if an abort occurs during the dump.
545 Current_Source_File
:= No_Source_File
;
546 Debug_Flag_Z
:= False;
549 Write_Str
("Source recreated from tree of Standard (spec)");
551 Sprint_Node
(Standard_Package_Node
);
556 if Debug_Flag_S
or Dump_Generated_Only
or Dump_Original_Only
then
557 Debug_Flag_G
:= False;
558 Debug_Flag_O
:= False;
559 Debug_Flag_S
:= False;
561 -- Dump requested units
563 for U
in Main_Unit
.. Last_Unit
loop
564 Current_Source_File
:= Source_Index
(U
);
566 -- Dump all units if -gnatdf set, otherwise we dump only
567 -- the source files that are in the extended main source.
570 or else In_Extended_Main_Source_Unit
(Cunit_Entity
(U
))
572 -- If we are generating debug files, setup to write them
574 if Debug_Generated_Code
then
575 Set_Special_Output
(Print_Debug_Line
'Access);
576 Create_Debug_Source
(Source_Index
(U
), Debug_Sloc
);
577 Write_Source_Line
(1);
578 Last_Line_Printed
:= 1;
579 Sprint_Node
(Cunit
(U
));
580 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
583 Set_Special_Output
(null);
585 -- Normal output to standard output file
588 Write_Str
("Source recreated from tree for ");
589 Write_Unit_Name
(Unit_Name
(U
));
591 Write_Source_Line
(1);
592 Last_Line_Printed
:= 1;
593 Sprint_Node
(Cunit
(U
));
594 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
603 ---------------------
604 -- Sprint_And_List --
605 ---------------------
607 procedure Sprint_And_List
(List
: List_Id
) is
610 if Is_Non_Empty_List
(List
) then
611 Node
:= First
(List
);
615 exit when Node
= Empty
;
621 ---------------------
622 -- Sprint_Bar_List --
623 ---------------------
625 procedure Sprint_Bar_List
(List
: List_Id
) is
628 if Is_Non_Empty_List
(List
) then
629 Node
:= First
(List
);
633 exit when Node
= Empty
;
639 ----------------------
640 -- Sprint_End_Label --
641 ----------------------
643 procedure Sprint_End_Label
649 and then Present
(End_Label
(Node
))
650 and then Is_Entity_Name
(End_Label
(Node
))
652 Set_Entity
(End_Label
(Node
), Default
);
654 -- For a function whose name is an operator, use the qualified name
655 -- created for the defining entity.
657 if Nkind
(End_Label
(Node
)) = N_Operator_Symbol
then
658 Set_Chars
(End_Label
(Node
), Chars
(Default
));
661 Sprint_Node
(End_Label
(Node
));
663 Sprint_Node
(Default
);
665 end Sprint_End_Label
;
667 -----------------------
668 -- Sprint_Comma_List --
669 -----------------------
671 procedure Sprint_Comma_List
(List
: List_Id
) is
675 if Is_Non_Empty_List
(List
) then
676 Node
:= First
(List
);
680 exit when Node
= Empty
;
682 if not Is_Rewrite_Insertion
(Node
)
683 or else not Dump_Original_Only
689 end Sprint_Comma_List
;
691 --------------------------
692 -- Sprint_Indented_List --
693 --------------------------
695 procedure Sprint_Indented_List
(List
: List_Id
) is
698 Sprint_Node_List
(List
);
700 end Sprint_Indented_List
;
702 ---------------------
703 -- Sprint_Left_Opnd --
704 ---------------------
706 procedure Sprint_Left_Opnd
(N
: Node_Id
) is
707 Opnd
: constant Node_Id
:= Left_Opnd
(N
);
710 if Paren_Count
(Opnd
) /= 0
711 or else Op_Prec
(Nkind
(Opnd
)) >= Op_Prec
(Nkind
(N
))
720 end Sprint_Left_Opnd
;
726 procedure Sprint_Node
(Node
: Node_Id
) is
728 if Is_Rewrite_Insertion
(Node
) then
729 if not Dump_Original_Only
then
731 -- For special cases of nodes that always output <<< >>>
732 -- do not duplicate the output at this point.
734 if Nkind
(Node
) = N_Freeze_Entity
735 or else Nkind
(Node
) = N_Implicit_Label_Declaration
737 Sprint_Node_Actual
(Node
);
739 -- Normal case where <<< >>> may be required
742 Write_Rewrite_Str
("<<<");
743 Sprint_Node_Actual
(Node
);
744 Write_Rewrite_Str
(">>>");
748 elsif Is_Rewrite_Substitution
(Node
) then
750 -- Case of dump generated only
752 if Dump_Generated_Only
then
753 Sprint_Node_Actual
(Node
);
755 -- Case of dump original only
757 elsif Dump_Original_Only
then
758 Sprint_Node_Actual
(Original_Node
(Node
));
760 -- Case of both being dumped
763 Sprint_Node_Actual
(Original_Node
(Node
));
764 Write_Rewrite_Str
("<<<");
765 Sprint_Node_Actual
(Node
);
766 Write_Rewrite_Str
(">>>");
770 Sprint_Node_Actual
(Node
);
774 ------------------------
775 -- Sprint_Node_Actual --
776 ------------------------
778 procedure Sprint_Node_Actual
(Node
: Node_Id
) is
779 Save_Dump_Node
: constant Node_Id
:= Dump_Node
;
786 for J
in 1 .. Paren_Count
(Node
) loop
787 Write_Str_With_Col_Check
("(");
790 -- Setup current dump node
794 if Nkind
(Node
) in N_Subexpr
795 and then Do_Range_Check
(Node
)
797 Write_Str_With_Col_Check
("{");
800 -- Select print circuit based on node kind
804 when N_Abort_Statement
=>
805 Write_Indent_Str_Sloc
("abort ");
806 Sprint_Comma_List
(Names
(Node
));
809 when N_Abortable_Part
=>
811 Write_Str_Sloc
("abort ");
812 Sprint_Indented_List
(Statements
(Node
));
814 when N_Abstract_Subprogram_Declaration
=>
816 Sprint_Node
(Specification
(Node
));
817 Write_Str_With_Col_Check
(" is ");
818 Write_Str_Sloc
("abstract;");
820 when N_Accept_Alternative
=>
821 Sprint_Node_List
(Pragmas_Before
(Node
));
823 if Present
(Condition
(Node
)) then
824 Write_Indent_Str
("when ");
825 Sprint_Node
(Condition
(Node
));
830 Sprint_Node_Sloc
(Accept_Statement
(Node
));
831 Sprint_Node_List
(Statements
(Node
));
833 when N_Accept_Statement
=>
834 Write_Indent_Str_Sloc
("accept ");
835 Write_Id
(Entry_Direct_Name
(Node
));
837 if Present
(Entry_Index
(Node
)) then
838 Write_Str_With_Col_Check
(" (");
839 Sprint_Node
(Entry_Index
(Node
));
843 Write_Param_Specs
(Node
);
845 if Present
(Handled_Statement_Sequence
(Node
)) then
846 Write_Str_With_Col_Check
(" do");
847 Sprint_Node
(Handled_Statement_Sequence
(Node
));
848 Write_Indent_Str
("end ");
849 Write_Id
(Entry_Direct_Name
(Node
));
854 when N_Access_Definition
=>
858 if Present
(Access_To_Subprogram_Definition
(Node
)) then
859 Sprint_Node
(Access_To_Subprogram_Definition
(Node
));
863 if Null_Exclusion_Present
(Node
) then
864 Write_Str
("not null ");
867 Write_Str_With_Col_Check_Sloc
("access ");
869 if All_Present
(Node
) then
871 elsif Constant_Present
(Node
) then
872 Write_Str
("constant ");
875 Sprint_Node
(Subtype_Mark
(Node
));
878 when N_Access_Function_Definition
=>
882 if Null_Exclusion_Present
(Node
) then
883 Write_Str
("not null ");
886 Write_Str_With_Col_Check_Sloc
("access ");
888 if Protected_Present
(Node
) then
889 Write_Str_With_Col_Check
("protected ");
892 Write_Str_With_Col_Check
("function");
893 Write_Param_Specs
(Node
);
894 Write_Str_With_Col_Check
(" return ");
895 Sprint_Node
(Result_Definition
(Node
));
897 when N_Access_Procedure_Definition
=>
901 if Null_Exclusion_Present
(Node
) then
902 Write_Str
("not null ");
905 Write_Str_With_Col_Check_Sloc
("access ");
907 if Protected_Present
(Node
) then
908 Write_Str_With_Col_Check
("protected ");
911 Write_Str_With_Col_Check
("procedure");
912 Write_Param_Specs
(Node
);
914 when N_Access_To_Object_Definition
=>
915 Write_Str_With_Col_Check_Sloc
("access ");
917 if All_Present
(Node
) then
918 Write_Str_With_Col_Check
("all ");
919 elsif Constant_Present
(Node
) then
920 Write_Str_With_Col_Check
("constant ");
925 if Null_Exclusion_Present
(Node
) then
926 Write_Str
("not null ");
929 Sprint_Node
(Subtype_Indication
(Node
));
932 if Null_Record_Present
(Node
) then
933 Write_Str_With_Col_Check_Sloc
("(null record)");
936 Write_Str_With_Col_Check_Sloc
("(");
938 if Present
(Expressions
(Node
)) then
939 Sprint_Comma_List
(Expressions
(Node
));
941 if Present
(Component_Associations
(Node
))
942 and then not Is_Empty_List
(Component_Associations
(Node
))
948 if Present
(Component_Associations
(Node
))
949 and then not Is_Empty_List
(Component_Associations
(Node
))
957 Nd
:= First
(Component_Associations
(Node
));
965 if not Is_Rewrite_Insertion
(Nd
)
966 or else not Dump_Original_Only
980 Write_Str_With_Col_Check_Sloc
("new ");
984 if Null_Exclusion_Present
(Node
) then
985 Write_Str
("not null ");
988 Sprint_Node
(Expression
(Node
));
990 if Present
(Storage_Pool
(Node
)) then
991 Write_Str_With_Col_Check
("[storage_pool = ");
992 Sprint_Node
(Storage_Pool
(Node
));
997 Sprint_Left_Opnd
(Node
);
998 Write_Str_Sloc
(" and then ");
999 Sprint_Right_Opnd
(Node
);
1002 Write_Indent_Str_Sloc
("for ");
1003 Write_Id
(Identifier
(Node
));
1004 Write_Str_With_Col_Check
(" use at ");
1005 Sprint_Node
(Expression
(Node
));
1008 when N_Assignment_Statement
=>
1010 Sprint_Node
(Name
(Node
));
1011 Write_Str_Sloc
(" := ");
1012 Sprint_Node
(Expression
(Node
));
1015 when N_Asynchronous_Select
=>
1016 Write_Indent_Str_Sloc
("select");
1018 Sprint_Node
(Triggering_Alternative
(Node
));
1021 -- Note: let the printing of Abortable_Part handle outputting
1022 -- the ABORT keyword, so that the Sloc can be set correctly.
1024 Write_Indent_Str
("then ");
1025 Sprint_Node
(Abortable_Part
(Node
));
1026 Write_Indent_Str
("end select;");
1028 when N_Attribute_Definition_Clause
=>
1029 Write_Indent_Str_Sloc
("for ");
1030 Sprint_Node
(Name
(Node
));
1032 Write_Name_With_Col_Check
(Chars
(Node
));
1033 Write_Str_With_Col_Check
(" use ");
1034 Sprint_Node
(Expression
(Node
));
1037 when N_Attribute_Reference
=>
1038 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
1042 Sprint_Node
(Prefix
(Node
));
1043 Write_Char_Sloc
(''');
1044 Write_Name_With_Col_Check
(Attribute_Name
(Node
));
1045 Sprint_Paren_Comma_List
(Expressions
(Node
));
1047 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
1051 when N_Block_Statement
=>
1054 if Present
(Identifier
(Node
))
1055 and then (not Has_Created_Identifier
(Node
)
1056 or else not Dump_Original_Only
)
1058 Write_Rewrite_Str
("<<<");
1059 Write_Id
(Identifier
(Node
));
1061 Write_Rewrite_Str
(">>>");
1064 if Present
(Declarations
(Node
)) then
1065 Write_Str_With_Col_Check_Sloc
("declare");
1066 Sprint_Indented_List
(Declarations
(Node
));
1070 Write_Str_With_Col_Check_Sloc
("begin");
1071 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1072 Write_Indent_Str
("end");
1074 if Present
(Identifier
(Node
))
1075 and then (not Has_Created_Identifier
(Node
)
1076 or else not Dump_Original_Only
)
1078 Write_Rewrite_Str
("<<<");
1080 Write_Id
(Identifier
(Node
));
1081 Write_Rewrite_Str
(">>>");
1086 when N_Case_Statement
=>
1087 Write_Indent_Str_Sloc
("case ");
1088 Sprint_Node
(Expression
(Node
));
1090 Sprint_Indented_List
(Alternatives
(Node
));
1091 Write_Indent_Str
("end case;");
1093 when N_Case_Statement_Alternative
=>
1094 Write_Indent_Str_Sloc
("when ");
1095 Sprint_Bar_List
(Discrete_Choices
(Node
));
1097 Sprint_Indented_List
(Statements
(Node
));
1099 when N_Character_Literal
=>
1100 if Column
> Sprint_Line_Limit
- 2 then
1101 Write_Indent_Str
(" ");
1104 Write_Char_Sloc
(''');
1105 Write_Char_Code
(UI_To_CC
(Char_Literal_Value
(Node
)));
1108 when N_Code_Statement
=>
1111 Sprint_Node
(Expression
(Node
));
1114 when N_Compilation_Unit
=>
1115 Sprint_Node_List
(Context_Items
(Node
));
1116 Sprint_Opt_Node_List
(Declarations
(Aux_Decls_Node
(Node
)));
1118 if Private_Present
(Node
) then
1119 Write_Indent_Str
("private ");
1123 Sprint_Node_Sloc
(Unit
(Node
));
1125 if Present
(Actions
(Aux_Decls_Node
(Node
)))
1127 Present
(Pragmas_After
(Aux_Decls_Node
(Node
)))
1132 Sprint_Opt_Node_List
(Actions
(Aux_Decls_Node
(Node
)));
1133 Sprint_Opt_Node_List
(Pragmas_After
(Aux_Decls_Node
(Node
)));
1135 when N_Compilation_Unit_Aux
=>
1136 null; -- nothing to do, never used, see above
1138 when N_Component_Association
=>
1140 Sprint_Bar_List
(Choices
(Node
));
1143 -- Ada 2005 (AI-287): Print the box if present
1145 if Box_Present
(Node
) then
1146 Write_Str_With_Col_Check
("<>");
1148 Sprint_Node
(Expression
(Node
));
1151 when N_Component_Clause
=>
1153 Sprint_Node
(Component_Name
(Node
));
1154 Write_Str_Sloc
(" at ");
1155 Sprint_Node
(Position
(Node
));
1157 Write_Str_With_Col_Check
("range ");
1158 Sprint_Node
(First_Bit
(Node
));
1160 Sprint_Node
(Last_Bit
(Node
));
1163 when N_Component_Definition
=>
1166 -- Ada 2005 (AI-230): Access definition components
1168 if Present
(Access_Definition
(Node
)) then
1169 Sprint_Node
(Access_Definition
(Node
));
1171 elsif Present
(Subtype_Indication
(Node
)) then
1172 if Aliased_Present
(Node
) then
1173 Write_Str_With_Col_Check
("aliased ");
1176 -- Ada 2005 (AI-231)
1178 if Null_Exclusion_Present
(Node
) then
1179 Write_Str
(" not null ");
1182 Sprint_Node
(Subtype_Indication
(Node
));
1185 Write_Str
(" ??? ");
1188 when N_Component_Declaration
=>
1189 if Write_Indent_Identifiers_Sloc
(Node
) then
1191 Sprint_Node
(Component_Definition
(Node
));
1193 if Present
(Expression
(Node
)) then
1195 Sprint_Node
(Expression
(Node
));
1201 when N_Component_List
=>
1202 if Null_Present
(Node
) then
1204 Write_Indent_Str_Sloc
("null");
1210 Sprint_Indented_List
(Component_Items
(Node
));
1211 Sprint_Node
(Variant_Part
(Node
));
1214 when N_Conditional_Entry_Call
=>
1215 Write_Indent_Str_Sloc
("select");
1217 Sprint_Node
(Entry_Call_Alternative
(Node
));
1219 Write_Indent_Str
("else");
1220 Sprint_Indented_List
(Else_Statements
(Node
));
1221 Write_Indent_Str
("end select;");
1223 when N_Conditional_Expression
=>
1225 Condition
: constant Node_Id
:= First
(Expressions
(Node
));
1226 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1227 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1229 Write_Str_With_Col_Check_Sloc
("(if ");
1230 Sprint_Node
(Condition
);
1231 Write_Str_With_Col_Check
(" then ");
1232 Sprint_Node
(Then_Expr
);
1233 Write_Str_With_Col_Check
(" else ");
1234 Sprint_Node
(Else_Expr
);
1238 when N_Constrained_Array_Definition
=>
1239 Write_Str_With_Col_Check_Sloc
("array ");
1240 Sprint_Paren_Comma_List
(Discrete_Subtype_Definitions
(Node
));
1243 Sprint_Node
(Component_Definition
(Node
));
1245 when N_Decimal_Fixed_Point_Definition
=>
1246 Write_Str_With_Col_Check_Sloc
(" delta ");
1247 Sprint_Node
(Delta_Expression
(Node
));
1248 Write_Str_With_Col_Check
("digits ");
1249 Sprint_Node
(Digits_Expression
(Node
));
1250 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1252 when N_Defining_Character_Literal
=>
1253 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1255 when N_Defining_Identifier
=>
1259 when N_Defining_Operator_Symbol
=>
1260 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1262 when N_Defining_Program_Unit_Name
=>
1264 Sprint_Node
(Name
(Node
));
1266 Write_Id
(Defining_Identifier
(Node
));
1268 when N_Delay_Alternative
=>
1269 Sprint_Node_List
(Pragmas_Before
(Node
));
1271 if Present
(Condition
(Node
)) then
1273 Write_Str_With_Col_Check
("when ");
1274 Sprint_Node
(Condition
(Node
));
1279 Sprint_Node_Sloc
(Delay_Statement
(Node
));
1280 Sprint_Node_List
(Statements
(Node
));
1282 when N_Delay_Relative_Statement
=>
1283 Write_Indent_Str_Sloc
("delay ");
1284 Sprint_Node
(Expression
(Node
));
1287 when N_Delay_Until_Statement
=>
1288 Write_Indent_Str_Sloc
("delay until ");
1289 Sprint_Node
(Expression
(Node
));
1292 when N_Delta_Constraint
=>
1293 Write_Str_With_Col_Check_Sloc
("delta ");
1294 Sprint_Node
(Delta_Expression
(Node
));
1295 Sprint_Opt_Node
(Range_Constraint
(Node
));
1297 when N_Derived_Type_Definition
=>
1298 if Abstract_Present
(Node
) then
1299 Write_Str_With_Col_Check
("abstract ");
1302 Write_Str_With_Col_Check_Sloc
("new ");
1304 -- Ada 2005 (AI-231)
1306 if Null_Exclusion_Present
(Node
) then
1307 Write_Str_With_Col_Check
("not null ");
1310 Sprint_Node
(Subtype_Indication
(Node
));
1312 if Present
(Interface_List
(Node
)) then
1313 Write_Str_With_Col_Check
(" and ");
1314 Sprint_And_List
(Interface_List
(Node
));
1315 Write_Str_With_Col_Check
(" with ");
1318 if Present
(Record_Extension_Part
(Node
)) then
1319 if No
(Interface_List
(Node
)) then
1320 Write_Str_With_Col_Check
(" with ");
1323 Sprint_Node
(Record_Extension_Part
(Node
));
1326 when N_Designator
=>
1327 Sprint_Node
(Name
(Node
));
1328 Write_Char_Sloc
('.');
1329 Write_Id
(Identifier
(Node
));
1331 when N_Digits_Constraint
=>
1332 Write_Str_With_Col_Check_Sloc
("digits ");
1333 Sprint_Node
(Digits_Expression
(Node
));
1334 Sprint_Opt_Node
(Range_Constraint
(Node
));
1336 when N_Discriminant_Association
=>
1339 if Present
(Selector_Names
(Node
)) then
1340 Sprint_Bar_List
(Selector_Names
(Node
));
1345 Sprint_Node
(Expression
(Node
));
1347 when N_Discriminant_Specification
=>
1350 if Write_Identifiers
(Node
) then
1353 if Null_Exclusion_Present
(Node
) then
1354 Write_Str
("not null ");
1357 Sprint_Node
(Discriminant_Type
(Node
));
1359 if Present
(Expression
(Node
)) then
1361 Sprint_Node
(Expression
(Node
));
1367 when N_Elsif_Part
=>
1368 Write_Indent_Str_Sloc
("elsif ");
1369 Sprint_Node
(Condition
(Node
));
1370 Write_Str_With_Col_Check
(" then");
1371 Sprint_Indented_List
(Then_Statements
(Node
));
1376 when N_Entry_Body
=>
1377 Write_Indent_Str_Sloc
("entry ");
1378 Write_Id
(Defining_Identifier
(Node
));
1379 Sprint_Node
(Entry_Body_Formal_Part
(Node
));
1380 Write_Str_With_Col_Check
(" is");
1381 Sprint_Indented_List
(Declarations
(Node
));
1382 Write_Indent_Str
("begin");
1383 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1384 Write_Indent_Str
("end ");
1385 Write_Id
(Defining_Identifier
(Node
));
1388 when N_Entry_Body_Formal_Part
=>
1389 if Present
(Entry_Index_Specification
(Node
)) then
1390 Write_Str_With_Col_Check_Sloc
(" (");
1391 Sprint_Node
(Entry_Index_Specification
(Node
));
1395 Write_Param_Specs
(Node
);
1396 Write_Str_With_Col_Check_Sloc
(" when ");
1397 Sprint_Node
(Condition
(Node
));
1399 when N_Entry_Call_Alternative
=>
1400 Sprint_Node_List
(Pragmas_Before
(Node
));
1401 Sprint_Node_Sloc
(Entry_Call_Statement
(Node
));
1402 Sprint_Node_List
(Statements
(Node
));
1404 when N_Entry_Call_Statement
=>
1406 Sprint_Node_Sloc
(Name
(Node
));
1407 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
1410 when N_Entry_Declaration
=>
1411 Write_Indent_Str_Sloc
("entry ");
1412 Write_Id
(Defining_Identifier
(Node
));
1414 if Present
(Discrete_Subtype_Definition
(Node
)) then
1415 Write_Str_With_Col_Check
(" (");
1416 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1420 Write_Param_Specs
(Node
);
1423 when N_Entry_Index_Specification
=>
1424 Write_Str_With_Col_Check_Sloc
("for ");
1425 Write_Id
(Defining_Identifier
(Node
));
1426 Write_Str_With_Col_Check
(" in ");
1427 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1429 when N_Enumeration_Representation_Clause
=>
1430 Write_Indent_Str_Sloc
("for ");
1431 Write_Id
(Identifier
(Node
));
1432 Write_Str_With_Col_Check
(" use ");
1433 Sprint_Node
(Array_Aggregate
(Node
));
1436 when N_Enumeration_Type_Definition
=>
1439 -- Skip attempt to print Literals field if it's not there and
1440 -- we are in package Standard (case of Character, which is
1441 -- handled specially (without an explicit literals list).
1443 if Sloc
(Node
) > Standard_Location
1444 or else Present
(Literals
(Node
))
1446 Sprint_Paren_Comma_List
(Literals
(Node
));
1450 Write_Str_With_Col_Check_Sloc
("<error>");
1452 when N_Exception_Declaration
=>
1453 if Write_Indent_Identifiers
(Node
) then
1454 Write_Str_With_Col_Check
(" : ");
1456 if Is_Statically_Allocated
(Defining_Identifier
(Node
)) then
1457 Write_Str_With_Col_Check
("static ");
1460 Write_Str_Sloc
("exception");
1462 if Present
(Expression
(Node
)) then
1464 Sprint_Node
(Expression
(Node
));
1470 when N_Exception_Handler
=>
1471 Write_Indent_Str_Sloc
("when ");
1473 if Present
(Choice_Parameter
(Node
)) then
1474 Sprint_Node
(Choice_Parameter
(Node
));
1478 Sprint_Bar_List
(Exception_Choices
(Node
));
1480 Sprint_Indented_List
(Statements
(Node
));
1482 when N_Exception_Renaming_Declaration
=>
1485 Sprint_Node
(Defining_Identifier
(Node
));
1486 Write_Str_With_Col_Check
(" : exception renames ");
1487 Sprint_Node
(Name
(Node
));
1490 when N_Exit_Statement
=>
1491 Write_Indent_Str_Sloc
("exit");
1492 Sprint_Opt_Node
(Name
(Node
));
1494 if Present
(Condition
(Node
)) then
1495 Write_Str_With_Col_Check
(" when ");
1496 Sprint_Node
(Condition
(Node
));
1501 when N_Expanded_Name
=>
1502 Sprint_Node
(Prefix
(Node
));
1503 Write_Char_Sloc
('.');
1504 Sprint_Node
(Selector_Name
(Node
));
1506 when N_Explicit_Dereference
=>
1507 Sprint_Node
(Prefix
(Node
));
1508 Write_Char_Sloc
('.');
1509 Write_Str_Sloc
("all");
1511 when N_Extended_Return_Statement
=>
1512 Write_Indent_Str_Sloc
("return ");
1513 Sprint_Node_List
(Return_Object_Declarations
(Node
));
1515 if Present
(Handled_Statement_Sequence
(Node
)) then
1516 Write_Str_With_Col_Check
(" do");
1517 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1518 Write_Indent_Str
("end return;");
1520 Write_Indent_Str
(";");
1523 when N_Extension_Aggregate
=>
1524 Write_Str_With_Col_Check_Sloc
("(");
1525 Sprint_Node
(Ancestor_Part
(Node
));
1526 Write_Str_With_Col_Check
(" with ");
1528 if Null_Record_Present
(Node
) then
1529 Write_Str_With_Col_Check
("null record");
1531 if Present
(Expressions
(Node
)) then
1532 Sprint_Comma_List
(Expressions
(Node
));
1534 if Present
(Component_Associations
(Node
)) then
1539 if Present
(Component_Associations
(Node
)) then
1540 Sprint_Comma_List
(Component_Associations
(Node
));
1546 when N_Floating_Point_Definition
=>
1547 Write_Str_With_Col_Check_Sloc
("digits ");
1548 Sprint_Node
(Digits_Expression
(Node
));
1549 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1551 when N_Formal_Decimal_Fixed_Point_Definition
=>
1552 Write_Str_With_Col_Check_Sloc
("delta <> digits <>");
1554 when N_Formal_Derived_Type_Definition
=>
1555 Write_Str_With_Col_Check_Sloc
("new ");
1556 Sprint_Node
(Subtype_Mark
(Node
));
1558 if Present
(Interface_List
(Node
)) then
1559 Write_Str_With_Col_Check
(" and ");
1560 Sprint_And_List
(Interface_List
(Node
));
1563 if Private_Present
(Node
) then
1564 Write_Str_With_Col_Check
(" with private");
1567 when N_Formal_Abstract_Subprogram_Declaration
=>
1568 Write_Indent_Str_Sloc
("with ");
1569 Sprint_Node
(Specification
(Node
));
1571 Write_Str_With_Col_Check
(" is abstract");
1573 if Box_Present
(Node
) then
1574 Write_Str_With_Col_Check
(" <>");
1575 elsif Present
(Default_Name
(Node
)) then
1576 Write_Str_With_Col_Check
(" ");
1577 Sprint_Node
(Default_Name
(Node
));
1582 when N_Formal_Concrete_Subprogram_Declaration
=>
1583 Write_Indent_Str_Sloc
("with ");
1584 Sprint_Node
(Specification
(Node
));
1586 if Box_Present
(Node
) then
1587 Write_Str_With_Col_Check
(" is <>");
1588 elsif Present
(Default_Name
(Node
)) then
1589 Write_Str_With_Col_Check
(" is ");
1590 Sprint_Node
(Default_Name
(Node
));
1595 when N_Formal_Discrete_Type_Definition
=>
1596 Write_Str_With_Col_Check_Sloc
("<>");
1598 when N_Formal_Floating_Point_Definition
=>
1599 Write_Str_With_Col_Check_Sloc
("digits <>");
1601 when N_Formal_Modular_Type_Definition
=>
1602 Write_Str_With_Col_Check_Sloc
("mod <>");
1604 when N_Formal_Object_Declaration
=>
1607 if Write_Indent_Identifiers
(Node
) then
1610 if In_Present
(Node
) then
1611 Write_Str_With_Col_Check
("in ");
1614 if Out_Present
(Node
) then
1615 Write_Str_With_Col_Check
("out ");
1618 if Present
(Subtype_Mark
(Node
)) then
1620 -- Ada 2005 (AI-423): Formal object with null exclusion
1622 if Null_Exclusion_Present
(Node
) then
1623 Write_Str
("not null ");
1626 Sprint_Node
(Subtype_Mark
(Node
));
1628 -- Ada 2005 (AI-423): Formal object with access definition
1631 pragma Assert
(Present
(Access_Definition
(Node
)));
1633 Sprint_Node
(Access_Definition
(Node
));
1636 if Present
(Default_Expression
(Node
)) then
1638 Sprint_Node
(Default_Expression
(Node
));
1644 when N_Formal_Ordinary_Fixed_Point_Definition
=>
1645 Write_Str_With_Col_Check_Sloc
("delta <>");
1647 when N_Formal_Package_Declaration
=>
1648 Write_Indent_Str_Sloc
("with package ");
1649 Write_Id
(Defining_Identifier
(Node
));
1650 Write_Str_With_Col_Check
(" is new ");
1651 Sprint_Node
(Name
(Node
));
1652 Write_Str_With_Col_Check
(" (<>);");
1654 when N_Formal_Private_Type_Definition
=>
1655 if Abstract_Present
(Node
) then
1656 Write_Str_With_Col_Check
("abstract ");
1659 if Tagged_Present
(Node
) then
1660 Write_Str_With_Col_Check
("tagged ");
1663 if Limited_Present
(Node
) then
1664 Write_Str_With_Col_Check
("limited ");
1667 Write_Str_With_Col_Check_Sloc
("private");
1669 when N_Formal_Signed_Integer_Type_Definition
=>
1670 Write_Str_With_Col_Check_Sloc
("range <>");
1672 when N_Formal_Type_Declaration
=>
1673 Write_Indent_Str_Sloc
("type ");
1674 Write_Id
(Defining_Identifier
(Node
));
1676 if Present
(Discriminant_Specifications
(Node
)) then
1677 Write_Discr_Specs
(Node
);
1678 elsif Unknown_Discriminants_Present
(Node
) then
1679 Write_Str_With_Col_Check
("(<>)");
1682 Write_Str_With_Col_Check
(" is ");
1683 Sprint_Node
(Formal_Type_Definition
(Node
));
1686 when N_Free_Statement
=>
1687 Write_Indent_Str_Sloc
("free ");
1688 Sprint_Node
(Expression
(Node
));
1691 when N_Freeze_Entity
=>
1692 if Dump_Original_Only
then
1695 elsif Present
(Actions
(Node
)) or else Dump_Freeze_Null
then
1697 Write_Rewrite_Str
("<<<");
1698 Write_Str_With_Col_Check_Sloc
("freeze ");
1699 Write_Id
(Entity
(Node
));
1702 if No
(Actions
(Node
)) then
1706 -- Output freeze actions. We increment Freeze_Indent during
1707 -- this output to avoid generating extra blank lines before
1708 -- any procedures included in the freeze actions.
1710 Freeze_Indent
:= Freeze_Indent
+ 1;
1711 Sprint_Indented_List
(Actions
(Node
));
1712 Freeze_Indent
:= Freeze_Indent
- 1;
1713 Write_Indent_Str
("]");
1716 Write_Rewrite_Str
(">>>");
1719 when N_Full_Type_Declaration
=>
1720 Write_Indent_Str_Sloc
("type ");
1721 Sprint_Node
(Defining_Identifier
(Node
));
1722 Write_Discr_Specs
(Node
);
1723 Write_Str_With_Col_Check
(" is ");
1724 Sprint_Node
(Type_Definition
(Node
));
1727 when N_Function_Call
=>
1729 Write_Subprogram_Name
(Name
(Node
));
1730 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
1732 when N_Function_Instantiation
=>
1733 Write_Indent_Str_Sloc
("function ");
1734 Sprint_Node
(Defining_Unit_Name
(Node
));
1735 Write_Str_With_Col_Check
(" is new ");
1736 Sprint_Node
(Name
(Node
));
1737 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
1740 when N_Function_Specification
=>
1741 Write_Str_With_Col_Check_Sloc
("function ");
1742 Sprint_Node
(Defining_Unit_Name
(Node
));
1743 Write_Param_Specs
(Node
);
1744 Write_Str_With_Col_Check
(" return ");
1746 -- Ada 2005 (AI-231)
1748 if Nkind
(Result_Definition
(Node
)) /= N_Access_Definition
1749 and then Null_Exclusion_Present
(Node
)
1751 Write_Str
(" not null ");
1754 Sprint_Node
(Result_Definition
(Node
));
1756 when N_Generic_Association
=>
1759 if Present
(Selector_Name
(Node
)) then
1760 Sprint_Node
(Selector_Name
(Node
));
1764 Sprint_Node
(Explicit_Generic_Actual_Parameter
(Node
));
1766 when N_Generic_Function_Renaming_Declaration
=>
1767 Write_Indent_Str_Sloc
("generic function ");
1768 Sprint_Node
(Defining_Unit_Name
(Node
));
1769 Write_Str_With_Col_Check
(" renames ");
1770 Sprint_Node
(Name
(Node
));
1773 when N_Generic_Package_Declaration
=>
1775 Write_Indent_Str_Sloc
("generic ");
1776 Sprint_Indented_List
(Generic_Formal_Declarations
(Node
));
1778 Sprint_Node
(Specification
(Node
));
1781 when N_Generic_Package_Renaming_Declaration
=>
1782 Write_Indent_Str_Sloc
("generic package ");
1783 Sprint_Node
(Defining_Unit_Name
(Node
));
1784 Write_Str_With_Col_Check
(" renames ");
1785 Sprint_Node
(Name
(Node
));
1788 when N_Generic_Procedure_Renaming_Declaration
=>
1789 Write_Indent_Str_Sloc
("generic procedure ");
1790 Sprint_Node
(Defining_Unit_Name
(Node
));
1791 Write_Str_With_Col_Check
(" renames ");
1792 Sprint_Node
(Name
(Node
));
1795 when N_Generic_Subprogram_Declaration
=>
1797 Write_Indent_Str_Sloc
("generic ");
1798 Sprint_Indented_List
(Generic_Formal_Declarations
(Node
));
1800 Sprint_Node
(Specification
(Node
));
1803 when N_Goto_Statement
=>
1804 Write_Indent_Str_Sloc
("goto ");
1805 Sprint_Node
(Name
(Node
));
1808 if Nkind
(Next
(Node
)) = N_Label
then
1812 when N_Handled_Sequence_Of_Statements
=>
1814 Sprint_Indented_List
(Statements
(Node
));
1816 if Present
(Exception_Handlers
(Node
)) then
1817 Write_Indent_Str
("exception");
1819 Sprint_Node_List
(Exception_Handlers
(Node
));
1823 if Present
(At_End_Proc
(Node
)) then
1824 Write_Indent_Str
("at end");
1827 Sprint_Node
(At_End_Proc
(Node
));
1832 when N_Identifier
=>
1836 when N_If_Statement
=>
1837 Write_Indent_Str_Sloc
("if ");
1838 Sprint_Node
(Condition
(Node
));
1839 Write_Str_With_Col_Check
(" then");
1840 Sprint_Indented_List
(Then_Statements
(Node
));
1841 Sprint_Opt_Node_List
(Elsif_Parts
(Node
));
1843 if Present
(Else_Statements
(Node
)) then
1844 Write_Indent_Str
("else");
1845 Sprint_Indented_List
(Else_Statements
(Node
));
1848 Write_Indent_Str
("end if;");
1850 when N_Implicit_Label_Declaration
=>
1851 if not Dump_Original_Only
then
1853 Write_Rewrite_Str
("<<<");
1855 Write_Id
(Defining_Identifier
(Node
));
1857 Write_Str_With_Col_Check
("label");
1858 Write_Rewrite_Str
(">>>");
1862 Sprint_Left_Opnd
(Node
);
1863 Write_Str_Sloc
(" in ");
1865 if Present
(Right_Opnd
(Node
)) then
1866 Sprint_Right_Opnd
(Node
);
1868 Sprint_Bar_List
(Alternatives
(Node
));
1871 when N_Incomplete_Type_Declaration
=>
1872 Write_Indent_Str_Sloc
("type ");
1873 Write_Id
(Defining_Identifier
(Node
));
1875 if Present
(Discriminant_Specifications
(Node
)) then
1876 Write_Discr_Specs
(Node
);
1877 elsif Unknown_Discriminants_Present
(Node
) then
1878 Write_Str_With_Col_Check
("(<>)");
1883 when N_Index_Or_Discriminant_Constraint
=>
1885 Sprint_Paren_Comma_List
(Constraints
(Node
));
1887 when N_Indexed_Component
=>
1888 Sprint_Node_Sloc
(Prefix
(Node
));
1889 Sprint_Opt_Paren_Comma_List
(Expressions
(Node
));
1891 when N_Integer_Literal
=>
1892 if Print_In_Hex
(Node
) then
1893 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Hex
);
1895 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Auto
);
1898 when N_Iteration_Scheme
=>
1899 if Present
(Condition
(Node
)) then
1900 Write_Str_With_Col_Check_Sloc
("while ");
1901 Sprint_Node
(Condition
(Node
));
1903 Write_Str_With_Col_Check_Sloc
("for ");
1904 Sprint_Node
(Loop_Parameter_Specification
(Node
));
1909 when N_Itype_Reference
=>
1910 Write_Indent_Str_Sloc
("reference ");
1911 Write_Id
(Itype
(Node
));
1914 Write_Indent_Str_Sloc
("<<");
1915 Write_Id
(Identifier
(Node
));
1918 when N_Loop_Parameter_Specification
=>
1920 Write_Id
(Defining_Identifier
(Node
));
1921 Write_Str_With_Col_Check
(" in ");
1923 if Reverse_Present
(Node
) then
1924 Write_Str_With_Col_Check
("reverse ");
1927 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1929 when N_Loop_Statement
=>
1932 if Present
(Identifier
(Node
))
1933 and then (not Has_Created_Identifier
(Node
)
1934 or else not Dump_Original_Only
)
1936 Write_Rewrite_Str
("<<<");
1937 Write_Id
(Identifier
(Node
));
1939 Write_Rewrite_Str
(">>>");
1940 Sprint_Node
(Iteration_Scheme
(Node
));
1941 Write_Str_With_Col_Check_Sloc
("loop");
1942 Sprint_Indented_List
(Statements
(Node
));
1943 Write_Indent_Str
("end loop ");
1944 Write_Rewrite_Str
("<<<");
1945 Write_Id
(Identifier
(Node
));
1946 Write_Rewrite_Str
(">>>");
1950 Sprint_Node
(Iteration_Scheme
(Node
));
1951 Write_Str_With_Col_Check_Sloc
("loop");
1952 Sprint_Indented_List
(Statements
(Node
));
1953 Write_Indent_Str
("end loop;");
1956 when N_Mod_Clause
=>
1957 Sprint_Node_List
(Pragmas_Before
(Node
));
1958 Write_Str_With_Col_Check_Sloc
("at mod ");
1959 Sprint_Node
(Expression
(Node
));
1961 when N_Modular_Type_Definition
=>
1962 Write_Str_With_Col_Check_Sloc
("mod ");
1963 Sprint_Node
(Expression
(Node
));
1966 Sprint_Left_Opnd
(Node
);
1967 Write_Str_Sloc
(" not in ");
1969 if Present
(Right_Opnd
(Node
)) then
1970 Sprint_Right_Opnd
(Node
);
1972 Sprint_Bar_List
(Alternatives
(Node
));
1976 Write_Str_With_Col_Check_Sloc
("null");
1978 when N_Null_Statement
=>
1979 if Comes_From_Source
(Node
)
1980 or else Dump_Freeze_Null
1981 or else not Is_List_Member
(Node
)
1982 or else (No
(Prev
(Node
)) and then No
(Next
(Node
)))
1984 Write_Indent_Str_Sloc
("null;");
1987 when N_Number_Declaration
=>
1990 if Write_Indent_Identifiers
(Node
) then
1991 Write_Str_With_Col_Check
(" : constant ");
1993 Sprint_Node
(Expression
(Node
));
1997 when N_Object_Declaration
=>
2000 if Write_Indent_Identifiers
(Node
) then
2002 Def_Id
: constant Entity_Id
:= Defining_Identifier
(Node
);
2005 Write_Str_With_Col_Check
(" : ");
2007 if Is_Statically_Allocated
(Def_Id
) then
2008 Write_Str_With_Col_Check
("static ");
2011 if Aliased_Present
(Node
) then
2012 Write_Str_With_Col_Check
("aliased ");
2015 if Constant_Present
(Node
) then
2016 Write_Str_With_Col_Check
("constant ");
2019 -- Ada 2005 (AI-231)
2021 if Null_Exclusion_Present
(Node
) then
2022 Write_Str_With_Col_Check
("not null ");
2025 Sprint_Node
(Object_Definition
(Node
));
2027 if Present
(Expression
(Node
)) then
2029 Sprint_Node
(Expression
(Node
));
2034 -- Handle implicit importation and implicit exportation of
2035 -- object declarations:
2036 -- $pragma import (Convention_Id, Def_Id, "...");
2037 -- $pragma export (Convention_Id, Def_Id, "...");
2039 if Is_Internal
(Def_Id
)
2040 and then Present
(Interface_Name
(Def_Id
))
2042 Write_Indent_Str_Sloc
("$pragma ");
2044 if Is_Imported
(Def_Id
) then
2045 Write_Str
("import (");
2047 else pragma Assert
(Is_Exported
(Def_Id
));
2048 Write_Str
("export (");
2052 Prefix
: constant String := "Convention_";
2053 S
: constant String := Convention
(Def_Id
)'Img;
2056 Name_Len
:= S
'Last - Prefix
'Last;
2057 Name_Buffer
(1 .. Name_Len
) :=
2058 S
(Prefix
'Last + 1 .. S
'Last);
2059 Set_Casing
(All_Lower_Case
);
2060 Write_Str
(Name_Buffer
(1 .. Name_Len
));
2066 Write_String_Table_Entry
2067 (Strval
(Interface_Name
(Def_Id
)));
2073 when N_Object_Renaming_Declaration
=>
2076 Sprint_Node
(Defining_Identifier
(Node
));
2079 -- Ada 2005 (AI-230): Access renamings
2081 if Present
(Access_Definition
(Node
)) then
2082 Sprint_Node
(Access_Definition
(Node
));
2084 elsif Present
(Subtype_Mark
(Node
)) then
2086 -- Ada 2005 (AI-423): Object renaming with a null exclusion
2088 if Null_Exclusion_Present
(Node
) then
2089 Write_Str
("not null ");
2092 Sprint_Node
(Subtype_Mark
(Node
));
2095 Write_Str
(" ??? ");
2098 Write_Str_With_Col_Check
(" renames ");
2099 Sprint_Node
(Name
(Node
));
2103 Write_Operator
(Node
, "abs ");
2104 Sprint_Right_Opnd
(Node
);
2107 Sprint_Left_Opnd
(Node
);
2108 Write_Operator
(Node
, " + ");
2109 Sprint_Right_Opnd
(Node
);
2112 Sprint_Left_Opnd
(Node
);
2113 Write_Operator
(Node
, " and ");
2114 Sprint_Right_Opnd
(Node
);
2117 Sprint_Left_Opnd
(Node
);
2118 Write_Operator
(Node
, " & ");
2119 Sprint_Right_Opnd
(Node
);
2122 Sprint_Left_Opnd
(Node
);
2124 Process_TFAI_RR_Flags
(Node
);
2125 Write_Operator
(Node
, "/ ");
2126 Sprint_Right_Opnd
(Node
);
2129 Sprint_Left_Opnd
(Node
);
2130 Write_Operator
(Node
, " = ");
2131 Sprint_Right_Opnd
(Node
);
2134 Sprint_Left_Opnd
(Node
);
2135 Write_Operator
(Node
, " ** ");
2136 Sprint_Right_Opnd
(Node
);
2139 Sprint_Left_Opnd
(Node
);
2140 Write_Operator
(Node
, " >= ");
2141 Sprint_Right_Opnd
(Node
);
2144 Sprint_Left_Opnd
(Node
);
2145 Write_Operator
(Node
, " > ");
2146 Sprint_Right_Opnd
(Node
);
2149 Sprint_Left_Opnd
(Node
);
2150 Write_Operator
(Node
, " <= ");
2151 Sprint_Right_Opnd
(Node
);
2154 Sprint_Left_Opnd
(Node
);
2155 Write_Operator
(Node
, " < ");
2156 Sprint_Right_Opnd
(Node
);
2159 Write_Operator
(Node
, "-");
2160 Sprint_Right_Opnd
(Node
);
2163 Sprint_Left_Opnd
(Node
);
2165 if Treat_Fixed_As_Integer
(Node
) then
2169 Write_Operator
(Node
, " mod ");
2170 Sprint_Right_Opnd
(Node
);
2172 when N_Op_Multiply
=>
2173 Sprint_Left_Opnd
(Node
);
2175 Process_TFAI_RR_Flags
(Node
);
2176 Write_Operator
(Node
, "* ");
2177 Sprint_Right_Opnd
(Node
);
2180 Sprint_Left_Opnd
(Node
);
2181 Write_Operator
(Node
, " /= ");
2182 Sprint_Right_Opnd
(Node
);
2185 Write_Operator
(Node
, "not ");
2186 Sprint_Right_Opnd
(Node
);
2189 Sprint_Left_Opnd
(Node
);
2190 Write_Operator
(Node
, " or ");
2191 Sprint_Right_Opnd
(Node
);
2194 Write_Operator
(Node
, "+");
2195 Sprint_Right_Opnd
(Node
);
2198 Sprint_Left_Opnd
(Node
);
2200 if Treat_Fixed_As_Integer
(Node
) then
2204 Write_Operator
(Node
, " rem ");
2205 Sprint_Right_Opnd
(Node
);
2211 Write_Str_With_Col_Check
("(");
2212 Sprint_Node
(Left_Opnd
(Node
));
2214 Sprint_Node
(Right_Opnd
(Node
));
2217 when N_Op_Subtract
=>
2218 Sprint_Left_Opnd
(Node
);
2219 Write_Operator
(Node
, " - ");
2220 Sprint_Right_Opnd
(Node
);
2223 Sprint_Left_Opnd
(Node
);
2224 Write_Operator
(Node
, " xor ");
2225 Sprint_Right_Opnd
(Node
);
2227 when N_Operator_Symbol
=>
2228 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
2230 when N_Ordinary_Fixed_Point_Definition
=>
2231 Write_Str_With_Col_Check_Sloc
("delta ");
2232 Sprint_Node
(Delta_Expression
(Node
));
2233 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
2236 Sprint_Left_Opnd
(Node
);
2237 Write_Str_Sloc
(" or else ");
2238 Sprint_Right_Opnd
(Node
);
2240 when N_Others_Choice
=>
2241 if All_Others
(Node
) then
2242 Write_Str_With_Col_Check
("all ");
2245 Write_Str_With_Col_Check_Sloc
("others");
2247 when N_Package_Body
=>
2249 Write_Indent_Str_Sloc
("package body ");
2250 Sprint_Node
(Defining_Unit_Name
(Node
));
2252 Sprint_Indented_List
(Declarations
(Node
));
2254 if Present
(Handled_Statement_Sequence
(Node
)) then
2255 Write_Indent_Str
("begin");
2256 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2259 Write_Indent_Str
("end ");
2261 (Handled_Statement_Sequence
(Node
), Defining_Unit_Name
(Node
));
2264 when N_Package_Body_Stub
=>
2265 Write_Indent_Str_Sloc
("package body ");
2266 Sprint_Node
(Defining_Identifier
(Node
));
2267 Write_Str_With_Col_Check
(" is separate;");
2269 when N_Package_Declaration
=>
2272 Sprint_Node_Sloc
(Specification
(Node
));
2275 when N_Package_Instantiation
=>
2277 Write_Indent_Str_Sloc
("package ");
2278 Sprint_Node
(Defining_Unit_Name
(Node
));
2279 Write_Str
(" is new ");
2280 Sprint_Node
(Name
(Node
));
2281 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2284 when N_Package_Renaming_Declaration
=>
2285 Write_Indent_Str_Sloc
("package ");
2286 Sprint_Node
(Defining_Unit_Name
(Node
));
2287 Write_Str_With_Col_Check
(" renames ");
2288 Sprint_Node
(Name
(Node
));
2291 when N_Package_Specification
=>
2292 Write_Str_With_Col_Check_Sloc
("package ");
2293 Sprint_Node
(Defining_Unit_Name
(Node
));
2295 Sprint_Indented_List
(Visible_Declarations
(Node
));
2297 if Present
(Private_Declarations
(Node
)) then
2298 Write_Indent_Str
("private");
2299 Sprint_Indented_List
(Private_Declarations
(Node
));
2302 Write_Indent_Str
("end ");
2303 Sprint_Node
(Defining_Unit_Name
(Node
));
2305 when N_Parameter_Association
=>
2306 Sprint_Node_Sloc
(Selector_Name
(Node
));
2308 Sprint_Node
(Explicit_Actual_Parameter
(Node
));
2310 when N_Parameter_Specification
=>
2313 if Write_Identifiers
(Node
) then
2316 if In_Present
(Node
) then
2317 Write_Str_With_Col_Check
("in ");
2320 if Out_Present
(Node
) then
2321 Write_Str_With_Col_Check
("out ");
2324 -- Ada 2005 (AI-231): Parameter specification may carry null
2325 -- exclusion. Do not print it now if this is an access formal,
2326 -- it is emitted when the access definition is displayed.
2328 if Null_Exclusion_Present
(Node
)
2329 and then Nkind
(Parameter_Type
(Node
))
2330 /= N_Access_Definition
2332 Write_Str
("not null ");
2335 Sprint_Node
(Parameter_Type
(Node
));
2337 if Present
(Expression
(Node
)) then
2339 Sprint_Node
(Expression
(Node
));
2345 when N_Pop_Constraint_Error_Label
=>
2346 Write_Indent_Str
("%pop_constraint_error_label");
2348 when N_Pop_Program_Error_Label
=>
2349 Write_Indent_Str
("%pop_program_error_label");
2351 when N_Pop_Storage_Error_Label
=>
2352 Write_Indent_Str
("%pop_storage_error_label");
2354 when N_Push_Constraint_Error_Label
=>
2355 Write_Indent_Str
("%push_constraint_error_label (");
2357 if Present
(Exception_Label
(Node
)) then
2358 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2363 when N_Push_Program_Error_Label
=>
2364 Write_Indent_Str
("%push_program_error_label (");
2366 if Present
(Exception_Label
(Node
)) then
2367 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2372 when N_Push_Storage_Error_Label
=>
2373 Write_Indent_Str
("%push_storage_error_label (");
2375 if Present
(Exception_Label
(Node
)) then
2376 Write_Name_With_Col_Check
(Chars
(Exception_Label
(Node
)));
2382 Write_Indent_Str_Sloc
("pragma ");
2383 Write_Name_With_Col_Check
(Pragma_Name
(Node
));
2385 if Present
(Pragma_Argument_Associations
(Node
)) then
2386 Sprint_Opt_Paren_Comma_List
2387 (Pragma_Argument_Associations
(Node
));
2392 when N_Pragma_Argument_Association
=>
2395 if Chars
(Node
) /= No_Name
then
2396 Write_Name_With_Col_Check
(Chars
(Node
));
2400 Sprint_Node
(Expression
(Node
));
2402 when N_Private_Type_Declaration
=>
2403 Write_Indent_Str_Sloc
("type ");
2404 Write_Id
(Defining_Identifier
(Node
));
2406 if Present
(Discriminant_Specifications
(Node
)) then
2407 Write_Discr_Specs
(Node
);
2408 elsif Unknown_Discriminants_Present
(Node
) then
2409 Write_Str_With_Col_Check
("(<>)");
2414 if Tagged_Present
(Node
) then
2415 Write_Str_With_Col_Check
("tagged ");
2418 if Limited_Present
(Node
) then
2419 Write_Str_With_Col_Check
("limited ");
2422 Write_Str_With_Col_Check
("private;");
2424 when N_Private_Extension_Declaration
=>
2425 Write_Indent_Str_Sloc
("type ");
2426 Write_Id
(Defining_Identifier
(Node
));
2428 if Present
(Discriminant_Specifications
(Node
)) then
2429 Write_Discr_Specs
(Node
);
2430 elsif Unknown_Discriminants_Present
(Node
) then
2431 Write_Str_With_Col_Check
("(<>)");
2434 Write_Str_With_Col_Check
(" is new ");
2435 Sprint_Node
(Subtype_Indication
(Node
));
2437 if Present
(Interface_List
(Node
)) then
2438 Write_Str_With_Col_Check
(" and ");
2439 Sprint_And_List
(Interface_List
(Node
));
2442 Write_Str_With_Col_Check
(" with private;");
2444 when N_Procedure_Call_Statement
=>
2447 Write_Subprogram_Name
(Name
(Node
));
2448 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
2451 when N_Procedure_Instantiation
=>
2452 Write_Indent_Str_Sloc
("procedure ");
2453 Sprint_Node
(Defining_Unit_Name
(Node
));
2454 Write_Str_With_Col_Check
(" is new ");
2455 Sprint_Node
(Name
(Node
));
2456 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2459 when N_Procedure_Specification
=>
2460 Write_Str_With_Col_Check_Sloc
("procedure ");
2461 Sprint_Node
(Defining_Unit_Name
(Node
));
2462 Write_Param_Specs
(Node
);
2464 when N_Protected_Body
=>
2465 Write_Indent_Str_Sloc
("protected body ");
2466 Write_Id
(Defining_Identifier
(Node
));
2468 Sprint_Indented_List
(Declarations
(Node
));
2469 Write_Indent_Str
("end ");
2470 Write_Id
(Defining_Identifier
(Node
));
2473 when N_Protected_Body_Stub
=>
2474 Write_Indent_Str_Sloc
("protected body ");
2475 Write_Id
(Defining_Identifier
(Node
));
2476 Write_Str_With_Col_Check
(" is separate;");
2478 when N_Protected_Definition
=>
2480 Sprint_Indented_List
(Visible_Declarations
(Node
));
2482 if Present
(Private_Declarations
(Node
)) then
2483 Write_Indent_Str
("private");
2484 Sprint_Indented_List
(Private_Declarations
(Node
));
2487 Write_Indent_Str
("end ");
2489 when N_Protected_Type_Declaration
=>
2490 Write_Indent_Str_Sloc
("protected type ");
2491 Sprint_Node
(Defining_Identifier
(Node
));
2492 Write_Discr_Specs
(Node
);
2494 if Present
(Interface_List
(Node
)) then
2495 Write_Str
(" is new ");
2496 Sprint_And_List
(Interface_List
(Node
));
2497 Write_Str
(" with ");
2502 Sprint_Node
(Protected_Definition
(Node
));
2503 Write_Id
(Defining_Identifier
(Node
));
2506 when N_Qualified_Expression
=>
2507 Sprint_Node
(Subtype_Mark
(Node
));
2508 Write_Char_Sloc
(''');
2510 -- Print expression, make sure we have at least one level of
2511 -- parentheses around the expression. For cases of qualified
2512 -- expressions in the source, this is always the case, but
2513 -- for generated qualifications, there may be no explicit
2514 -- parentheses present.
2516 if Paren_Count
(Expression
(Node
)) /= 0 then
2517 Sprint_Node
(Expression
(Node
));
2520 Sprint_Node
(Expression
(Node
));
2524 when N_Raise_Constraint_Error
=>
2526 -- This node can be used either as a subexpression or as a
2527 -- statement form. The following test is a reasonably reliable
2528 -- way to distinguish the two cases.
2530 if Is_List_Member
(Node
)
2531 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2536 Write_Str_With_Col_Check_Sloc
("[constraint_error");
2537 Write_Condition_And_Reason
(Node
);
2539 when N_Raise_Program_Error
=>
2541 -- This node can be used either as a subexpression or as a
2542 -- statement form. The following test is a reasonably reliable
2543 -- way to distinguish the two cases.
2545 if Is_List_Member
(Node
)
2546 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2551 Write_Str_With_Col_Check_Sloc
("[program_error");
2552 Write_Condition_And_Reason
(Node
);
2554 when N_Raise_Storage_Error
=>
2556 -- This node can be used either as a subexpression or as a
2557 -- statement form. The following test is a reasonably reliable
2558 -- way to distinguish the two cases.
2560 if Is_List_Member
(Node
)
2561 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2566 Write_Str_With_Col_Check_Sloc
("[storage_error");
2567 Write_Condition_And_Reason
(Node
);
2569 when N_Raise_Statement
=>
2570 Write_Indent_Str_Sloc
("raise ");
2571 Sprint_Node
(Name
(Node
));
2575 Sprint_Node
(Low_Bound
(Node
));
2576 Write_Str_Sloc
(" .. ");
2577 Sprint_Node
(High_Bound
(Node
));
2578 Update_Itype
(Node
);
2580 when N_Range_Constraint
=>
2581 Write_Str_With_Col_Check_Sloc
("range ");
2582 Sprint_Node
(Range_Expression
(Node
));
2584 when N_Real_Literal
=>
2585 Write_Ureal_With_Col_Check_Sloc
(Realval
(Node
));
2587 when N_Real_Range_Specification
=>
2588 Write_Str_With_Col_Check_Sloc
("range ");
2589 Sprint_Node
(Low_Bound
(Node
));
2591 Sprint_Node
(High_Bound
(Node
));
2593 when N_Record_Definition
=>
2594 if Abstract_Present
(Node
) then
2595 Write_Str_With_Col_Check
("abstract ");
2598 if Tagged_Present
(Node
) then
2599 Write_Str_With_Col_Check
("tagged ");
2602 if Limited_Present
(Node
) then
2603 Write_Str_With_Col_Check
("limited ");
2606 if Null_Present
(Node
) then
2607 Write_Str_With_Col_Check_Sloc
("null record");
2610 Write_Str_With_Col_Check_Sloc
("record");
2611 Sprint_Node
(Component_List
(Node
));
2612 Write_Indent_Str
("end record");
2615 when N_Record_Representation_Clause
=>
2616 Write_Indent_Str_Sloc
("for ");
2617 Sprint_Node
(Identifier
(Node
));
2618 Write_Str_With_Col_Check
(" use record ");
2620 if Present
(Mod_Clause
(Node
)) then
2621 Sprint_Node
(Mod_Clause
(Node
));
2624 Sprint_Indented_List
(Component_Clauses
(Node
));
2625 Write_Indent_Str
("end record;");
2628 Sprint_Node
(Prefix
(Node
));
2629 Write_Str_With_Col_Check_Sloc
("'reference");
2631 when N_Requeue_Statement
=>
2632 Write_Indent_Str_Sloc
("requeue ");
2633 Sprint_Node
(Name
(Node
));
2635 if Abort_Present
(Node
) then
2636 Write_Str_With_Col_Check
(" with abort");
2641 -- Don't we want to print more detail???
2643 -- Doc of this extended syntax belongs in sinfo.ads and/or
2646 when N_SCIL_Dispatch_Table_Object_Init
=>
2647 Write_Indent_Str
("[N_SCIL_Dispatch_Table_Object_Init]");
2649 when N_SCIL_Dispatch_Table_Tag_Init
=>
2650 Write_Indent_Str
("[N_SCIL_Dispatch_Table_Tag_Init]");
2652 when N_SCIL_Dispatching_Call
=>
2653 Write_Indent_Str
("[N_SCIL_Dispatching_Node]");
2655 when N_SCIL_Membership_Test
=>
2656 Write_Indent_Str
("[N_SCIL_Membership_Test]");
2658 when N_SCIL_Tag_Init
=>
2659 Write_Indent_Str
("[N_SCIL_Dispatch_Table_Tag_Init]");
2661 when N_Simple_Return_Statement
=>
2662 if Present
(Expression
(Node
)) then
2663 Write_Indent_Str_Sloc
("return ");
2664 Sprint_Node
(Expression
(Node
));
2667 Write_Indent_Str_Sloc
("return;");
2670 when N_Selective_Accept
=>
2671 Write_Indent_Str_Sloc
("select");
2676 Alt_Node
:= First
(Select_Alternatives
(Node
));
2679 Sprint_Node
(Alt_Node
);
2682 exit when No
(Alt_Node
);
2683 Write_Indent_Str
("or");
2687 if Present
(Else_Statements
(Node
)) then
2688 Write_Indent_Str
("else");
2689 Sprint_Indented_List
(Else_Statements
(Node
));
2692 Write_Indent_Str
("end select;");
2694 when N_Signed_Integer_Type_Definition
=>
2695 Write_Str_With_Col_Check_Sloc
("range ");
2696 Sprint_Node
(Low_Bound
(Node
));
2698 Sprint_Node
(High_Bound
(Node
));
2700 when N_Single_Protected_Declaration
=>
2701 Write_Indent_Str_Sloc
("protected ");
2702 Write_Id
(Defining_Identifier
(Node
));
2704 Sprint_Node
(Protected_Definition
(Node
));
2705 Write_Id
(Defining_Identifier
(Node
));
2708 when N_Single_Task_Declaration
=>
2709 Write_Indent_Str_Sloc
("task ");
2710 Sprint_Node
(Defining_Identifier
(Node
));
2712 if Present
(Task_Definition
(Node
)) then
2714 Sprint_Node
(Task_Definition
(Node
));
2719 when N_Selected_Component
=>
2720 Sprint_Node
(Prefix
(Node
));
2721 Write_Char_Sloc
('.');
2722 Sprint_Node
(Selector_Name
(Node
));
2726 Sprint_Node
(Prefix
(Node
));
2727 Write_Str_With_Col_Check
(" (");
2728 Sprint_Node
(Discrete_Range
(Node
));
2731 when N_String_Literal
=>
2732 if String_Length
(Strval
(Node
)) + Column
> Sprint_Line_Limit
then
2733 Write_Indent_Str
(" ");
2737 Write_String_Table_Entry
(Strval
(Node
));
2739 when N_Subprogram_Body
=>
2741 -- Output extra blank line unless we are in freeze actions
2743 if Freeze_Indent
= 0 then
2748 Sprint_Node_Sloc
(Specification
(Node
));
2751 Sprint_Indented_List
(Declarations
(Node
));
2752 Write_Indent_Str
("begin");
2753 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2755 Write_Indent_Str
("end ");
2758 (Handled_Statement_Sequence
(Node
),
2759 Defining_Unit_Name
(Specification
(Node
)));
2762 if Is_List_Member
(Node
)
2763 and then Present
(Next
(Node
))
2764 and then Nkind
(Next
(Node
)) /= N_Subprogram_Body
2769 when N_Subprogram_Body_Stub
=>
2771 Sprint_Node_Sloc
(Specification
(Node
));
2772 Write_Str_With_Col_Check
(" is separate;");
2774 when N_Subprogram_Declaration
=>
2776 Sprint_Node_Sloc
(Specification
(Node
));
2778 if Nkind
(Specification
(Node
)) = N_Procedure_Specification
2779 and then Null_Present
(Specification
(Node
))
2781 Write_Str_With_Col_Check
(" is null");
2786 when N_Subprogram_Info
=>
2787 Sprint_Node
(Identifier
(Node
));
2788 Write_Str_With_Col_Check_Sloc
("'subprogram_info");
2790 when N_Subprogram_Renaming_Declaration
=>
2792 Sprint_Node
(Specification
(Node
));
2793 Write_Str_With_Col_Check_Sloc
(" renames ");
2794 Sprint_Node
(Name
(Node
));
2797 when N_Subtype_Declaration
=>
2798 Write_Indent_Str_Sloc
("subtype ");
2799 Sprint_Node
(Defining_Identifier
(Node
));
2802 -- Ada 2005 (AI-231)
2804 if Null_Exclusion_Present
(Node
) then
2805 Write_Str
("not null ");
2808 Sprint_Node
(Subtype_Indication
(Node
));
2811 when N_Subtype_Indication
=>
2812 Sprint_Node_Sloc
(Subtype_Mark
(Node
));
2814 Sprint_Node
(Constraint
(Node
));
2817 Write_Indent_Str_Sloc
("separate (");
2818 Sprint_Node
(Name
(Node
));
2821 Sprint_Node
(Proper_Body
(Node
));
2824 Write_Indent_Str_Sloc
("task body ");
2825 Write_Id
(Defining_Identifier
(Node
));
2827 Sprint_Indented_List
(Declarations
(Node
));
2828 Write_Indent_Str
("begin");
2829 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2830 Write_Indent_Str
("end ");
2832 (Handled_Statement_Sequence
(Node
), Defining_Identifier
(Node
));
2835 when N_Task_Body_Stub
=>
2836 Write_Indent_Str_Sloc
("task body ");
2837 Write_Id
(Defining_Identifier
(Node
));
2838 Write_Str_With_Col_Check
(" is separate;");
2840 when N_Task_Definition
=>
2842 Sprint_Indented_List
(Visible_Declarations
(Node
));
2844 if Present
(Private_Declarations
(Node
)) then
2845 Write_Indent_Str
("private");
2846 Sprint_Indented_List
(Private_Declarations
(Node
));
2849 Write_Indent_Str
("end ");
2850 Sprint_End_Label
(Node
, Defining_Identifier
(Parent
(Node
)));
2852 when N_Task_Type_Declaration
=>
2853 Write_Indent_Str_Sloc
("task type ");
2854 Sprint_Node
(Defining_Identifier
(Node
));
2855 Write_Discr_Specs
(Node
);
2857 if Present
(Interface_List
(Node
)) then
2858 Write_Str
(" is new ");
2859 Sprint_And_List
(Interface_List
(Node
));
2862 if Present
(Task_Definition
(Node
)) then
2863 if No
(Interface_List
(Node
)) then
2866 Write_Str
(" with ");
2869 Sprint_Node
(Task_Definition
(Node
));
2874 when N_Terminate_Alternative
=>
2875 Sprint_Node_List
(Pragmas_Before
(Node
));
2879 if Present
(Condition
(Node
)) then
2880 Write_Str_With_Col_Check
("when ");
2881 Sprint_Node
(Condition
(Node
));
2885 Write_Str_With_Col_Check_Sloc
("terminate;");
2886 Sprint_Node_List
(Pragmas_After
(Node
));
2888 when N_Timed_Entry_Call
=>
2889 Write_Indent_Str_Sloc
("select");
2891 Sprint_Node
(Entry_Call_Alternative
(Node
));
2893 Write_Indent_Str
("or");
2895 Sprint_Node
(Delay_Alternative
(Node
));
2897 Write_Indent_Str
("end select;");
2899 when N_Triggering_Alternative
=>
2900 Sprint_Node_List
(Pragmas_Before
(Node
));
2901 Sprint_Node_Sloc
(Triggering_Statement
(Node
));
2902 Sprint_Node_List
(Statements
(Node
));
2904 when N_Type_Conversion
=>
2906 Sprint_Node
(Subtype_Mark
(Node
));
2909 if Conversion_OK
(Node
) then
2913 if Float_Truncate
(Node
) then
2917 if Rounded_Result
(Node
) then
2922 Sprint_Node
(Expression
(Node
));
2925 when N_Unchecked_Expression
=>
2928 Sprint_Node_Sloc
(Expression
(Node
));
2931 when N_Unchecked_Type_Conversion
=>
2932 Sprint_Node
(Subtype_Mark
(Node
));
2934 Write_Str_With_Col_Check
("(");
2935 Sprint_Node_Sloc
(Expression
(Node
));
2938 when N_Unconstrained_Array_Definition
=>
2939 Write_Str_With_Col_Check_Sloc
("array (");
2944 Node1
:= First
(Subtype_Marks
(Node
));
2946 Sprint_Node
(Node1
);
2947 Write_Str_With_Col_Check
(" range <>");
2949 exit when Node1
= Empty
;
2954 Write_Str
(") of ");
2955 Sprint_Node
(Component_Definition
(Node
));
2957 when N_Unused_At_Start | N_Unused_At_End
=>
2958 Write_Indent_Str
("***** Error, unused node encountered *****");
2961 when N_Use_Package_Clause
=>
2962 Write_Indent_Str_Sloc
("use ");
2963 Sprint_Comma_List
(Names
(Node
));
2966 when N_Use_Type_Clause
=>
2967 Write_Indent_Str_Sloc
("use type ");
2968 Sprint_Comma_List
(Subtype_Marks
(Node
));
2971 when N_Validate_Unchecked_Conversion
=>
2972 Write_Indent_Str_Sloc
("validate unchecked_conversion (");
2973 Sprint_Node
(Source_Type
(Node
));
2975 Sprint_Node
(Target_Type
(Node
));
2979 Write_Indent_Str_Sloc
("when ");
2980 Sprint_Bar_List
(Discrete_Choices
(Node
));
2982 Sprint_Node
(Component_List
(Node
));
2984 when N_Variant_Part
=>
2986 Write_Indent_Str_Sloc
("case ");
2987 Sprint_Node
(Name
(Node
));
2989 Sprint_Indented_List
(Variants
(Node
));
2990 Write_Indent_Str
("end case");
2993 when N_With_Clause
=>
2995 -- Special test, if we are dumping the original tree only,
2996 -- then we want to eliminate the bogus with clauses that
2997 -- correspond to the non-existent children of Text_IO.
2999 if Dump_Original_Only
3000 and then Is_Text_IO_Kludge_Unit
(Name
(Node
))
3004 -- Normal case, output the with clause
3007 if First_Name
(Node
) or else not Dump_Original_Only
then
3009 -- Ada 2005 (AI-50217): Print limited with_clauses
3011 if Private_Present
(Node
) and Limited_Present
(Node
) then
3012 Write_Indent_Str
("limited private with ");
3014 elsif Private_Present
(Node
) then
3015 Write_Indent_Str
("private with ");
3017 elsif Limited_Present
(Node
) then
3018 Write_Indent_Str
("limited with ");
3021 Write_Indent_Str
("with ");
3028 Sprint_Node_Sloc
(Name
(Node
));
3030 if Last_Name
(Node
) or else not Dump_Original_Only
then
3037 if Nkind
(Node
) in N_Subexpr
3038 and then Do_Range_Check
(Node
)
3043 for J
in 1 .. Paren_Count
(Node
) loop
3047 Dump_Node
:= Save_Dump_Node
;
3048 end Sprint_Node_Actual
;
3050 ----------------------
3051 -- Sprint_Node_List --
3052 ----------------------
3054 procedure Sprint_Node_List
(List
: List_Id
) is
3058 if Is_Non_Empty_List
(List
) then
3059 Node
:= First
(List
);
3064 exit when Node
= Empty
;
3067 end Sprint_Node_List
;
3069 ----------------------
3070 -- Sprint_Node_Sloc --
3071 ----------------------
3073 procedure Sprint_Node_Sloc
(Node
: Node_Id
) is
3077 if Debug_Generated_Code
and then Present
(Dump_Node
) then
3078 Set_Sloc
(Dump_Node
, Sloc
(Node
));
3081 end Sprint_Node_Sloc
;
3083 ---------------------
3084 -- Sprint_Opt_Node --
3085 ---------------------
3087 procedure Sprint_Opt_Node
(Node
: Node_Id
) is
3089 if Present
(Node
) then
3093 end Sprint_Opt_Node
;
3095 --------------------------
3096 -- Sprint_Opt_Node_List --
3097 --------------------------
3099 procedure Sprint_Opt_Node_List
(List
: List_Id
) is
3101 if Present
(List
) then
3102 Sprint_Node_List
(List
);
3104 end Sprint_Opt_Node_List
;
3106 ---------------------------------
3107 -- Sprint_Opt_Paren_Comma_List --
3108 ---------------------------------
3110 procedure Sprint_Opt_Paren_Comma_List
(List
: List_Id
) is
3112 if Is_Non_Empty_List
(List
) then
3114 Sprint_Paren_Comma_List
(List
);
3116 end Sprint_Opt_Paren_Comma_List
;
3118 -----------------------------
3119 -- Sprint_Paren_Comma_List --
3120 -----------------------------
3122 procedure Sprint_Paren_Comma_List
(List
: List_Id
) is
3124 Node_Exists
: Boolean := False;
3128 if Is_Non_Empty_List
(List
) then
3130 if Dump_Original_Only
then
3132 while Present
(N
) loop
3133 if not Is_Rewrite_Insertion
(N
) then
3134 Node_Exists
:= True;
3141 if not Node_Exists
then
3146 Write_Str_With_Col_Check
("(");
3147 Sprint_Comma_List
(List
);
3150 end Sprint_Paren_Comma_List
;
3152 ----------------------
3153 -- Sprint_Right_Opnd --
3154 ----------------------
3156 procedure Sprint_Right_Opnd
(N
: Node_Id
) is
3157 Opnd
: constant Node_Id
:= Right_Opnd
(N
);
3160 if Paren_Count
(Opnd
) /= 0
3161 or else Op_Prec
(Nkind
(Opnd
)) > Op_Prec
(Nkind
(N
))
3170 end Sprint_Right_Opnd
;
3176 procedure Update_Itype
(Node
: Node_Id
) is
3178 if Present
(Etype
(Node
))
3179 and then Is_Itype
(Etype
(Node
))
3180 and then Debug_Generated_Code
3182 Set_Sloc
(Etype
(Node
), Sloc
(Node
));
3186 ---------------------
3187 -- Write_Char_Sloc --
3188 ---------------------
3190 procedure Write_Char_Sloc
(C
: Character) is
3192 if Debug_Generated_Code
and then C
/= ' ' then
3197 end Write_Char_Sloc
;
3199 --------------------------------
3200 -- Write_Condition_And_Reason --
3201 --------------------------------
3203 procedure Write_Condition_And_Reason
(Node
: Node_Id
) is
3204 Cond
: constant Node_Id
:= Condition
(Node
);
3205 Image
: constant String := RT_Exception_Code
'Image
3206 (RT_Exception_Code
'Val
3207 (UI_To_Int
(Reason
(Node
))));
3210 if Present
(Cond
) then
3212 -- If condition is a single entity, or NOT with a single entity,
3213 -- output all on one line, since it will likely fit just fine.
3215 if Is_Entity_Name
(Cond
)
3216 or else (Nkind
(Cond
) = N_Op_Not
3217 and then Is_Entity_Name
(Right_Opnd
(Cond
)))
3219 Write_Str_With_Col_Check
(" when ");
3223 -- Otherwise for more complex condition, multiple lines
3226 Write_Str_With_Col_Check
(" when");
3227 Indent
:= Indent
+ 2;
3231 Indent
:= Indent
- 2;
3234 -- If no condition, just need a space (all on one line)
3244 for J
in 4 .. Image
'Last loop
3245 if Image
(J
) = '_' then
3248 Write_Char
(Fold_Lower
(Image
(J
)));
3253 end Write_Condition_And_Reason
;
3255 --------------------------------
3256 -- Write_Corresponding_Source --
3257 --------------------------------
3259 procedure Write_Corresponding_Source
(S
: String) is
3261 Src
: Source_Buffer_Ptr
;
3264 -- Ignore if not in dump source text mode, or if in freeze actions
3266 if Dump_Source_Text
and then Freeze_Indent
= 0 then
3268 -- Ignore null string
3274 -- Ignore space or semicolon at end of given string
3276 if S
(S
'Last) = ' ' or else S
(S
'Last) = ';' then
3277 Write_Corresponding_Source
(S
(S
'First .. S
'Last - 1));
3281 -- Loop to look at next lines not yet printed in source file
3284 Last_Line_Printed
+ 1 .. Last_Source_Line
(Current_Source_File
)
3286 Src
:= Source_Text
(Current_Source_File
);
3287 Loc
:= Line_Start
(L
, Current_Source_File
);
3289 -- If comment, keep looking
3291 if Src
(Loc
.. Loc
+ 1) = "--" then
3294 -- Search to first non-blank
3297 while Src
(Loc
) not in Line_Terminator
loop
3301 if Src
(Loc
) /= ' ' and then Src
(Loc
) /= ASCII
.HT
then
3303 -- Loop through characters in string to see if we match
3305 for J
in S
'Range loop
3307 -- If mismatch, then not the case we are looking for
3309 if Src
(Loc
) /= S
(J
) then
3316 -- If we fall through, string matched, if white space or
3317 -- semicolon after the matched string, this is the case
3318 -- we are looking for.
3320 if Src
(Loc
) in Line_Terminator
3321 or else Src
(Loc
) = ' '
3322 or else Src
(Loc
) = ASCII
.HT
3323 or else Src
(Loc
) = ';'
3325 -- So output source lines up to and including this one
3327 Write_Source_Lines
(L
);
3336 -- Line was all blanks, or a comment line, keep looking
3340 end Write_Corresponding_Source
;
3342 -----------------------
3343 -- Write_Discr_Specs --
3344 -----------------------
3346 procedure Write_Discr_Specs
(N
: Node_Id
) is
3351 Specs
:= Discriminant_Specifications
(N
);
3353 if Present
(Specs
) then
3354 Write_Str_With_Col_Check
(" (");
3355 Spec
:= First
(Specs
);
3360 exit when Spec
= Empty
;
3362 -- Add semicolon, unless we are printing original tree and the
3363 -- next specification is part of a list (but not the first
3364 -- element of that list)
3366 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
3373 end Write_Discr_Specs
;
3379 procedure Write_Ekind
(E
: Entity_Id
) is
3380 S
: constant String := Entity_Kind
'Image (Ekind
(E
));
3383 Name_Len
:= S
'Length;
3384 Name_Buffer
(1 .. Name_Len
) := S
;
3385 Set_Casing
(Mixed_Case
);
3386 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3393 procedure Write_Id
(N
: Node_Id
) is
3395 -- Deal with outputting Itype
3397 -- Note: if we are printing the full tree with -gnatds, then we may
3398 -- end up picking up the Associated_Node link from a generic template
3399 -- here which overlaps the Entity field, but as documented, Write_Itype
3400 -- is defended against junk calls.
3402 if Nkind
(N
) in N_Entity
then
3404 elsif Nkind
(N
) in N_Has_Entity
then
3405 Write_Itype
(Entity
(N
));
3408 -- Case of a defining identifier
3410 if Nkind
(N
) = N_Defining_Identifier
then
3412 -- If defining identifier has an interface name (and no
3413 -- address clause), then we output the interface name.
3415 if (Is_Imported
(N
) or else Is_Exported
(N
))
3416 and then Present
(Interface_Name
(N
))
3417 and then No
(Address_Clause
(N
))
3419 String_To_Name_Buffer
(Strval
(Interface_Name
(N
)));
3420 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3422 -- If no interface name (or inactive because there was
3423 -- an address clause), then just output the Chars name.
3426 Write_Name_With_Col_Check
(Chars
(N
));
3429 -- Case of selector of an expanded name where the expanded name
3430 -- has an associated entity, output this entity.
3432 elsif Nkind
(Parent
(N
)) = N_Expanded_Name
3433 and then Selector_Name
(Parent
(N
)) = N
3434 and then Present
(Entity
(Parent
(N
)))
3436 Write_Id
(Entity
(Parent
(N
)));
3438 -- For any other node with an associated entity, output it
3440 elsif Nkind
(N
) in N_Has_Entity
3441 and then Present
(Entity_Or_Associated_Node
(N
))
3442 and then Nkind
(Entity_Or_Associated_Node
(N
)) in N_Entity
3444 Write_Id
(Entity
(N
));
3446 -- All other cases, we just print the Chars field
3449 Write_Name_With_Col_Check
(Chars
(N
));
3453 -----------------------
3454 -- Write_Identifiers --
3455 -----------------------
3457 function Write_Identifiers
(Node
: Node_Id
) return Boolean is
3459 Sprint_Node
(Defining_Identifier
(Node
));
3460 Update_Itype
(Defining_Identifier
(Node
));
3462 -- The remainder of the declaration must be printed unless we are
3463 -- printing the original tree and this is not the last identifier
3466 not Dump_Original_Only
or else not More_Ids
(Node
);
3468 end Write_Identifiers
;
3470 ------------------------
3471 -- Write_Implicit_Def --
3472 ------------------------
3474 procedure Write_Implicit_Def
(E
: Entity_Id
) is
3479 when E_Array_Subtype
=>
3480 Write_Str_With_Col_Check
("subtype ");
3482 Write_Str_With_Col_Check
(" is ");
3483 Write_Id
(Base_Type
(E
));
3484 Write_Str_With_Col_Check
(" (");
3486 Ind
:= First_Index
(E
);
3487 while Present
(Ind
) loop
3491 if Present
(Ind
) then
3498 when E_Signed_Integer_Subtype | E_Enumeration_Subtype
=>
3499 Write_Str_With_Col_Check
("subtype ");
3502 Write_Id
(Etype
(E
));
3503 Write_Str_With_Col_Check
(" range ");
3504 Sprint_Node
(Scalar_Range
(E
));
3508 Write_Str_With_Col_Check
("type ");
3510 Write_Str_With_Col_Check
(" is <");
3515 end Write_Implicit_Def
;
3521 procedure Write_Indent
is
3522 Loc
: constant Source_Ptr
:= Sloc
(Dump_Node
);
3525 if Indent_Annull_Flag
then
3526 Indent_Annull_Flag
:= False;
3528 -- Deal with Dump_Source_Text output. Note that we ignore implicit
3529 -- label declarations, since they typically have the sloc of the
3530 -- corresponding label, which really messes up the -gnatL output.
3533 and then Loc
> No_Location
3534 and then Nkind
(Dump_Node
) /= N_Implicit_Label_Declaration
3536 if Get_Source_File_Index
(Loc
) = Current_Source_File
then
3538 (Get_Physical_Line_Number
(Sloc
(Dump_Node
)));
3544 for J
in 1 .. Indent
loop
3550 ------------------------------
3551 -- Write_Indent_Identifiers --
3552 ------------------------------
3554 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean is
3556 -- We need to start a new line for every node, except in the case
3557 -- where we are printing the original tree and this is not the first
3558 -- defining identifier in the list.
3560 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
3563 -- If printing original tree and this is not the first defining
3564 -- identifier in the list, then the previous call to this procedure
3565 -- printed only the name, and we add a comma to separate the names.
3571 Sprint_Node
(Defining_Identifier
(Node
));
3573 -- The remainder of the declaration must be printed unless we are
3574 -- printing the original tree and this is not the last identifier
3577 not Dump_Original_Only
or else not More_Ids
(Node
);
3578 end Write_Indent_Identifiers
;
3580 -----------------------------------
3581 -- Write_Indent_Identifiers_Sloc --
3582 -----------------------------------
3584 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean is
3586 -- We need to start a new line for every node, except in the case
3587 -- where we are printing the original tree and this is not the first
3588 -- defining identifier in the list.
3590 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
3593 -- If printing original tree and this is not the first defining
3594 -- identifier in the list, then the previous call to this procedure
3595 -- printed only the name, and we add a comma to separate the names.
3602 Sprint_Node
(Defining_Identifier
(Node
));
3604 -- The remainder of the declaration must be printed unless we are
3605 -- printing the original tree and this is not the last identifier
3607 return not Dump_Original_Only
or else not More_Ids
(Node
);
3608 end Write_Indent_Identifiers_Sloc
;
3610 ----------------------
3611 -- Write_Indent_Str --
3612 ----------------------
3614 procedure Write_Indent_Str
(S
: String) is
3616 Write_Corresponding_Source
(S
);
3619 end Write_Indent_Str
;
3621 ---------------------------
3622 -- Write_Indent_Str_Sloc --
3623 ---------------------------
3625 procedure Write_Indent_Str_Sloc
(S
: String) is
3627 Write_Corresponding_Source
(S
);
3630 end Write_Indent_Str_Sloc
;
3636 procedure Write_Itype
(Typ
: Entity_Id
) is
3638 procedure Write_Header
(T
: Boolean := True);
3639 -- Write type if T is True, subtype if T is false
3645 procedure Write_Header
(T
: Boolean := True) is
3648 Write_Str
("[type ");
3650 Write_Str
("[subtype ");
3653 Write_Name_With_Col_Check
(Chars
(Typ
));
3657 -- Start of processing for Write_Itype
3660 if Nkind
(Typ
) in N_Entity
3661 and then Is_Itype
(Typ
)
3662 and then not Itype_Printed
(Typ
)
3664 -- Itype to be printed
3667 B
: constant Node_Id
:= Etype
(Typ
);
3669 P
: constant Node_Id
:= Parent
(Typ
);
3671 S
: constant Saved_Output_Buffer
:= Save_Output_Buffer
;
3672 -- Save current output buffer
3674 Old_Sloc
: Source_Ptr
;
3675 -- Save sloc of related node, so it is not modified when
3676 -- printing with -gnatD.
3679 -- Write indentation at start of line
3681 for J
in 1 .. Indent
loop
3685 -- If we have a constructed declaration for the itype, print it
3688 and then Nkind
(P
) in N_Declaration
3689 and then Defining_Entity
(P
) = Typ
3691 -- We must set Itype_Printed true before the recursive call to
3692 -- print the node, otherwise we get an infinite recursion!
3694 Set_Itype_Printed
(Typ
, True);
3696 -- Write the declaration enclosed in [], avoiding new line
3697 -- at start of declaration, and semicolon at end.
3699 -- Note: The itype may be imported from another unit, in which
3700 -- case we do not want to modify the Sloc of the declaration.
3701 -- Otherwise the itype may appear to be in the current unit,
3702 -- and the back-end will reject a reference out of scope.
3705 Indent_Annull_Flag
:= True;
3706 Old_Sloc
:= Sloc
(P
);
3708 Set_Sloc
(P
, Old_Sloc
);
3709 Write_Erase_Char
(';');
3711 -- If no constructed declaration, then we have to concoct the
3712 -- source corresponding to the type entity that we have at hand.
3717 -- Access types and subtypes
3720 Write_Header
(Ekind
(Typ
) = E_Access_Type
);
3721 Write_Str
("access ");
3723 if Is_Access_Constant
(Typ
) then
3724 Write_Str
("constant ");
3725 elsif Can_Never_Be_Null
(Typ
) then
3726 Write_Str
("not null ");
3729 Write_Id
(Directly_Designated_Type
(Typ
));
3731 -- Array types and string types
3733 when E_Array_Type | E_String_Type
=>
3735 Write_Str
("array (");
3737 X
:= First_Index
(Typ
);
3741 if not Is_Constrained
(Typ
) then
3742 Write_Str
(" range <>");
3750 Write_Str
(") of ");
3751 X
:= Component_Type
(Typ
);
3753 -- Preserve sloc of component type, which is defined
3754 -- elsewhere than the itype (see comment above).
3756 Old_Sloc
:= Sloc
(X
);
3758 Set_Sloc
(X
, Old_Sloc
);
3760 -- Array subtypes and string subtypes.
3761 -- Preserve Sloc of index subtypes, as above.
3763 when E_Array_Subtype | E_String_Subtype
=>
3764 Write_Header
(False);
3765 Write_Id
(Etype
(Typ
));
3768 X
:= First_Index
(Typ
);
3770 Old_Sloc
:= Sloc
(X
);
3772 Set_Sloc
(X
, Old_Sloc
);
3780 -- Signed integer types, and modular integer subtypes,
3781 -- and also enumeration subtypes.
3783 when E_Signed_Integer_Type |
3784 E_Signed_Integer_Subtype |
3785 E_Modular_Integer_Subtype |
3786 E_Enumeration_Subtype
=>
3788 Write_Header
(Ekind
(Typ
) = E_Signed_Integer_Type
);
3790 if Ekind
(Typ
) = E_Signed_Integer_Type
then
3796 -- Print bounds if different from base type
3799 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3800 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
3805 -- B can either be a scalar type, in which case the
3806 -- declaration of Typ may constrain it with different
3807 -- bounds, or a private type, in which case we know
3808 -- that the declaration of Typ cannot have a scalar
3811 if Is_Scalar_Type
(B
) then
3812 LE
:= Type_Low_Bound
(B
);
3813 HE
:= Type_High_Bound
(B
);
3821 and then Nkind
(L
) = N_Integer_Literal
3822 and then Nkind
(H
) = N_Integer_Literal
3823 and then Nkind
(LE
) = N_Integer_Literal
3824 and then Nkind
(HE
) = N_Integer_Literal
3825 and then UI_Eq
(Intval
(L
), Intval
(LE
))
3826 and then UI_Eq
(Intval
(H
), Intval
(HE
)))
3831 Write_Str
(" range ");
3832 Sprint_Node
(Type_Low_Bound
(Typ
));
3834 Sprint_Node
(Type_High_Bound
(Typ
));
3838 -- Modular integer types
3840 when E_Modular_Integer_Type
=>
3842 Write_Str
(" mod ");
3843 Write_Uint_With_Col_Check
(Modulus
(Typ
), Auto
);
3845 -- Floating point types and subtypes
3847 when E_Floating_Point_Type |
3848 E_Floating_Point_Subtype
=>
3850 Write_Header
(Ekind
(Typ
) = E_Floating_Point_Type
);
3852 if Ekind
(Typ
) = E_Floating_Point_Type
then
3856 Write_Id
(Etype
(Typ
));
3858 if Digits_Value
(Typ
) /= Digits_Value
(Etype
(Typ
)) then
3859 Write_Str
(" digits ");
3860 Write_Uint_With_Col_Check
3861 (Digits_Value
(Typ
), Decimal
);
3864 -- Print bounds if not different from base type
3867 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3868 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
3869 LE
: constant Node_Id
:= Type_Low_Bound
(B
);
3870 HE
: constant Node_Id
:= Type_High_Bound
(B
);
3873 if Nkind
(L
) = N_Real_Literal
3874 and then Nkind
(H
) = N_Real_Literal
3875 and then Nkind
(LE
) = N_Real_Literal
3876 and then Nkind
(HE
) = N_Real_Literal
3877 and then UR_Eq
(Realval
(L
), Realval
(LE
))
3878 and then UR_Eq
(Realval
(H
), Realval
(HE
))
3883 Write_Str
(" range ");
3884 Sprint_Node
(Type_Low_Bound
(Typ
));
3886 Sprint_Node
(Type_High_Bound
(Typ
));
3892 when E_Record_Subtype
=>
3893 Write_Header
(False);
3894 Write_Str
("record");
3900 C
:= First_Entity
(Typ
);
3901 while Present
(C
) loop
3905 Write_Id
(Etype
(C
));
3911 Write_Indent_Str
(" end record");
3915 when E_Class_Wide_Type |
3916 E_Class_Wide_Subtype
=>
3918 Write_Name_With_Col_Check
(Chars
(Etype
(Typ
)));
3919 Write_Str
("'Class");
3923 when E_Subprogram_Type
=>
3926 if Etype
(Typ
) = Standard_Void_Type
then
3927 Write_Str
("procedure");
3929 Write_Str
("function");
3932 if Present
(First_Entity
(Typ
)) then
3939 Param
:= First_Entity
(Typ
);
3944 if Ekind
(Param
) = E_In_Out_Parameter
then
3945 Write_Str
("in out ");
3946 elsif Ekind
(Param
) = E_Out_Parameter
then
3950 Write_Id
(Etype
(Param
));
3951 Next_Entity
(Param
);
3952 exit when No
(Param
);
3960 if Etype
(Typ
) /= Standard_Void_Type
then
3961 Write_Str
(" return ");
3962 Write_Id
(Etype
(Typ
));
3965 when E_String_Literal_Subtype
=>
3967 LB
: constant Uint
:=
3968 Expr_Value
(String_Literal_Low_Bound
(Typ
));
3969 Len
: constant Uint
:=
3970 String_Literal_Length
(Typ
);
3972 Write_Str
("String (");
3973 Write_Int
(UI_To_Int
(LB
));
3975 Write_Int
(UI_To_Int
(LB
+ Len
) - 1);
3979 -- For all other Itypes, print ??? (fill in later)
3982 Write_Header
(True);
3988 -- Add terminating bracket and restore output buffer
3992 Restore_Output_Buffer
(S
);
3995 Set_Itype_Printed
(Typ
);
3999 -------------------------------
4000 -- Write_Name_With_Col_Check --
4001 -------------------------------
4003 procedure Write_Name_With_Col_Check
(N
: Name_Id
) is
4009 Get_Name_String
(N
);
4011 -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an
4012 -- upper case letter, nnn is one or more digits and b is a lower case
4013 -- letter by C...b, so that listings do not depend on serial numbers.
4015 if Debug_Flag_II
then
4017 while J
< Name_Len
- 1 loop
4018 if Name_Buffer
(J
) in 'A' .. 'Z'
4019 and then Name_Buffer
(J
+ 1) in '0' .. '9'
4022 while K
< Name_Len
loop
4023 exit when Name_Buffer
(K
) not in '0' .. '9';
4027 if Name_Buffer
(K
) in 'a' .. 'z' then
4028 L
:= Name_Len
- K
+ 1;
4030 Name_Buffer
(J
+ 4 .. J
+ L
+ 3) :=
4031 Name_Buffer
(K
.. Name_Len
);
4032 Name_Buffer
(J
+ 1 .. J
+ 3) := "...";
4033 Name_Len
:= J
+ L
+ 3;
4046 -- Fall through for normal case
4048 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
4049 end Write_Name_With_Col_Check
;
4051 ------------------------------------
4052 -- Write_Name_With_Col_Check_Sloc --
4053 ------------------------------------
4055 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
) is
4057 Get_Name_String
(N
);
4058 Write_Str_With_Col_Check_Sloc
(Name_Buffer
(1 .. Name_Len
));
4059 end Write_Name_With_Col_Check_Sloc
;
4061 --------------------
4062 -- Write_Operator --
4063 --------------------
4065 procedure Write_Operator
(N
: Node_Id
; S
: String) is
4066 F
: Natural := S
'First;
4067 T
: Natural := S
'Last;
4070 -- If no overflow check, just write string out, and we are done
4072 if not Do_Overflow_Check
(N
) then
4075 -- If overflow check, we want to surround the operator with curly
4076 -- brackets, but not include spaces within the brackets.
4089 Write_Str_Sloc
(S
(F
.. T
));
4092 if S
(S
'Last) = ' ' then
4098 -----------------------
4099 -- Write_Param_Specs --
4100 -----------------------
4102 procedure Write_Param_Specs
(N
: Node_Id
) is
4108 Specs
:= Parameter_Specifications
(N
);
4110 if Is_Non_Empty_List
(Specs
) then
4111 Write_Str_With_Col_Check
(" (");
4112 Spec
:= First
(Specs
);
4116 Formal
:= Defining_Identifier
(Spec
);
4118 exit when Spec
= Empty
;
4120 -- Add semicolon, unless we are printing original tree and the
4121 -- next specification is part of a list (but not the first element
4124 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
4129 -- Write out any extra formals
4131 while Present
(Extra_Formal
(Formal
)) loop
4132 Formal
:= Extra_Formal
(Formal
);
4134 Write_Name_With_Col_Check
(Chars
(Formal
));
4136 Write_Name_With_Col_Check
(Chars
(Etype
(Formal
)));
4141 end Write_Param_Specs
;
4143 -----------------------
4144 -- Write_Rewrite_Str --
4145 -----------------------
4147 procedure Write_Rewrite_Str
(S
: String) is
4149 if not Dump_Generated_Only
then
4150 if S
'Length = 3 and then S
= ">>>" then
4153 Write_Str_With_Col_Check
(S
);
4156 end Write_Rewrite_Str
;
4158 -----------------------
4159 -- Write_Source_Line --
4160 -----------------------
4162 procedure Write_Source_Line
(L
: Physical_Line_Number
) is
4164 Src
: Source_Buffer_Ptr
;
4168 if Dump_Source_Text
then
4169 Src
:= Source_Text
(Current_Source_File
);
4170 Loc
:= Line_Start
(L
, Current_Source_File
);
4173 -- See if line is a comment line, if not, and if not line one,
4174 -- precede with blank line.
4177 while Src
(Scn
) = ' ' or else Src
(Scn
) = ASCII
.HT
loop
4181 if (Src
(Scn
) in Line_Terminator
4182 or else Src
(Scn
.. Scn
+ 1) /= "--")
4188 -- Now write the source text of the line
4191 Write_Int
(Int
(L
));
4194 while Src
(Loc
) not in Line_Terminator
loop
4195 Write_Char
(Src
(Loc
));
4199 end Write_Source_Line
;
4201 ------------------------
4202 -- Write_Source_Lines --
4203 ------------------------
4205 procedure Write_Source_Lines
(L
: Physical_Line_Number
) is
4207 while Last_Line_Printed
< L
loop
4208 Last_Line_Printed
:= Last_Line_Printed
+ 1;
4209 Write_Source_Line
(Last_Line_Printed
);
4211 end Write_Source_Lines
;
4213 --------------------
4214 -- Write_Str_Sloc --
4215 --------------------
4217 procedure Write_Str_Sloc
(S
: String) is
4219 for J
in S
'Range loop
4220 Write_Char_Sloc
(S
(J
));
4224 ------------------------------
4225 -- Write_Str_With_Col_Check --
4226 ------------------------------
4228 procedure Write_Str_With_Col_Check
(S
: String) is
4230 if Int
(S
'Last) + Column
> Sprint_Line_Limit
then
4231 Write_Indent_Str
(" ");
4233 if S
(S
'First) = ' ' then
4234 Write_Str
(S
(S
'First + 1 .. S
'Last));
4242 end Write_Str_With_Col_Check
;
4244 -----------------------------------
4245 -- Write_Str_With_Col_Check_Sloc --
4246 -----------------------------------
4248 procedure Write_Str_With_Col_Check_Sloc
(S
: String) is
4250 if Int
(S
'Last) + Column
> Sprint_Line_Limit
then
4251 Write_Indent_Str
(" ");
4253 if S
(S
'First) = ' ' then
4254 Write_Str_Sloc
(S
(S
'First + 1 .. S
'Last));
4262 end Write_Str_With_Col_Check_Sloc
;
4264 ---------------------------
4265 -- Write_Subprogram_Name --
4266 ---------------------------
4268 procedure Write_Subprogram_Name
(N
: Node_Id
) is
4270 if not Comes_From_Source
(N
)
4271 and then Is_Entity_Name
(N
)
4274 Ent
: constant Entity_Id
:= Entity
(N
);
4276 if not In_Extended_Main_Source_Unit
(Ent
)
4278 Is_Predefined_File_Name
4279 (Unit_File_Name
(Get_Source_Unit
(Ent
)))
4281 -- Run-time routine name, output name with a preceding dollar
4282 -- making sure that we do not get a line split between them.
4284 Col_Check
(Length_Of_Name
(Chars
(Ent
)) + 1);
4286 Write_Name
(Chars
(Ent
));
4292 -- Normal case, not a run-time routine name
4295 end Write_Subprogram_Name
;
4297 -------------------------------
4298 -- Write_Uint_With_Col_Check --
4299 -------------------------------
4301 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
) is
4303 Col_Check
(UI_Decimal_Digits_Hi
(U
));
4304 UI_Write
(U
, Format
);
4305 end Write_Uint_With_Col_Check
;
4307 ------------------------------------
4308 -- Write_Uint_With_Col_Check_Sloc --
4309 ------------------------------------
4311 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
) is
4313 Col_Check
(UI_Decimal_Digits_Hi
(U
));
4315 UI_Write
(U
, Format
);
4316 end Write_Uint_With_Col_Check_Sloc
;
4318 -------------------------------------
4319 -- Write_Ureal_With_Col_Check_Sloc --
4320 -------------------------------------
4322 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
) is
4323 D
: constant Uint
:= Denominator
(U
);
4324 N
: constant Uint
:= Numerator
(U
);
4328 (UI_Decimal_Digits_Hi
(D
) + UI_Decimal_Digits_Hi
(N
) + 4);
4331 end Write_Ureal_With_Col_Check_Sloc
;