1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Csets
; use Csets
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Fname
; use Fname
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
37 with Output
; use Output
;
38 with Rtsfind
; use Rtsfind
;
39 with Sinfo
; use Sinfo
;
40 with Sinput
; use Sinput
;
41 with Sinput
.D
; use Sinput
.D
;
42 with Snames
; use Snames
;
43 with Stand
; use Stand
;
44 with Stringt
; use Stringt
;
45 with Uintp
; use Uintp
;
46 with Uname
; use Uname
;
47 with Urealp
; use Urealp
;
49 package body Sprint
is
50 Current_Source_File
: Source_File_Index
;
51 -- Index of source file whose generated code is being dumped
53 Dump_Node
: Node_Id
:= Empty
;
54 -- This is set to the current node, used for printing line numbers. In
55 -- Debug_Generated_Code mode, Dump_Node is set to the current node
56 -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
57 -- value. The call clears it back to Empty.
59 Debug_Sloc
: Source_Ptr
;
60 -- Sloc of first byte of line currently being written if we are
61 -- generating a source debug file.
63 Dump_Original_Only
: Boolean;
64 -- Set True if the -gnatdo (dump original tree) flag is set
66 Dump_Generated_Only
: Boolean;
67 -- Set True if the -gnatG (dump generated tree) debug flag is set
68 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
70 Dump_Freeze_Null
: Boolean;
71 -- Set True if freeze nodes and non-source null statements output
73 Freeze_Indent
: Int
:= 0;
74 -- Keep track of freeze indent level (controls output of blank lines before
75 -- procedures within expression freeze actions). Relevant only if we are
76 -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
77 -- output these blank lines in any case.
80 -- Number of columns for current line output indentation
82 Indent_Annull_Flag
: Boolean := False;
83 -- Set True if subsequent Write_Indent call to be ignored, gets reset
84 -- by this call, so it is only active to suppress a single indent call.
86 Last_Line_Printed
: Physical_Line_Number
;
87 -- This keeps track of the physical line number of the last source line
88 -- that has been output. The value is only valid in Dump_Source_Text mode.
90 Line_Limit
: constant := 72;
91 -- Limit value for chopping long lines
93 -------------------------------
94 -- Operator Precedence Table --
95 -------------------------------
97 -- This table is used to decide whether a subexpression needs to be
98 -- parenthesized. The rule is that if an operand of an operator (which
99 -- for this purpose includes AND THEN and OR ELSE) is itself an operator
100 -- with a lower precedence than the operator (or equal precedence if
101 -- appearing as the right operand), then parentheses are required.
103 Op_Prec
: constant array (N_Subexpr
) of Short_Short_Integer :=
136 procedure Sprint_Left_Opnd
(N
: Node_Id
);
137 -- Print left operand of operator, parenthesizing if necessary
139 procedure Sprint_Right_Opnd
(N
: Node_Id
);
140 -- Print right operand of operator, parenthesizing if necessary
142 -----------------------
143 -- Local Subprograms --
144 -----------------------
146 procedure Col_Check
(N
: Nat
);
147 -- Check that at least N characters remain on current line, and if not,
148 -- then start an extra line with two characters extra indentation for
149 -- continuing text on the next line.
151 procedure Extra_Blank_Line
;
152 -- In some situations we write extra blank lines to separate the generated
153 -- code to make it more readable. However, these extra blank lines are not
154 -- generated in Dump_Source_Text mode, since there the source text lines
155 -- output with preceding blank lines are quite sufficient as separators.
156 -- This procedure writes a blank line if Dump_Source_Text is False.
158 procedure Indent_Annull
;
159 -- Causes following call to Write_Indent to be ignored. This is used when
160 -- a higher level node wants to stop a lower level node from starting a
161 -- new line, when it would otherwise be inclined to do so (e.g. the case
162 -- of an accept statement called from an accept alternative with a guard)
164 procedure Indent_Begin
;
165 -- Increase indentation level
167 procedure Indent_End
;
168 -- Decrease indentation level
170 procedure Note_Implicit_Run_Time_Call
(N
: Node_Id
);
171 -- N is the Name field of a function call or procedure statement call.
172 -- The effect of the call is to output a $ if the call is identified as
173 -- an implicit call to a run time routine.
175 procedure Print_Debug_Line
(S
: String);
176 -- Used to print output lines in Debug_Generated_Code mode (this is used
177 -- as the argument for a call to Set_Special_Output in package Output).
179 procedure Process_TFAI_RR_Flags
(Nod
: Node_Id
);
180 -- Given a divide, multiplication or division node, check the flags
181 -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the
182 -- appropriate special syntax characters (# and @).
184 procedure Set_Debug_Sloc
;
185 -- If Dump_Node is non-empty, this routine sets the appropriate value
186 -- in its Sloc field, from the current location in the debug source file
187 -- that is currently being written.
189 procedure Sprint_And_List
(List
: List_Id
);
190 -- Print the given list with items separated by vertical "and"
192 procedure Sprint_Bar_List
(List
: List_Id
);
193 -- Print the given list with items separated by vertical bars
195 procedure Sprint_Node_Actual
(Node
: Node_Id
);
196 -- This routine prints its node argument. It is a lower level routine than
197 -- Sprint_Node, in that it does not bother about rewritten trees.
199 procedure Sprint_Node_Sloc
(Node
: Node_Id
);
200 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode,
201 -- sets the Sloc of the current debug node to be a copy of the Sloc
202 -- of the sprinted node Node. Note that this is done after printing
203 -- Node, so that the Sloc is the proper updated value for the debug file.
205 procedure Write_Char_Sloc
(C
: Character);
206 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
207 -- called to ensure that the current node has a proper Sloc set.
209 procedure Write_Condition_And_Reason
(Node
: Node_Id
);
210 -- Write Condition and Reason codes of Raise_xxx_Error node
212 procedure Write_Corresponding_Source
(S
: String);
213 -- If S is a string with a single keyword (possibly followed by a space),
214 -- and if the next non-comment non-blank source line matches this keyword,
215 -- then output all source lines up to this matching line.
217 procedure Write_Discr_Specs
(N
: Node_Id
);
218 -- Ouput discriminant specification for node, which is any of the type
219 -- declarations that can have discriminants.
221 procedure Write_Ekind
(E
: Entity_Id
);
222 -- Write the String corresponding to the Ekind without "E_"
224 procedure Write_Id
(N
: Node_Id
);
225 -- N is a node with a Chars field. This procedure writes the name that
226 -- will be used in the generated code associated with the name. For a
227 -- node with no associated entity, this is simply the Chars field. For
228 -- the case where there is an entity associated with the node, we print
229 -- the name associated with the entity (since it may have been encoded).
230 -- One other special case is that an entity has an active external name
231 -- (i.e. an external name present with no address clause), then this
232 -- external name is output. This procedure also deals with outputting
233 -- declarations of referenced itypes, if not output earlier.
235 function Write_Identifiers
(Node
: Node_Id
) return Boolean;
236 -- Handle node where the grammar has a list of defining identifiers, but
237 -- the tree has a separate declaration for each identifier. Handles the
238 -- printing of the defining identifier, and returns True if the type and
239 -- initialization information is to be printed, False if it is to be
240 -- skipped (the latter case happens when printing defining identifiers
241 -- other than the first in the original tree output case).
243 procedure Write_Implicit_Def
(E
: Entity_Id
);
244 pragma Warnings
(Off
, Write_Implicit_Def
);
245 -- Write the definition of the implicit type E according to its Ekind
246 -- For now a debugging procedure, but might be used in the future.
248 procedure Write_Indent
;
249 -- Start a new line and write indentation spacing
251 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean;
252 -- Like Write_Identifiers except that each new printed declaration
253 -- is at the start of a new line.
255 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean;
256 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code
257 -- mode, the Sloc of the current debug node is set to point ot the
258 -- first output identifier.
260 procedure Write_Indent_Str
(S
: String);
261 -- Start a new line and write indent spacing followed by given string
263 procedure Write_Indent_Str_Sloc
(S
: String);
264 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode,
265 -- the Sloc of the current node is set to the first non-blank character
268 procedure Write_Itype
(Typ
: Entity_Id
);
269 -- If Typ is an Itype that has not been written yet, write it. If Typ is
270 -- any other kind of entity or tree node, the call is ignored.
272 procedure Write_Name_With_Col_Check
(N
: Name_Id
);
273 -- Write name (using Write_Name) with initial column check, and possible
274 -- initial Write_Indent (to get new line) if current line is too full.
276 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
);
277 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code
278 -- mode, sets Sloc of current debug node to first character of name.
280 procedure Write_Operator
(N
: Node_Id
; S
: String);
281 -- Like Write_Str_Sloc, used for operators, encloses the string in
282 -- characters {} if the Do_Overflow flag is set on the node N.
284 procedure Write_Param_Specs
(N
: Node_Id
);
285 -- Output parameter specifications for node (which is either a function
286 -- or procedure specification with a Parameter_Specifications field)
288 procedure Write_Rewrite_Str
(S
: String);
289 -- Writes out a string (typically containing <<< or >>>}) for a node
290 -- created by rewriting the tree. Suppressed if we are outputting the
291 -- generated code only, since in this case we don't specially mark nodes
292 -- created by rewriting).
294 procedure Write_Source_Line
(L
: Physical_Line_Number
);
295 -- If writing of interspersed source lines is enabled, then write the given
296 -- line from the source file, preceded by Eol, then an extra blank line if
297 -- the line has at least one blank, is not a comment and is not line one,
298 -- then "--" and the line number followed by period followed by text of the
299 -- source line (without terminating Eol). If interspersed source line
300 -- output not enabled, then the call has no effect.
302 procedure Write_Source_Lines
(L
: Physical_Line_Number
);
303 -- If writing of interspersed source lines is enabled, then writes source
304 -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
305 -- interspersed source line output not enabled, then call has no effect.
307 procedure Write_Str_Sloc
(S
: String);
308 -- Like Write_Str, but sets debug Sloc of current debug node to first
309 -- non-blank character if a current debug node is active.
311 procedure Write_Str_With_Col_Check
(S
: String);
312 -- Write string (using Write_Str) with initial column check, and possible
313 -- initial Write_Indent (to get new line) if current line is too full.
315 procedure Write_Str_With_Col_Check_Sloc
(S
: String);
316 -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug
317 -- node to first non-blank character if a current debug node is active.
319 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
);
320 -- Write Uint (using UI_Write) with initial column check, and possible
321 -- initial Write_Indent (to get new line) if current line is too full.
322 -- The format parameter determines the output format (see UI_Write).
324 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
);
325 -- Write Uint (using UI_Write) with initial column check, and possible
326 -- initial Write_Indent (to get new line) if current line is too full.
327 -- The format parameter determines the output format (see UI_Write).
328 -- In addition, in Debug_Generated_Code mode, sets the current node
329 -- Sloc to the first character of the output value.
331 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
);
332 -- Write Ureal (using same output format as UR_Write) with column checks
333 -- and a possible initial Write_Indent (to get new line) if current line
334 -- is too full. In addition, in Debug_Generated_Code mode, sets the
335 -- current node Sloc to the first character of the output value.
341 procedure Col_Check
(N
: Nat
) is
343 if N
+ Column
> Line_Limit
then
344 Write_Indent_Str
(" ");
348 ----------------------
349 -- Extra_Blank_Line --
350 ----------------------
352 procedure Extra_Blank_Line
is
354 if not Dump_Source_Text
then
357 end Extra_Blank_Line
;
363 procedure Indent_Annull
is
365 Indent_Annull_Flag
:= True;
372 procedure Indent_Begin
is
374 Indent
:= Indent
+ 3;
381 procedure Indent_End
is
383 Indent
:= Indent
- 3;
386 ---------------------------------
387 -- Note_Implicit_Run_Time_Call --
388 ---------------------------------
390 procedure Note_Implicit_Run_Time_Call
(N
: Node_Id
) is
392 if not Comes_From_Source
(N
)
393 and then Is_Entity_Name
(N
)
396 Ent
: constant Entity_Id
:= Entity
(N
);
398 if not In_Extended_Main_Source_Unit
(Ent
)
400 Is_Predefined_File_Name
401 (Unit_File_Name
(Get_Source_Unit
(Ent
)))
403 Col_Check
(Length_Of_Name
(Chars
(Ent
)));
408 end Note_Implicit_Run_Time_Call
;
414 procedure pg
(Node
: Node_Id
) is
416 Dump_Generated_Only
:= True;
417 Dump_Original_Only
:= False;
418 Current_Source_File
:= No_Source_File
;
427 procedure po
(Node
: Node_Id
) is
429 Dump_Generated_Only
:= False;
430 Dump_Original_Only
:= True;
431 Current_Source_File
:= No_Source_File
;
436 ----------------------
437 -- Print_Debug_Line --
438 ----------------------
440 procedure Print_Debug_Line
(S
: String) is
442 Write_Debug_Line
(S
, Debug_Sloc
);
443 end Print_Debug_Line
;
445 ---------------------------
446 -- Process_TFAI_RR_Flags --
447 ---------------------------
449 procedure Process_TFAI_RR_Flags
(Nod
: Node_Id
) is
451 if Treat_Fixed_As_Integer
(Nod
) then
455 if Rounded_Result
(Nod
) then
458 end Process_TFAI_RR_Flags
;
464 procedure ps
(Node
: Node_Id
) is
466 Dump_Generated_Only
:= False;
467 Dump_Original_Only
:= False;
468 Current_Source_File
:= No_Source_File
;
477 procedure Set_Debug_Sloc
is
479 if Debug_Generated_Code
and then Present
(Dump_Node
) then
480 Set_Sloc
(Dump_Node
, Debug_Sloc
+ Source_Ptr
(Column
- 1));
489 procedure Source_Dump
is
492 -- Put underline under string we just printed
498 procedure Underline
is
499 Col
: constant Int
:= Column
;
504 while Col
> Column
loop
511 -- Start of processing for Tree_Dump
514 Dump_Generated_Only
:= Debug_Flag_G
or
515 Print_Generated_Code
or
516 Debug_Generated_Code
;
517 Dump_Original_Only
:= Debug_Flag_O
;
518 Dump_Freeze_Null
:= Debug_Flag_S
or Debug_Flag_G
;
520 -- Note that we turn off the tree dump flags immediately, before
521 -- starting the dump. This avoids generating two copies of the dump
522 -- if an abort occurs after printing the dump, and more importantly,
523 -- avoids an infinite loop if an abort occurs during the dump.
526 Current_Source_File
:= No_Source_File
;
527 Debug_Flag_Z
:= False;
530 Write_Str
("Source recreated from tree of Standard (spec)");
532 Sprint_Node
(Standard_Package_Node
);
537 if Debug_Flag_S
or Dump_Generated_Only
or Dump_Original_Only
then
538 Debug_Flag_G
:= False;
539 Debug_Flag_O
:= False;
540 Debug_Flag_S
:= False;
542 -- Dump requested units
544 for U
in Main_Unit
.. Last_Unit
loop
545 Current_Source_File
:= Source_Index
(U
);
547 -- Dump all units if -gnatdf set, otherwise we dump only
548 -- the source files that are in the extended main source.
551 or else In_Extended_Main_Source_Unit
(Cunit_Entity
(U
))
553 -- If we are generating debug files, setup to write them
555 if Debug_Generated_Code
then
556 Set_Special_Output
(Print_Debug_Line
'Access);
557 Create_Debug_Source
(Source_Index
(U
), Debug_Sloc
);
558 Write_Source_Line
(1);
559 Last_Line_Printed
:= 1;
560 Sprint_Node
(Cunit
(U
));
561 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
564 Set_Special_Output
(null);
566 -- Normal output to standard output file
569 Write_Str
("Source recreated from tree for ");
570 Write_Unit_Name
(Unit_Name
(U
));
572 Write_Source_Line
(1);
573 Last_Line_Printed
:= 1;
574 Sprint_Node
(Cunit
(U
));
575 Write_Source_Lines
(Last_Source_Line
(Current_Source_File
));
584 ---------------------
585 -- Sprint_And_List --
586 ---------------------
588 procedure Sprint_And_List
(List
: List_Id
) is
591 if Is_Non_Empty_List
(List
) then
592 Node
:= First
(List
);
596 exit when Node
= Empty
;
602 ---------------------
603 -- Sprint_Bar_List --
604 ---------------------
606 procedure Sprint_Bar_List
(List
: List_Id
) is
609 if Is_Non_Empty_List
(List
) then
610 Node
:= First
(List
);
614 exit when Node
= Empty
;
620 -----------------------
621 -- Sprint_Comma_List --
622 -----------------------
624 procedure Sprint_Comma_List
(List
: List_Id
) is
628 if Is_Non_Empty_List
(List
) then
629 Node
:= First
(List
);
633 exit when Node
= Empty
;
635 if not Is_Rewrite_Insertion
(Node
)
636 or else not Dump_Original_Only
642 end Sprint_Comma_List
;
644 --------------------------
645 -- Sprint_Indented_List --
646 --------------------------
648 procedure Sprint_Indented_List
(List
: List_Id
) is
651 Sprint_Node_List
(List
);
653 end Sprint_Indented_List
;
655 ---------------------
656 -- Sprint_Left_Opnd --
657 ---------------------
659 procedure Sprint_Left_Opnd
(N
: Node_Id
) is
660 Opnd
: constant Node_Id
:= Left_Opnd
(N
);
663 if Paren_Count
(Opnd
) /= 0
664 or else Op_Prec
(Nkind
(Opnd
)) >= Op_Prec
(Nkind
(N
))
673 end Sprint_Left_Opnd
;
679 procedure Sprint_Node
(Node
: Node_Id
) is
681 if Is_Rewrite_Insertion
(Node
) then
682 if not Dump_Original_Only
then
684 -- For special cases of nodes that always output <<< >>>
685 -- do not duplicate the output at this point.
687 if Nkind
(Node
) = N_Freeze_Entity
688 or else Nkind
(Node
) = N_Implicit_Label_Declaration
690 Sprint_Node_Actual
(Node
);
692 -- Normal case where <<< >>> may be required
695 Write_Rewrite_Str
("<<<");
696 Sprint_Node_Actual
(Node
);
697 Write_Rewrite_Str
(">>>");
701 elsif Is_Rewrite_Substitution
(Node
) then
703 -- Case of dump generated only
705 if Dump_Generated_Only
then
706 Sprint_Node_Actual
(Node
);
708 -- Case of dump original only
710 elsif Dump_Original_Only
then
711 Sprint_Node_Actual
(Original_Node
(Node
));
713 -- Case of both being dumped
716 Sprint_Node_Actual
(Original_Node
(Node
));
717 Write_Rewrite_Str
("<<<");
718 Sprint_Node_Actual
(Node
);
719 Write_Rewrite_Str
(">>>");
723 Sprint_Node_Actual
(Node
);
727 ------------------------
728 -- Sprint_Node_Actual --
729 ------------------------
731 procedure Sprint_Node_Actual
(Node
: Node_Id
) is
732 Save_Dump_Node
: constant Node_Id
:= Dump_Node
;
739 for J
in 1 .. Paren_Count
(Node
) loop
740 Write_Str_With_Col_Check
("(");
743 -- Setup current dump node
747 if Nkind
(Node
) in N_Subexpr
748 and then Do_Range_Check
(Node
)
750 Write_Str_With_Col_Check
("{");
753 -- Select print circuit based on node kind
757 when N_Abort_Statement
=>
758 Write_Indent_Str_Sloc
("abort ");
759 Sprint_Comma_List
(Names
(Node
));
762 when N_Abortable_Part
=>
764 Write_Str_Sloc
("abort ");
765 Sprint_Indented_List
(Statements
(Node
));
767 when N_Abstract_Subprogram_Declaration
=>
769 Sprint_Node
(Specification
(Node
));
770 Write_Str_With_Col_Check
(" is ");
771 Write_Str_Sloc
("abstract;");
773 when N_Accept_Alternative
=>
774 Sprint_Node_List
(Pragmas_Before
(Node
));
776 if Present
(Condition
(Node
)) then
777 Write_Indent_Str
("when ");
778 Sprint_Node
(Condition
(Node
));
783 Sprint_Node_Sloc
(Accept_Statement
(Node
));
784 Sprint_Node_List
(Statements
(Node
));
786 when N_Accept_Statement
=>
787 Write_Indent_Str_Sloc
("accept ");
788 Write_Id
(Entry_Direct_Name
(Node
));
790 if Present
(Entry_Index
(Node
)) then
791 Write_Str_With_Col_Check
(" (");
792 Sprint_Node
(Entry_Index
(Node
));
796 Write_Param_Specs
(Node
);
798 if Present
(Handled_Statement_Sequence
(Node
)) then
799 Write_Str_With_Col_Check
(" do");
800 Sprint_Node
(Handled_Statement_Sequence
(Node
));
801 Write_Indent_Str
("end ");
802 Write_Id
(Entry_Direct_Name
(Node
));
807 when N_Access_Definition
=>
811 if Present
(Access_To_Subprogram_Definition
(Node
)) then
812 Sprint_Node
(Access_To_Subprogram_Definition
(Node
));
816 if Null_Exclusion_Present
(Node
) then
817 Write_Str
("not null ");
820 Write_Str_With_Col_Check_Sloc
("access ");
822 if All_Present
(Node
) then
824 elsif Constant_Present
(Node
) then
825 Write_Str
("constant ");
828 Sprint_Node
(Subtype_Mark
(Node
));
831 when N_Access_Function_Definition
=>
835 if Null_Exclusion_Present
(Node
) then
836 Write_Str
("not null ");
839 Write_Str_With_Col_Check_Sloc
("access ");
841 if Protected_Present
(Node
) then
842 Write_Str_With_Col_Check
("protected ");
845 Write_Str_With_Col_Check
("function");
846 Write_Param_Specs
(Node
);
847 Write_Str_With_Col_Check
(" return ");
848 Sprint_Node
(Result_Definition
(Node
));
850 when N_Access_Procedure_Definition
=>
854 if Null_Exclusion_Present
(Node
) then
855 Write_Str
("not null ");
858 Write_Str_With_Col_Check_Sloc
("access ");
860 if Protected_Present
(Node
) then
861 Write_Str_With_Col_Check
("protected ");
864 Write_Str_With_Col_Check
("procedure");
865 Write_Param_Specs
(Node
);
867 when N_Access_To_Object_Definition
=>
868 Write_Str_With_Col_Check_Sloc
("access ");
870 if All_Present
(Node
) then
871 Write_Str_With_Col_Check
("all ");
872 elsif Constant_Present
(Node
) then
873 Write_Str_With_Col_Check
("constant ");
878 if Null_Exclusion_Present
(Node
) then
879 Write_Str
("not null ");
882 Sprint_Node
(Subtype_Indication
(Node
));
885 if Null_Record_Present
(Node
) then
886 Write_Str_With_Col_Check_Sloc
("(null record)");
889 Write_Str_With_Col_Check_Sloc
("(");
891 if Present
(Expressions
(Node
)) then
892 Sprint_Comma_List
(Expressions
(Node
));
894 if Present
(Component_Associations
(Node
)) then
899 if Present
(Component_Associations
(Node
)) then
906 Nd
:= First
(Component_Associations
(Node
));
914 if not Is_Rewrite_Insertion
(Nd
)
915 or else not Dump_Original_Only
929 Write_Str_With_Col_Check_Sloc
("new ");
933 if Null_Exclusion_Present
(Node
) then
934 Write_Str
("not null ");
937 Sprint_Node
(Expression
(Node
));
939 if Present
(Storage_Pool
(Node
)) then
940 Write_Str_With_Col_Check
("[storage_pool = ");
941 Sprint_Node
(Storage_Pool
(Node
));
946 Sprint_Left_Opnd
(Node
);
947 Write_Str_Sloc
(" and then ");
948 Sprint_Right_Opnd
(Node
);
951 Write_Indent_Str_Sloc
("for ");
952 Write_Id
(Identifier
(Node
));
953 Write_Str_With_Col_Check
(" use at ");
954 Sprint_Node
(Expression
(Node
));
957 when N_Assignment_Statement
=>
959 Sprint_Node
(Name
(Node
));
960 Write_Str_Sloc
(" := ");
961 Sprint_Node
(Expression
(Node
));
964 when N_Asynchronous_Select
=>
965 Write_Indent_Str_Sloc
("select");
967 Sprint_Node
(Triggering_Alternative
(Node
));
970 -- Note: let the printing of Abortable_Part handle outputting
971 -- the ABORT keyword, so that the Slco can be set correctly.
973 Write_Indent_Str
("then ");
974 Sprint_Node
(Abortable_Part
(Node
));
975 Write_Indent_Str
("end select;");
977 when N_Attribute_Definition_Clause
=>
978 Write_Indent_Str_Sloc
("for ");
979 Sprint_Node
(Name
(Node
));
981 Write_Name_With_Col_Check
(Chars
(Node
));
982 Write_Str_With_Col_Check
(" use ");
983 Sprint_Node
(Expression
(Node
));
986 when N_Attribute_Reference
=>
987 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
991 Sprint_Node
(Prefix
(Node
));
992 Write_Char_Sloc
(''');
993 Write_Name_With_Col_Check
(Attribute_Name
(Node
));
994 Sprint_Paren_Comma_List
(Expressions
(Node
));
996 if Is_Procedure_Attribute_Name
(Attribute_Name
(Node
)) then
1000 when N_Block_Statement
=>
1003 if Present
(Identifier
(Node
))
1004 and then (not Has_Created_Identifier
(Node
)
1005 or else not Dump_Original_Only
)
1007 Write_Rewrite_Str
("<<<");
1008 Write_Id
(Identifier
(Node
));
1010 Write_Rewrite_Str
(">>>");
1013 if Present
(Declarations
(Node
)) then
1014 Write_Str_With_Col_Check_Sloc
("declare");
1015 Sprint_Indented_List
(Declarations
(Node
));
1019 Write_Str_With_Col_Check_Sloc
("begin");
1020 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1021 Write_Indent_Str
("end");
1023 if Present
(Identifier
(Node
))
1024 and then (not Has_Created_Identifier
(Node
)
1025 or else not Dump_Original_Only
)
1027 Write_Rewrite_Str
("<<<");
1029 Write_Id
(Identifier
(Node
));
1030 Write_Rewrite_Str
(">>>");
1035 when N_Case_Statement
=>
1036 Write_Indent_Str_Sloc
("case ");
1037 Sprint_Node
(Expression
(Node
));
1039 Sprint_Indented_List
(Alternatives
(Node
));
1040 Write_Indent_Str
("end case;");
1042 when N_Case_Statement_Alternative
=>
1043 Write_Indent_Str_Sloc
("when ");
1044 Sprint_Bar_List
(Discrete_Choices
(Node
));
1046 Sprint_Indented_List
(Statements
(Node
));
1048 when N_Character_Literal
=>
1050 Write_Indent_Str
(" ");
1053 Write_Char_Sloc
(''');
1054 Write_Char_Code
(UI_To_CC
(Char_Literal_Value
(Node
)));
1057 when N_Code_Statement
=>
1060 Sprint_Node
(Expression
(Node
));
1063 when N_Compilation_Unit
=>
1064 Sprint_Node_List
(Context_Items
(Node
));
1065 Sprint_Opt_Node_List
(Declarations
(Aux_Decls_Node
(Node
)));
1067 if Private_Present
(Node
) then
1068 Write_Indent_Str
("private ");
1072 Sprint_Node_Sloc
(Unit
(Node
));
1074 if Present
(Actions
(Aux_Decls_Node
(Node
)))
1076 Present
(Pragmas_After
(Aux_Decls_Node
(Node
)))
1081 Sprint_Opt_Node_List
(Actions
(Aux_Decls_Node
(Node
)));
1082 Sprint_Opt_Node_List
(Pragmas_After
(Aux_Decls_Node
(Node
)));
1084 when N_Compilation_Unit_Aux
=>
1085 null; -- nothing to do, never used, see above
1087 when N_Component_Association
=>
1089 Sprint_Bar_List
(Choices
(Node
));
1092 -- Ada 2005 (AI-287): Print the box if present
1094 if Box_Present
(Node
) then
1095 Write_Str_With_Col_Check
("<>");
1097 Sprint_Node
(Expression
(Node
));
1100 when N_Component_Clause
=>
1102 Sprint_Node
(Component_Name
(Node
));
1103 Write_Str_Sloc
(" at ");
1104 Sprint_Node
(Position
(Node
));
1106 Write_Str_With_Col_Check
("range ");
1107 Sprint_Node
(First_Bit
(Node
));
1109 Sprint_Node
(Last_Bit
(Node
));
1112 when N_Component_Definition
=>
1115 -- Ada 2005 (AI-230): Access definition components
1117 if Present
(Access_Definition
(Node
)) then
1118 Sprint_Node
(Access_Definition
(Node
));
1120 elsif Present
(Subtype_Indication
(Node
)) then
1121 if Aliased_Present
(Node
) then
1122 Write_Str_With_Col_Check
("aliased ");
1125 -- Ada 2005 (AI-231)
1127 if Null_Exclusion_Present
(Node
) then
1128 Write_Str
(" not null ");
1131 Sprint_Node
(Subtype_Indication
(Node
));
1134 Write_Str
(" ??? ");
1137 when N_Component_Declaration
=>
1138 if Write_Indent_Identifiers_Sloc
(Node
) then
1140 Sprint_Node
(Component_Definition
(Node
));
1142 if Present
(Expression
(Node
)) then
1144 Sprint_Node
(Expression
(Node
));
1150 when N_Component_List
=>
1151 if Null_Present
(Node
) then
1153 Write_Indent_Str_Sloc
("null");
1159 Sprint_Indented_List
(Component_Items
(Node
));
1160 Sprint_Node
(Variant_Part
(Node
));
1163 when N_Conditional_Entry_Call
=>
1164 Write_Indent_Str_Sloc
("select");
1166 Sprint_Node
(Entry_Call_Alternative
(Node
));
1168 Write_Indent_Str
("else");
1169 Sprint_Indented_List
(Else_Statements
(Node
));
1170 Write_Indent_Str
("end select;");
1172 when N_Conditional_Expression
=>
1174 Condition
: constant Node_Id
:= First
(Expressions
(Node
));
1175 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1176 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1178 Write_Str_With_Col_Check_Sloc
("(if ");
1179 Sprint_Node
(Condition
);
1180 Write_Str_With_Col_Check
(" then ");
1181 Sprint_Node
(Then_Expr
);
1182 Write_Str_With_Col_Check
(" else ");
1183 Sprint_Node
(Else_Expr
);
1187 when N_Constrained_Array_Definition
=>
1188 Write_Str_With_Col_Check_Sloc
("array ");
1189 Sprint_Paren_Comma_List
(Discrete_Subtype_Definitions
(Node
));
1192 Sprint_Node
(Component_Definition
(Node
));
1194 when N_Decimal_Fixed_Point_Definition
=>
1195 Write_Str_With_Col_Check_Sloc
(" delta ");
1196 Sprint_Node
(Delta_Expression
(Node
));
1197 Write_Str_With_Col_Check
("digits ");
1198 Sprint_Node
(Digits_Expression
(Node
));
1199 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1201 when N_Defining_Character_Literal
=>
1202 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1204 when N_Defining_Identifier
=>
1208 when N_Defining_Operator_Symbol
=>
1209 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
1211 when N_Defining_Program_Unit_Name
=>
1213 Sprint_Node
(Name
(Node
));
1215 Write_Id
(Defining_Identifier
(Node
));
1217 when N_Delay_Alternative
=>
1218 Sprint_Node_List
(Pragmas_Before
(Node
));
1220 if Present
(Condition
(Node
)) then
1222 Write_Str_With_Col_Check
("when ");
1223 Sprint_Node
(Condition
(Node
));
1228 Sprint_Node_Sloc
(Delay_Statement
(Node
));
1229 Sprint_Node_List
(Statements
(Node
));
1231 when N_Delay_Relative_Statement
=>
1232 Write_Indent_Str_Sloc
("delay ");
1233 Sprint_Node
(Expression
(Node
));
1236 when N_Delay_Until_Statement
=>
1237 Write_Indent_Str_Sloc
("delay until ");
1238 Sprint_Node
(Expression
(Node
));
1241 when N_Delta_Constraint
=>
1242 Write_Str_With_Col_Check_Sloc
("delta ");
1243 Sprint_Node
(Delta_Expression
(Node
));
1244 Sprint_Opt_Node
(Range_Constraint
(Node
));
1246 when N_Derived_Type_Definition
=>
1247 if Abstract_Present
(Node
) then
1248 Write_Str_With_Col_Check
("abstract ");
1251 Write_Str_With_Col_Check_Sloc
("new ");
1253 -- Ada 2005 (AI-231)
1255 if Null_Exclusion_Present
(Node
) then
1256 Write_Str_With_Col_Check
("not null ");
1259 Sprint_Node
(Subtype_Indication
(Node
));
1261 if Present
(Interface_List
(Node
)) then
1262 Sprint_And_List
(Interface_List
(Node
));
1263 Write_Str_With_Col_Check
(" with ");
1266 if Present
(Record_Extension_Part
(Node
)) then
1267 if No
(Interface_List
(Node
)) then
1268 Write_Str_With_Col_Check
(" with ");
1271 Sprint_Node
(Record_Extension_Part
(Node
));
1274 when N_Designator
=>
1275 Sprint_Node
(Name
(Node
));
1276 Write_Char_Sloc
('.');
1277 Write_Id
(Identifier
(Node
));
1279 when N_Digits_Constraint
=>
1280 Write_Str_With_Col_Check_Sloc
("digits ");
1281 Sprint_Node
(Digits_Expression
(Node
));
1282 Sprint_Opt_Node
(Range_Constraint
(Node
));
1284 when N_Discriminant_Association
=>
1287 if Present
(Selector_Names
(Node
)) then
1288 Sprint_Bar_List
(Selector_Names
(Node
));
1293 Sprint_Node
(Expression
(Node
));
1295 when N_Discriminant_Specification
=>
1298 if Write_Identifiers
(Node
) then
1301 if Null_Exclusion_Present
(Node
) then
1302 Write_Str
("not null ");
1305 Sprint_Node
(Discriminant_Type
(Node
));
1307 if Present
(Expression
(Node
)) then
1309 Sprint_Node
(Expression
(Node
));
1315 when N_Elsif_Part
=>
1316 Write_Indent_Str_Sloc
("elsif ");
1317 Sprint_Node
(Condition
(Node
));
1318 Write_Str_With_Col_Check
(" then");
1319 Sprint_Indented_List
(Then_Statements
(Node
));
1324 when N_Entry_Body
=>
1325 Write_Indent_Str_Sloc
("entry ");
1326 Write_Id
(Defining_Identifier
(Node
));
1327 Sprint_Node
(Entry_Body_Formal_Part
(Node
));
1328 Write_Str_With_Col_Check
(" is");
1329 Sprint_Indented_List
(Declarations
(Node
));
1330 Write_Indent_Str
("begin");
1331 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1332 Write_Indent_Str
("end ");
1333 Write_Id
(Defining_Identifier
(Node
));
1336 when N_Entry_Body_Formal_Part
=>
1337 if Present
(Entry_Index_Specification
(Node
)) then
1338 Write_Str_With_Col_Check_Sloc
(" (");
1339 Sprint_Node
(Entry_Index_Specification
(Node
));
1343 Write_Param_Specs
(Node
);
1344 Write_Str_With_Col_Check_Sloc
(" when ");
1345 Sprint_Node
(Condition
(Node
));
1347 when N_Entry_Call_Alternative
=>
1348 Sprint_Node_List
(Pragmas_Before
(Node
));
1349 Sprint_Node_Sloc
(Entry_Call_Statement
(Node
));
1350 Sprint_Node_List
(Statements
(Node
));
1352 when N_Entry_Call_Statement
=>
1354 Sprint_Node_Sloc
(Name
(Node
));
1355 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
1358 when N_Entry_Declaration
=>
1359 Write_Indent_Str_Sloc
("entry ");
1360 Write_Id
(Defining_Identifier
(Node
));
1362 if Present
(Discrete_Subtype_Definition
(Node
)) then
1363 Write_Str_With_Col_Check
(" (");
1364 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1368 Write_Param_Specs
(Node
);
1371 when N_Entry_Index_Specification
=>
1372 Write_Str_With_Col_Check_Sloc
("for ");
1373 Write_Id
(Defining_Identifier
(Node
));
1374 Write_Str_With_Col_Check
(" in ");
1375 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1377 when N_Enumeration_Representation_Clause
=>
1378 Write_Indent_Str_Sloc
("for ");
1379 Write_Id
(Identifier
(Node
));
1380 Write_Str_With_Col_Check
(" use ");
1381 Sprint_Node
(Array_Aggregate
(Node
));
1384 when N_Enumeration_Type_Definition
=>
1387 -- Skip attempt to print Literals field if it's not there and
1388 -- we are in package Standard (case of Character, which is
1389 -- handled specially (without an explicit literals list).
1391 if Sloc
(Node
) > Standard_Location
1392 or else Present
(Literals
(Node
))
1394 Sprint_Paren_Comma_List
(Literals
(Node
));
1398 Write_Str_With_Col_Check_Sloc
("<error>");
1400 when N_Exception_Declaration
=>
1401 if Write_Indent_Identifiers
(Node
) then
1402 Write_Str_With_Col_Check
(" : ");
1403 Write_Str_Sloc
("exception;");
1406 when N_Exception_Handler
=>
1407 Write_Indent_Str_Sloc
("when ");
1409 if Present
(Choice_Parameter
(Node
)) then
1410 Sprint_Node
(Choice_Parameter
(Node
));
1414 Sprint_Bar_List
(Exception_Choices
(Node
));
1416 Sprint_Indented_List
(Statements
(Node
));
1418 when N_Exception_Renaming_Declaration
=>
1421 Sprint_Node
(Defining_Identifier
(Node
));
1422 Write_Str_With_Col_Check
(" : exception renames ");
1423 Sprint_Node
(Name
(Node
));
1426 when N_Exit_Statement
=>
1427 Write_Indent_Str_Sloc
("exit");
1428 Sprint_Opt_Node
(Name
(Node
));
1430 if Present
(Condition
(Node
)) then
1431 Write_Str_With_Col_Check
(" when ");
1432 Sprint_Node
(Condition
(Node
));
1437 when N_Expanded_Name
=>
1438 Sprint_Node
(Prefix
(Node
));
1439 Write_Char_Sloc
('.');
1440 Sprint_Node
(Selector_Name
(Node
));
1442 when N_Explicit_Dereference
=>
1443 Sprint_Node
(Prefix
(Node
));
1444 Write_Char_Sloc
('.');
1445 Write_Str_Sloc
("all");
1447 when N_Extended_Return_Statement
=>
1448 Write_Indent_Str_Sloc
("return ");
1449 Sprint_Node_List
(Return_Object_Declarations
(Node
));
1451 if Present
(Handled_Statement_Sequence
(Node
)) then
1452 Write_Str_With_Col_Check
(" do");
1453 Sprint_Node
(Handled_Statement_Sequence
(Node
));
1454 Write_Indent_Str
("end return;");
1456 Write_Indent_Str
(";");
1459 when N_Extension_Aggregate
=>
1460 Write_Str_With_Col_Check_Sloc
("(");
1461 Sprint_Node
(Ancestor_Part
(Node
));
1462 Write_Str_With_Col_Check
(" with ");
1464 if Null_Record_Present
(Node
) then
1465 Write_Str_With_Col_Check
("null record");
1467 if Present
(Expressions
(Node
)) then
1468 Sprint_Comma_List
(Expressions
(Node
));
1470 if Present
(Component_Associations
(Node
)) then
1475 if Present
(Component_Associations
(Node
)) then
1476 Sprint_Comma_List
(Component_Associations
(Node
));
1482 when N_Floating_Point_Definition
=>
1483 Write_Str_With_Col_Check_Sloc
("digits ");
1484 Sprint_Node
(Digits_Expression
(Node
));
1485 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
1487 when N_Formal_Decimal_Fixed_Point_Definition
=>
1488 Write_Str_With_Col_Check_Sloc
("delta <> digits <>");
1490 when N_Formal_Derived_Type_Definition
=>
1491 Write_Str_With_Col_Check_Sloc
("new ");
1492 Sprint_Node
(Subtype_Mark
(Node
));
1494 if Private_Present
(Node
) then
1495 Write_Str_With_Col_Check
(" with private");
1498 when N_Formal_Abstract_Subprogram_Declaration
=>
1499 Write_Indent_Str_Sloc
("with ");
1500 Sprint_Node
(Specification
(Node
));
1502 Write_Str_With_Col_Check
(" is abstract");
1504 if Box_Present
(Node
) then
1505 Write_Str_With_Col_Check
(" <>");
1506 elsif Present
(Default_Name
(Node
)) then
1507 Write_Str_With_Col_Check
(" ");
1508 Sprint_Node
(Default_Name
(Node
));
1513 when N_Formal_Concrete_Subprogram_Declaration
=>
1514 Write_Indent_Str_Sloc
("with ");
1515 Sprint_Node
(Specification
(Node
));
1517 if Box_Present
(Node
) then
1518 Write_Str_With_Col_Check
(" is <>");
1519 elsif Present
(Default_Name
(Node
)) then
1520 Write_Str_With_Col_Check
(" is ");
1521 Sprint_Node
(Default_Name
(Node
));
1526 when N_Formal_Discrete_Type_Definition
=>
1527 Write_Str_With_Col_Check_Sloc
("<>");
1529 when N_Formal_Floating_Point_Definition
=>
1530 Write_Str_With_Col_Check_Sloc
("digits <>");
1532 when N_Formal_Modular_Type_Definition
=>
1533 Write_Str_With_Col_Check_Sloc
("mod <>");
1535 when N_Formal_Object_Declaration
=>
1538 if Write_Indent_Identifiers
(Node
) then
1541 if In_Present
(Node
) then
1542 Write_Str_With_Col_Check
("in ");
1545 if Out_Present
(Node
) then
1546 Write_Str_With_Col_Check
("out ");
1549 if Present
(Subtype_Mark
(Node
)) then
1551 -- Ada 2005 (AI-423): Formal object with null exclusion
1553 if Null_Exclusion_Present
(Node
) then
1554 Write_Str
("not null ");
1557 Sprint_Node
(Subtype_Mark
(Node
));
1559 -- Ada 2005 (AI-423): Formal object with access definition
1562 pragma Assert
(Present
(Access_Definition
(Node
)));
1564 Sprint_Node
(Access_Definition
(Node
));
1567 if Present
(Default_Expression
(Node
)) then
1569 Sprint_Node
(Default_Expression
(Node
));
1575 when N_Formal_Ordinary_Fixed_Point_Definition
=>
1576 Write_Str_With_Col_Check_Sloc
("delta <>");
1578 when N_Formal_Package_Declaration
=>
1579 Write_Indent_Str_Sloc
("with package ");
1580 Write_Id
(Defining_Identifier
(Node
));
1581 Write_Str_With_Col_Check
(" is new ");
1582 Sprint_Node
(Name
(Node
));
1583 Write_Str_With_Col_Check
(" (<>);");
1585 when N_Formal_Private_Type_Definition
=>
1586 if Abstract_Present
(Node
) then
1587 Write_Str_With_Col_Check
("abstract ");
1590 if Tagged_Present
(Node
) then
1591 Write_Str_With_Col_Check
("tagged ");
1594 if Limited_Present
(Node
) then
1595 Write_Str_With_Col_Check
("limited ");
1598 Write_Str_With_Col_Check_Sloc
("private");
1600 when N_Formal_Signed_Integer_Type_Definition
=>
1601 Write_Str_With_Col_Check_Sloc
("range <>");
1603 when N_Formal_Type_Declaration
=>
1604 Write_Indent_Str_Sloc
("type ");
1605 Write_Id
(Defining_Identifier
(Node
));
1607 if Present
(Discriminant_Specifications
(Node
)) then
1608 Write_Discr_Specs
(Node
);
1609 elsif Unknown_Discriminants_Present
(Node
) then
1610 Write_Str_With_Col_Check
("(<>)");
1613 Write_Str_With_Col_Check
(" is ");
1614 Sprint_Node
(Formal_Type_Definition
(Node
));
1617 when N_Free_Statement
=>
1618 Write_Indent_Str_Sloc
("free ");
1619 Sprint_Node
(Expression
(Node
));
1622 when N_Freeze_Entity
=>
1623 if Dump_Original_Only
then
1626 elsif Present
(Actions
(Node
)) or else Dump_Freeze_Null
then
1628 Write_Rewrite_Str
("<<<");
1629 Write_Str_With_Col_Check_Sloc
("freeze ");
1630 Write_Id
(Entity
(Node
));
1633 if No
(Actions
(Node
)) then
1637 -- Output freeze actions. We increment Freeze_Indent during
1638 -- this output to avoid generating extra blank lines before
1639 -- any procedures included in the freeze actions.
1641 Freeze_Indent
:= Freeze_Indent
+ 1;
1642 Sprint_Indented_List
(Actions
(Node
));
1643 Freeze_Indent
:= Freeze_Indent
- 1;
1644 Write_Indent_Str
("]");
1647 Write_Rewrite_Str
(">>>");
1650 when N_Full_Type_Declaration
=>
1651 Write_Indent_Str_Sloc
("type ");
1652 Write_Id
(Defining_Identifier
(Node
));
1653 Write_Discr_Specs
(Node
);
1654 Write_Str_With_Col_Check
(" is ");
1655 Sprint_Node
(Type_Definition
(Node
));
1658 when N_Function_Call
=>
1660 Note_Implicit_Run_Time_Call
(Name
(Node
));
1661 Sprint_Node
(Name
(Node
));
1662 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
1664 when N_Function_Instantiation
=>
1665 Write_Indent_Str_Sloc
("function ");
1666 Sprint_Node
(Defining_Unit_Name
(Node
));
1667 Write_Str_With_Col_Check
(" is new ");
1668 Sprint_Node
(Name
(Node
));
1669 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
1672 when N_Function_Specification
=>
1673 Write_Str_With_Col_Check_Sloc
("function ");
1674 Sprint_Node
(Defining_Unit_Name
(Node
));
1675 Write_Param_Specs
(Node
);
1676 Write_Str_With_Col_Check
(" return ");
1678 -- Ada 2005 (AI-231)
1680 if Nkind
(Result_Definition
(Node
)) /= N_Access_Definition
1681 and then Null_Exclusion_Present
(Node
)
1683 Write_Str
(" not null ");
1686 Sprint_Node
(Result_Definition
(Node
));
1688 when N_Generic_Association
=>
1691 if Present
(Selector_Name
(Node
)) then
1692 Sprint_Node
(Selector_Name
(Node
));
1696 Sprint_Node
(Explicit_Generic_Actual_Parameter
(Node
));
1698 when N_Generic_Function_Renaming_Declaration
=>
1699 Write_Indent_Str_Sloc
("generic function ");
1700 Sprint_Node
(Defining_Unit_Name
(Node
));
1701 Write_Str_With_Col_Check
(" renames ");
1702 Sprint_Node
(Name
(Node
));
1705 when N_Generic_Package_Declaration
=>
1707 Write_Indent_Str_Sloc
("generic ");
1708 Sprint_Indented_List
(Generic_Formal_Declarations
(Node
));
1710 Sprint_Node
(Specification
(Node
));
1713 when N_Generic_Package_Renaming_Declaration
=>
1714 Write_Indent_Str_Sloc
("generic package ");
1715 Sprint_Node
(Defining_Unit_Name
(Node
));
1716 Write_Str_With_Col_Check
(" renames ");
1717 Sprint_Node
(Name
(Node
));
1720 when N_Generic_Procedure_Renaming_Declaration
=>
1721 Write_Indent_Str_Sloc
("generic procedure ");
1722 Sprint_Node
(Defining_Unit_Name
(Node
));
1723 Write_Str_With_Col_Check
(" renames ");
1724 Sprint_Node
(Name
(Node
));
1727 when N_Generic_Subprogram_Declaration
=>
1729 Write_Indent_Str_Sloc
("generic ");
1730 Sprint_Indented_List
(Generic_Formal_Declarations
(Node
));
1732 Sprint_Node
(Specification
(Node
));
1735 when N_Goto_Statement
=>
1736 Write_Indent_Str_Sloc
("goto ");
1737 Sprint_Node
(Name
(Node
));
1740 if Nkind
(Next
(Node
)) = N_Label
then
1744 when N_Handled_Sequence_Of_Statements
=>
1746 Sprint_Indented_List
(Statements
(Node
));
1748 if Present
(Exception_Handlers
(Node
)) then
1749 Write_Indent_Str
("exception");
1751 Sprint_Node_List
(Exception_Handlers
(Node
));
1755 if Present
(At_End_Proc
(Node
)) then
1756 Write_Indent_Str
("at end");
1759 Sprint_Node
(At_End_Proc
(Node
));
1764 when N_Identifier
=>
1768 when N_If_Statement
=>
1769 Write_Indent_Str_Sloc
("if ");
1770 Sprint_Node
(Condition
(Node
));
1771 Write_Str_With_Col_Check
(" then");
1772 Sprint_Indented_List
(Then_Statements
(Node
));
1773 Sprint_Opt_Node_List
(Elsif_Parts
(Node
));
1775 if Present
(Else_Statements
(Node
)) then
1776 Write_Indent_Str
("else");
1777 Sprint_Indented_List
(Else_Statements
(Node
));
1780 Write_Indent_Str
("end if;");
1782 when N_Implicit_Label_Declaration
=>
1783 if not Dump_Original_Only
then
1785 Write_Rewrite_Str
("<<<");
1787 Write_Id
(Defining_Identifier
(Node
));
1789 Write_Str_With_Col_Check
("label");
1790 Write_Rewrite_Str
(">>>");
1794 Sprint_Left_Opnd
(Node
);
1795 Write_Str_Sloc
(" in ");
1796 Sprint_Right_Opnd
(Node
);
1798 when N_Incomplete_Type_Declaration
=>
1799 Write_Indent_Str_Sloc
("type ");
1800 Write_Id
(Defining_Identifier
(Node
));
1802 if Present
(Discriminant_Specifications
(Node
)) then
1803 Write_Discr_Specs
(Node
);
1804 elsif Unknown_Discriminants_Present
(Node
) then
1805 Write_Str_With_Col_Check
("(<>)");
1810 when N_Index_Or_Discriminant_Constraint
=>
1812 Sprint_Paren_Comma_List
(Constraints
(Node
));
1814 when N_Indexed_Component
=>
1815 Sprint_Node_Sloc
(Prefix
(Node
));
1816 Sprint_Opt_Paren_Comma_List
(Expressions
(Node
));
1818 when N_Integer_Literal
=>
1819 if Print_In_Hex
(Node
) then
1820 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Hex
);
1822 Write_Uint_With_Col_Check_Sloc
(Intval
(Node
), Auto
);
1825 when N_Iteration_Scheme
=>
1826 if Present
(Condition
(Node
)) then
1827 Write_Str_With_Col_Check_Sloc
("while ");
1828 Sprint_Node
(Condition
(Node
));
1830 Write_Str_With_Col_Check_Sloc
("for ");
1831 Sprint_Node
(Loop_Parameter_Specification
(Node
));
1836 when N_Itype_Reference
=>
1837 Write_Indent_Str_Sloc
("reference ");
1838 Write_Id
(Itype
(Node
));
1841 Write_Indent_Str_Sloc
("<<");
1842 Write_Id
(Identifier
(Node
));
1845 when N_Loop_Parameter_Specification
=>
1847 Write_Id
(Defining_Identifier
(Node
));
1848 Write_Str_With_Col_Check
(" in ");
1850 if Reverse_Present
(Node
) then
1851 Write_Str_With_Col_Check
("reverse ");
1854 Sprint_Node
(Discrete_Subtype_Definition
(Node
));
1856 when N_Loop_Statement
=>
1859 if Present
(Identifier
(Node
))
1860 and then (not Has_Created_Identifier
(Node
)
1861 or else not Dump_Original_Only
)
1863 Write_Rewrite_Str
("<<<");
1864 Write_Id
(Identifier
(Node
));
1866 Write_Rewrite_Str
(">>>");
1867 Sprint_Node
(Iteration_Scheme
(Node
));
1868 Write_Str_With_Col_Check_Sloc
("loop");
1869 Sprint_Indented_List
(Statements
(Node
));
1870 Write_Indent_Str
("end loop ");
1871 Write_Rewrite_Str
("<<<");
1872 Write_Id
(Identifier
(Node
));
1873 Write_Rewrite_Str
(">>>");
1877 Sprint_Node
(Iteration_Scheme
(Node
));
1878 Write_Str_With_Col_Check_Sloc
("loop");
1879 Sprint_Indented_List
(Statements
(Node
));
1880 Write_Indent_Str
("end loop;");
1883 when N_Mod_Clause
=>
1884 Sprint_Node_List
(Pragmas_Before
(Node
));
1885 Write_Str_With_Col_Check_Sloc
("at mod ");
1886 Sprint_Node
(Expression
(Node
));
1888 when N_Modular_Type_Definition
=>
1889 Write_Str_With_Col_Check_Sloc
("mod ");
1890 Sprint_Node
(Expression
(Node
));
1893 Sprint_Left_Opnd
(Node
);
1894 Write_Str_Sloc
(" not in ");
1895 Sprint_Right_Opnd
(Node
);
1898 Write_Str_With_Col_Check_Sloc
("null");
1900 when N_Null_Statement
=>
1901 if Comes_From_Source
(Node
)
1902 or else Dump_Freeze_Null
1903 or else not Is_List_Member
(Node
)
1904 or else (No
(Prev
(Node
)) and then No
(Next
(Node
)))
1906 Write_Indent_Str_Sloc
("null;");
1909 when N_Number_Declaration
=>
1912 if Write_Indent_Identifiers
(Node
) then
1913 Write_Str_With_Col_Check
(" : constant ");
1915 Sprint_Node
(Expression
(Node
));
1919 when N_Object_Declaration
=>
1922 if Write_Indent_Identifiers
(Node
) then
1925 if Aliased_Present
(Node
) then
1926 Write_Str_With_Col_Check
("aliased ");
1929 if Constant_Present
(Node
) then
1930 Write_Str_With_Col_Check
("constant ");
1933 -- Ada 2005 (AI-231)
1935 if Null_Exclusion_Present
(Node
) then
1936 Write_Str_With_Col_Check
("not null ");
1939 Sprint_Node
(Object_Definition
(Node
));
1941 if Present
(Expression
(Node
)) then
1943 Sprint_Node
(Expression
(Node
));
1949 when N_Object_Renaming_Declaration
=>
1952 Sprint_Node
(Defining_Identifier
(Node
));
1955 -- Ada 2005 (AI-230): Access renamings
1957 if Present
(Access_Definition
(Node
)) then
1958 Sprint_Node
(Access_Definition
(Node
));
1960 elsif Present
(Subtype_Mark
(Node
)) then
1962 -- Ada 2005 (AI-423): Object renaming with a null exclusion
1964 if Null_Exclusion_Present
(Node
) then
1965 Write_Str
("not null ");
1968 Sprint_Node
(Subtype_Mark
(Node
));
1971 Write_Str
(" ??? ");
1974 Write_Str_With_Col_Check
(" renames ");
1975 Sprint_Node
(Name
(Node
));
1979 Write_Operator
(Node
, "abs ");
1980 Sprint_Right_Opnd
(Node
);
1983 Sprint_Left_Opnd
(Node
);
1984 Write_Operator
(Node
, " + ");
1985 Sprint_Right_Opnd
(Node
);
1988 Sprint_Left_Opnd
(Node
);
1989 Write_Operator
(Node
, " and ");
1990 Sprint_Right_Opnd
(Node
);
1993 Sprint_Left_Opnd
(Node
);
1994 Write_Operator
(Node
, " & ");
1995 Sprint_Right_Opnd
(Node
);
1998 Sprint_Left_Opnd
(Node
);
2000 Process_TFAI_RR_Flags
(Node
);
2001 Write_Operator
(Node
, "/ ");
2002 Sprint_Right_Opnd
(Node
);
2005 Sprint_Left_Opnd
(Node
);
2006 Write_Operator
(Node
, " = ");
2007 Sprint_Right_Opnd
(Node
);
2010 Sprint_Left_Opnd
(Node
);
2011 Write_Operator
(Node
, " ** ");
2012 Sprint_Right_Opnd
(Node
);
2015 Sprint_Left_Opnd
(Node
);
2016 Write_Operator
(Node
, " >= ");
2017 Sprint_Right_Opnd
(Node
);
2020 Sprint_Left_Opnd
(Node
);
2021 Write_Operator
(Node
, " > ");
2022 Sprint_Right_Opnd
(Node
);
2025 Sprint_Left_Opnd
(Node
);
2026 Write_Operator
(Node
, " <= ");
2027 Sprint_Right_Opnd
(Node
);
2030 Sprint_Left_Opnd
(Node
);
2031 Write_Operator
(Node
, " < ");
2032 Sprint_Right_Opnd
(Node
);
2035 Write_Operator
(Node
, "-");
2036 Sprint_Right_Opnd
(Node
);
2039 Sprint_Left_Opnd
(Node
);
2041 if Treat_Fixed_As_Integer
(Node
) then
2045 Write_Operator
(Node
, " mod ");
2046 Sprint_Right_Opnd
(Node
);
2048 when N_Op_Multiply
=>
2049 Sprint_Left_Opnd
(Node
);
2051 Process_TFAI_RR_Flags
(Node
);
2052 Write_Operator
(Node
, "* ");
2053 Sprint_Right_Opnd
(Node
);
2056 Sprint_Left_Opnd
(Node
);
2057 Write_Operator
(Node
, " /= ");
2058 Sprint_Right_Opnd
(Node
);
2061 Write_Operator
(Node
, "not ");
2062 Sprint_Right_Opnd
(Node
);
2065 Sprint_Left_Opnd
(Node
);
2066 Write_Operator
(Node
, " or ");
2067 Sprint_Right_Opnd
(Node
);
2070 Write_Operator
(Node
, "+");
2071 Sprint_Right_Opnd
(Node
);
2074 Sprint_Left_Opnd
(Node
);
2076 if Treat_Fixed_As_Integer
(Node
) then
2080 Write_Operator
(Node
, " rem ");
2081 Sprint_Right_Opnd
(Node
);
2087 Write_Str_With_Col_Check
("(");
2088 Sprint_Node
(Left_Opnd
(Node
));
2090 Sprint_Node
(Right_Opnd
(Node
));
2093 when N_Op_Subtract
=>
2094 Sprint_Left_Opnd
(Node
);
2095 Write_Operator
(Node
, " - ");
2096 Sprint_Right_Opnd
(Node
);
2099 Sprint_Left_Opnd
(Node
);
2100 Write_Operator
(Node
, " xor ");
2101 Sprint_Right_Opnd
(Node
);
2103 when N_Operator_Symbol
=>
2104 Write_Name_With_Col_Check_Sloc
(Chars
(Node
));
2106 when N_Ordinary_Fixed_Point_Definition
=>
2107 Write_Str_With_Col_Check_Sloc
("delta ");
2108 Sprint_Node
(Delta_Expression
(Node
));
2109 Sprint_Opt_Node
(Real_Range_Specification
(Node
));
2112 Sprint_Left_Opnd
(Node
);
2113 Write_Str_Sloc
(" or else ");
2114 Sprint_Right_Opnd
(Node
);
2116 when N_Others_Choice
=>
2117 if All_Others
(Node
) then
2118 Write_Str_With_Col_Check
("all ");
2121 Write_Str_With_Col_Check_Sloc
("others");
2123 when N_Package_Body
=>
2125 Write_Indent_Str_Sloc
("package body ");
2126 Sprint_Node
(Defining_Unit_Name
(Node
));
2128 Sprint_Indented_List
(Declarations
(Node
));
2130 if Present
(Handled_Statement_Sequence
(Node
)) then
2131 Write_Indent_Str
("begin");
2132 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2135 Write_Indent_Str
("end ");
2136 Sprint_Node
(Defining_Unit_Name
(Node
));
2139 when N_Package_Body_Stub
=>
2140 Write_Indent_Str_Sloc
("package body ");
2141 Sprint_Node
(Defining_Identifier
(Node
));
2142 Write_Str_With_Col_Check
(" is separate;");
2144 when N_Package_Declaration
=>
2147 Sprint_Node_Sloc
(Specification
(Node
));
2150 when N_Package_Instantiation
=>
2152 Write_Indent_Str_Sloc
("package ");
2153 Sprint_Node
(Defining_Unit_Name
(Node
));
2154 Write_Str
(" is new ");
2155 Sprint_Node
(Name
(Node
));
2156 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2159 when N_Package_Renaming_Declaration
=>
2160 Write_Indent_Str_Sloc
("package ");
2161 Sprint_Node
(Defining_Unit_Name
(Node
));
2162 Write_Str_With_Col_Check
(" renames ");
2163 Sprint_Node
(Name
(Node
));
2166 when N_Package_Specification
=>
2167 Write_Str_With_Col_Check_Sloc
("package ");
2168 Sprint_Node
(Defining_Unit_Name
(Node
));
2170 Sprint_Indented_List
(Visible_Declarations
(Node
));
2172 if Present
(Private_Declarations
(Node
)) then
2173 Write_Indent_Str
("private");
2174 Sprint_Indented_List
(Private_Declarations
(Node
));
2177 Write_Indent_Str
("end ");
2178 Sprint_Node
(Defining_Unit_Name
(Node
));
2180 when N_Parameter_Association
=>
2181 Sprint_Node_Sloc
(Selector_Name
(Node
));
2183 Sprint_Node
(Explicit_Actual_Parameter
(Node
));
2185 when N_Parameter_Specification
=>
2188 if Write_Identifiers
(Node
) then
2191 if In_Present
(Node
) then
2192 Write_Str_With_Col_Check
("in ");
2195 if Out_Present
(Node
) then
2196 Write_Str_With_Col_Check
("out ");
2199 -- Ada 2005 (AI-231) parameter specification may carry
2200 -- null exclusion. Do not print it now if this is an
2201 -- access parameter, it is emitted when the access
2202 -- definition is displayed.
2204 if Null_Exclusion_Present
(Node
)
2205 and then Nkind
(Parameter_Type
(Node
))
2206 /= N_Access_Definition
2208 Write_Str
("not null ");
2211 Sprint_Node
(Parameter_Type
(Node
));
2213 if Present
(Expression
(Node
)) then
2215 Sprint_Node
(Expression
(Node
));
2222 Write_Indent_Str_Sloc
("pragma ");
2223 Write_Name_With_Col_Check
(Chars
(Node
));
2225 if Present
(Pragma_Argument_Associations
(Node
)) then
2226 Sprint_Opt_Paren_Comma_List
2227 (Pragma_Argument_Associations
(Node
));
2232 when N_Pragma_Argument_Association
=>
2235 if Chars
(Node
) /= No_Name
then
2236 Write_Name_With_Col_Check
(Chars
(Node
));
2240 Sprint_Node
(Expression
(Node
));
2242 when N_Private_Type_Declaration
=>
2243 Write_Indent_Str_Sloc
("type ");
2244 Write_Id
(Defining_Identifier
(Node
));
2246 if Present
(Discriminant_Specifications
(Node
)) then
2247 Write_Discr_Specs
(Node
);
2248 elsif Unknown_Discriminants_Present
(Node
) then
2249 Write_Str_With_Col_Check
("(<>)");
2254 if Tagged_Present
(Node
) then
2255 Write_Str_With_Col_Check
("tagged ");
2258 if Limited_Present
(Node
) then
2259 Write_Str_With_Col_Check
("limited ");
2262 Write_Str_With_Col_Check
("private;");
2264 when N_Private_Extension_Declaration
=>
2265 Write_Indent_Str_Sloc
("type ");
2266 Write_Id
(Defining_Identifier
(Node
));
2268 if Present
(Discriminant_Specifications
(Node
)) then
2269 Write_Discr_Specs
(Node
);
2270 elsif Unknown_Discriminants_Present
(Node
) then
2271 Write_Str_With_Col_Check
("(<>)");
2274 Write_Str_With_Col_Check
(" is new ");
2275 Sprint_Node
(Subtype_Indication
(Node
));
2276 Write_Str_With_Col_Check
(" with private;");
2278 when N_Procedure_Call_Statement
=>
2281 Note_Implicit_Run_Time_Call
(Name
(Node
));
2282 Sprint_Node
(Name
(Node
));
2283 Sprint_Opt_Paren_Comma_List
(Parameter_Associations
(Node
));
2286 when N_Procedure_Instantiation
=>
2287 Write_Indent_Str_Sloc
("procedure ");
2288 Sprint_Node
(Defining_Unit_Name
(Node
));
2289 Write_Str_With_Col_Check
(" is new ");
2290 Sprint_Node
(Name
(Node
));
2291 Sprint_Opt_Paren_Comma_List
(Generic_Associations
(Node
));
2294 when N_Procedure_Specification
=>
2295 Write_Str_With_Col_Check_Sloc
("procedure ");
2296 Sprint_Node
(Defining_Unit_Name
(Node
));
2297 Write_Param_Specs
(Node
);
2299 when N_Protected_Body
=>
2300 Write_Indent_Str_Sloc
("protected body ");
2301 Write_Id
(Defining_Identifier
(Node
));
2303 Sprint_Indented_List
(Declarations
(Node
));
2304 Write_Indent_Str
("end ");
2305 Write_Id
(Defining_Identifier
(Node
));
2308 when N_Protected_Body_Stub
=>
2309 Write_Indent_Str_Sloc
("protected body ");
2310 Write_Id
(Defining_Identifier
(Node
));
2311 Write_Str_With_Col_Check
(" is separate;");
2313 when N_Protected_Definition
=>
2315 Sprint_Indented_List
(Visible_Declarations
(Node
));
2317 if Present
(Private_Declarations
(Node
)) then
2318 Write_Indent_Str
("private");
2319 Sprint_Indented_List
(Private_Declarations
(Node
));
2322 Write_Indent_Str
("end ");
2324 when N_Protected_Type_Declaration
=>
2325 Write_Indent_Str_Sloc
("protected type ");
2326 Write_Id
(Defining_Identifier
(Node
));
2327 Write_Discr_Specs
(Node
);
2329 if Present
(Interface_List
(Node
)) then
2330 Write_Str
(" is new ");
2331 Sprint_And_List
(Interface_List
(Node
));
2332 Write_Str
(" with ");
2337 Sprint_Node
(Protected_Definition
(Node
));
2338 Write_Id
(Defining_Identifier
(Node
));
2341 when N_Qualified_Expression
=>
2342 Sprint_Node
(Subtype_Mark
(Node
));
2343 Write_Char_Sloc
(''');
2345 -- Print expression, make sure we have at least one level of
2346 -- parentheses around the expression. For cases of qualified
2347 -- expressions in the source, this is always the case, but
2348 -- for generated qualifications, there may be no explicit
2349 -- parentheses present.
2351 if Paren_Count
(Expression
(Node
)) /= 0 then
2352 Sprint_Node
(Expression
(Node
));
2355 Sprint_Node
(Expression
(Node
));
2359 when N_Raise_Constraint_Error
=>
2361 -- This node can be used either as a subexpression or as a
2362 -- statement form. The following test is a reasonably reliable
2363 -- way to distinguish the two cases.
2365 if Is_List_Member
(Node
)
2366 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2371 Write_Str_With_Col_Check_Sloc
("[constraint_error");
2372 Write_Condition_And_Reason
(Node
);
2374 when N_Raise_Program_Error
=>
2376 -- This node can be used either as a subexpression or as a
2377 -- statement form. The following test is a reasonably reliable
2378 -- way to distinguish the two cases.
2380 if Is_List_Member
(Node
)
2381 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2386 Write_Str_With_Col_Check_Sloc
("[program_error");
2387 Write_Condition_And_Reason
(Node
);
2389 when N_Raise_Storage_Error
=>
2391 -- This node can be used either as a subexpression or as a
2392 -- statement form. The following test is a reasonably reliable
2393 -- way to distinguish the two cases.
2395 if Is_List_Member
(Node
)
2396 and then Nkind
(Parent
(Node
)) not in N_Subexpr
2401 Write_Str_With_Col_Check_Sloc
("[storage_error");
2402 Write_Condition_And_Reason
(Node
);
2404 when N_Raise_Statement
=>
2405 Write_Indent_Str_Sloc
("raise ");
2406 Sprint_Node
(Name
(Node
));
2410 Sprint_Node
(Low_Bound
(Node
));
2411 Write_Str_Sloc
(" .. ");
2412 Sprint_Node
(High_Bound
(Node
));
2414 when N_Range_Constraint
=>
2415 Write_Str_With_Col_Check_Sloc
("range ");
2416 Sprint_Node
(Range_Expression
(Node
));
2418 when N_Real_Literal
=>
2419 Write_Ureal_With_Col_Check_Sloc
(Realval
(Node
));
2421 when N_Real_Range_Specification
=>
2422 Write_Str_With_Col_Check_Sloc
("range ");
2423 Sprint_Node
(Low_Bound
(Node
));
2425 Sprint_Node
(High_Bound
(Node
));
2427 when N_Record_Definition
=>
2428 if Abstract_Present
(Node
) then
2429 Write_Str_With_Col_Check
("abstract ");
2432 if Tagged_Present
(Node
) then
2433 Write_Str_With_Col_Check
("tagged ");
2436 if Limited_Present
(Node
) then
2437 Write_Str_With_Col_Check
("limited ");
2440 if Null_Present
(Node
) then
2441 Write_Str_With_Col_Check_Sloc
("null record");
2444 Write_Str_With_Col_Check_Sloc
("record");
2445 Sprint_Node
(Component_List
(Node
));
2446 Write_Indent_Str
("end record");
2449 when N_Record_Representation_Clause
=>
2450 Write_Indent_Str_Sloc
("for ");
2451 Sprint_Node
(Identifier
(Node
));
2452 Write_Str_With_Col_Check
(" use record ");
2454 if Present
(Mod_Clause
(Node
)) then
2455 Sprint_Node
(Mod_Clause
(Node
));
2458 Sprint_Indented_List
(Component_Clauses
(Node
));
2459 Write_Indent_Str
("end record;");
2462 Sprint_Node
(Prefix
(Node
));
2463 Write_Str_With_Col_Check_Sloc
("'reference");
2465 when N_Requeue_Statement
=>
2466 Write_Indent_Str_Sloc
("requeue ");
2467 Sprint_Node
(Name
(Node
));
2469 if Abort_Present
(Node
) then
2470 Write_Str_With_Col_Check
(" with abort");
2475 when N_Return_Statement
=>
2476 if Present
(Expression
(Node
)) then
2477 Write_Indent_Str_Sloc
("return ");
2478 Sprint_Node
(Expression
(Node
));
2481 Write_Indent_Str_Sloc
("return;");
2484 when N_Selective_Accept
=>
2485 Write_Indent_Str_Sloc
("select");
2490 Alt_Node
:= First
(Select_Alternatives
(Node
));
2493 Sprint_Node
(Alt_Node
);
2496 exit when No
(Alt_Node
);
2497 Write_Indent_Str
("or");
2501 if Present
(Else_Statements
(Node
)) then
2502 Write_Indent_Str
("else");
2503 Sprint_Indented_List
(Else_Statements
(Node
));
2506 Write_Indent_Str
("end select;");
2508 when N_Signed_Integer_Type_Definition
=>
2509 Write_Str_With_Col_Check_Sloc
("range ");
2510 Sprint_Node
(Low_Bound
(Node
));
2512 Sprint_Node
(High_Bound
(Node
));
2514 when N_Single_Protected_Declaration
=>
2515 Write_Indent_Str_Sloc
("protected ");
2516 Write_Id
(Defining_Identifier
(Node
));
2518 Sprint_Node
(Protected_Definition
(Node
));
2519 Write_Id
(Defining_Identifier
(Node
));
2522 when N_Single_Task_Declaration
=>
2523 Write_Indent_Str_Sloc
("task ");
2524 Write_Id
(Defining_Identifier
(Node
));
2526 if Present
(Task_Definition
(Node
)) then
2528 Sprint_Node
(Task_Definition
(Node
));
2529 Write_Id
(Defining_Identifier
(Node
));
2534 when N_Selected_Component
=>
2535 Sprint_Node
(Prefix
(Node
));
2536 Write_Char_Sloc
('.');
2537 Sprint_Node
(Selector_Name
(Node
));
2541 Sprint_Node
(Prefix
(Node
));
2542 Write_Str_With_Col_Check
(" (");
2543 Sprint_Node
(Discrete_Range
(Node
));
2546 when N_String_Literal
=>
2547 if String_Length
(Strval
(Node
)) + Column
> 75 then
2548 Write_Indent_Str
(" ");
2552 Write_String_Table_Entry
(Strval
(Node
));
2554 when N_Subprogram_Body
=>
2556 -- Output extra blank line unless we are in freeze actions
2558 if Freeze_Indent
= 0 then
2563 Sprint_Node_Sloc
(Specification
(Node
));
2566 Sprint_Indented_List
(Declarations
(Node
));
2567 Write_Indent_Str
("begin");
2568 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2570 Write_Indent_Str
("end ");
2571 Sprint_Node
(Defining_Unit_Name
(Specification
(Node
)));
2574 if Is_List_Member
(Node
)
2575 and then Present
(Next
(Node
))
2576 and then Nkind
(Next
(Node
)) /= N_Subprogram_Body
2581 when N_Subprogram_Body_Stub
=>
2583 Sprint_Node_Sloc
(Specification
(Node
));
2584 Write_Str_With_Col_Check
(" is separate;");
2586 when N_Subprogram_Declaration
=>
2588 Sprint_Node_Sloc
(Specification
(Node
));
2590 if Nkind
(Specification
(Node
)) = N_Procedure_Specification
2591 and then Null_Present
(Specification
(Node
))
2593 Write_Str_With_Col_Check
(" is null");
2598 when N_Subprogram_Info
=>
2599 Sprint_Node
(Identifier
(Node
));
2600 Write_Str_With_Col_Check_Sloc
("'subprogram_info");
2602 when N_Subprogram_Renaming_Declaration
=>
2604 Sprint_Node
(Specification
(Node
));
2605 Write_Str_With_Col_Check_Sloc
(" renames ");
2606 Sprint_Node
(Name
(Node
));
2609 when N_Subtype_Declaration
=>
2610 Write_Indent_Str_Sloc
("subtype ");
2611 Write_Id
(Defining_Identifier
(Node
));
2614 -- Ada 2005 (AI-231)
2616 if Null_Exclusion_Present
(Node
) then
2617 Write_Str
("not null ");
2620 Sprint_Node
(Subtype_Indication
(Node
));
2623 when N_Subtype_Indication
=>
2624 Sprint_Node_Sloc
(Subtype_Mark
(Node
));
2626 Sprint_Node
(Constraint
(Node
));
2629 Write_Indent_Str_Sloc
("separate (");
2630 Sprint_Node
(Name
(Node
));
2633 Sprint_Node
(Proper_Body
(Node
));
2636 Write_Indent_Str_Sloc
("task body ");
2637 Write_Id
(Defining_Identifier
(Node
));
2639 Sprint_Indented_List
(Declarations
(Node
));
2640 Write_Indent_Str
("begin");
2641 Sprint_Node
(Handled_Statement_Sequence
(Node
));
2642 Write_Indent_Str
("end ");
2643 Write_Id
(Defining_Identifier
(Node
));
2646 when N_Task_Body_Stub
=>
2647 Write_Indent_Str_Sloc
("task body ");
2648 Write_Id
(Defining_Identifier
(Node
));
2649 Write_Str_With_Col_Check
(" is separate;");
2651 when N_Task_Definition
=>
2653 Sprint_Indented_List
(Visible_Declarations
(Node
));
2655 if Present
(Private_Declarations
(Node
)) then
2656 Write_Indent_Str
("private");
2657 Sprint_Indented_List
(Private_Declarations
(Node
));
2660 Write_Indent_Str
("end ");
2662 when N_Task_Type_Declaration
=>
2663 Write_Indent_Str_Sloc
("task type ");
2664 Write_Id
(Defining_Identifier
(Node
));
2665 Write_Discr_Specs
(Node
);
2667 if Present
(Interface_List
(Node
)) then
2668 Write_Str
(" is new ");
2669 Sprint_And_List
(Interface_List
(Node
));
2672 if Present
(Task_Definition
(Node
)) then
2673 if No
(Interface_List
(Node
)) then
2676 Write_Str
(" with ");
2679 Sprint_Node
(Task_Definition
(Node
));
2680 Write_Id
(Defining_Identifier
(Node
));
2685 when N_Terminate_Alternative
=>
2686 Sprint_Node_List
(Pragmas_Before
(Node
));
2690 if Present
(Condition
(Node
)) then
2691 Write_Str_With_Col_Check
("when ");
2692 Sprint_Node
(Condition
(Node
));
2696 Write_Str_With_Col_Check_Sloc
("terminate;");
2697 Sprint_Node_List
(Pragmas_After
(Node
));
2699 when N_Timed_Entry_Call
=>
2700 Write_Indent_Str_Sloc
("select");
2702 Sprint_Node
(Entry_Call_Alternative
(Node
));
2704 Write_Indent_Str
("or");
2706 Sprint_Node
(Delay_Alternative
(Node
));
2708 Write_Indent_Str
("end select;");
2710 when N_Triggering_Alternative
=>
2711 Sprint_Node_List
(Pragmas_Before
(Node
));
2712 Sprint_Node_Sloc
(Triggering_Statement
(Node
));
2713 Sprint_Node_List
(Statements
(Node
));
2715 when N_Type_Conversion
=>
2717 Sprint_Node
(Subtype_Mark
(Node
));
2720 if Conversion_OK
(Node
) then
2724 if Float_Truncate
(Node
) then
2728 if Rounded_Result
(Node
) then
2733 Sprint_Node
(Expression
(Node
));
2736 when N_Unchecked_Expression
=>
2739 Sprint_Node_Sloc
(Expression
(Node
));
2742 when N_Unchecked_Type_Conversion
=>
2743 Sprint_Node
(Subtype_Mark
(Node
));
2745 Write_Str_With_Col_Check
("(");
2746 Sprint_Node_Sloc
(Expression
(Node
));
2749 when N_Unconstrained_Array_Definition
=>
2750 Write_Str_With_Col_Check_Sloc
("array (");
2755 Node1
:= First
(Subtype_Marks
(Node
));
2757 Sprint_Node
(Node1
);
2758 Write_Str_With_Col_Check
(" range <>");
2760 exit when Node1
= Empty
;
2765 Write_Str
(") of ");
2766 Sprint_Node
(Component_Definition
(Node
));
2768 when N_Unused_At_Start | N_Unused_At_End
=>
2769 Write_Indent_Str
("***** Error, unused node encountered *****");
2772 when N_Use_Package_Clause
=>
2773 Write_Indent_Str_Sloc
("use ");
2774 Sprint_Comma_List
(Names
(Node
));
2777 when N_Use_Type_Clause
=>
2778 Write_Indent_Str_Sloc
("use type ");
2779 Sprint_Comma_List
(Subtype_Marks
(Node
));
2782 when N_Validate_Unchecked_Conversion
=>
2783 Write_Indent_Str_Sloc
("validate unchecked_conversion (");
2784 Sprint_Node
(Source_Type
(Node
));
2786 Sprint_Node
(Target_Type
(Node
));
2790 Write_Indent_Str_Sloc
("when ");
2791 Sprint_Bar_List
(Discrete_Choices
(Node
));
2793 Sprint_Node
(Component_List
(Node
));
2795 when N_Variant_Part
=>
2797 Write_Indent_Str_Sloc
("case ");
2798 Sprint_Node
(Name
(Node
));
2800 Sprint_Indented_List
(Variants
(Node
));
2801 Write_Indent_Str
("end case");
2804 when N_With_Clause
=>
2806 -- Special test, if we are dumping the original tree only,
2807 -- then we want to eliminate the bogus with clauses that
2808 -- correspond to the non-existent children of Text_IO.
2810 if Dump_Original_Only
2811 and then Is_Text_IO_Kludge_Unit
(Name
(Node
))
2815 -- Normal case, output the with clause
2818 if First_Name
(Node
) or else not Dump_Original_Only
then
2820 -- Ada 2005 (AI-50217): Print limited with_clauses
2822 if Private_Present
(Node
) and Limited_Present
(Node
) then
2823 Write_Indent_Str
("limited private with ");
2825 elsif Private_Present
(Node
) then
2826 Write_Indent_Str
("private with ");
2828 elsif Limited_Present
(Node
) then
2829 Write_Indent_Str
("limited with ");
2832 Write_Indent_Str
("with ");
2839 Sprint_Node_Sloc
(Name
(Node
));
2841 if Last_Name
(Node
) or else not Dump_Original_Only
then
2846 when N_With_Type_Clause
=>
2847 Write_Indent_Str
("with type ");
2848 Sprint_Node_Sloc
(Name
(Node
));
2850 if Tagged_Present
(Node
) then
2851 Write_Str
(" is tagged;");
2853 Write_Str
(" is access;");
2858 if Nkind
(Node
) in N_Subexpr
2859 and then Do_Range_Check
(Node
)
2864 for J
in 1 .. Paren_Count
(Node
) loop
2868 Dump_Node
:= Save_Dump_Node
;
2869 end Sprint_Node_Actual
;
2871 ----------------------
2872 -- Sprint_Node_List --
2873 ----------------------
2875 procedure Sprint_Node_List
(List
: List_Id
) is
2879 if Is_Non_Empty_List
(List
) then
2880 Node
:= First
(List
);
2885 exit when Node
= Empty
;
2888 end Sprint_Node_List
;
2890 ----------------------
2891 -- Sprint_Node_Sloc --
2892 ----------------------
2894 procedure Sprint_Node_Sloc
(Node
: Node_Id
) is
2898 if Debug_Generated_Code
and then Present
(Dump_Node
) then
2899 Set_Sloc
(Dump_Node
, Sloc
(Node
));
2902 end Sprint_Node_Sloc
;
2904 ---------------------
2905 -- Sprint_Opt_Node --
2906 ---------------------
2908 procedure Sprint_Opt_Node
(Node
: Node_Id
) is
2910 if Present
(Node
) then
2914 end Sprint_Opt_Node
;
2916 --------------------------
2917 -- Sprint_Opt_Node_List --
2918 --------------------------
2920 procedure Sprint_Opt_Node_List
(List
: List_Id
) is
2922 if Present
(List
) then
2923 Sprint_Node_List
(List
);
2925 end Sprint_Opt_Node_List
;
2927 ---------------------------------
2928 -- Sprint_Opt_Paren_Comma_List --
2929 ---------------------------------
2931 procedure Sprint_Opt_Paren_Comma_List
(List
: List_Id
) is
2933 if Is_Non_Empty_List
(List
) then
2935 Sprint_Paren_Comma_List
(List
);
2937 end Sprint_Opt_Paren_Comma_List
;
2939 -----------------------------
2940 -- Sprint_Paren_Comma_List --
2941 -----------------------------
2943 procedure Sprint_Paren_Comma_List
(List
: List_Id
) is
2945 Node_Exists
: Boolean := False;
2949 if Is_Non_Empty_List
(List
) then
2951 if Dump_Original_Only
then
2953 while Present
(N
) loop
2954 if not Is_Rewrite_Insertion
(N
) then
2955 Node_Exists
:= True;
2962 if not Node_Exists
then
2967 Write_Str_With_Col_Check
("(");
2968 Sprint_Comma_List
(List
);
2971 end Sprint_Paren_Comma_List
;
2973 ----------------------
2974 -- Sprint_Right_Opnd --
2975 ----------------------
2977 procedure Sprint_Right_Opnd
(N
: Node_Id
) is
2978 Opnd
: constant Node_Id
:= Right_Opnd
(N
);
2981 if Paren_Count
(Opnd
) /= 0
2982 or else Op_Prec
(Nkind
(Opnd
)) > Op_Prec
(Nkind
(N
))
2991 end Sprint_Right_Opnd
;
2993 ---------------------
2994 -- Write_Char_Sloc --
2995 ---------------------
2997 procedure Write_Char_Sloc
(C
: Character) is
2999 if Debug_Generated_Code
and then C
/= ' ' then
3004 end Write_Char_Sloc
;
3006 --------------------------------
3007 -- Write_Condition_And_Reason --
3008 --------------------------------
3010 procedure Write_Condition_And_Reason
(Node
: Node_Id
) is
3011 Cond
: constant Node_Id
:= Condition
(Node
);
3012 Image
: constant String := RT_Exception_Code
'Image
3013 (RT_Exception_Code
'Val
3014 (UI_To_Int
(Reason
(Node
))));
3017 if Present
(Cond
) then
3019 -- If condition is a single entity, or NOT with a single entity,
3020 -- output all on one line, since it will likely fit just fine.
3022 if Is_Entity_Name
(Cond
)
3023 or else (Nkind
(Cond
) = N_Op_Not
3024 and then Is_Entity_Name
(Right_Opnd
(Cond
)))
3026 Write_Str_With_Col_Check
(" when ");
3030 -- Otherwise for more complex condition, multiple lines
3033 Write_Str_With_Col_Check
(" when");
3034 Indent
:= Indent
+ 2;
3038 Indent
:= Indent
- 2;
3041 -- If no condition, just need a space (all on one line)
3051 for J
in 4 .. Image
'Last loop
3052 if Image
(J
) = '_' then
3055 Write_Char
(Fold_Lower
(Image
(J
)));
3060 end Write_Condition_And_Reason
;
3062 --------------------------------
3063 -- Write_Corresponding_Source --
3064 --------------------------------
3066 procedure Write_Corresponding_Source
(S
: String) is
3068 Src
: Source_Buffer_Ptr
;
3071 -- Ignore if not in dump source text mode, or if in freeze actions
3073 if Dump_Source_Text
and then Freeze_Indent
= 0 then
3075 -- Ignore null string
3081 -- Ignore space or semicolon at end of given string
3083 if S
(S
'Last) = ' ' or else S
(S
'Last) = ';' then
3084 Write_Corresponding_Source
(S
(S
'First .. S
'Last - 1));
3088 -- Loop to look at next lines not yet printed in source file
3091 Last_Line_Printed
+ 1 .. Last_Source_Line
(Current_Source_File
)
3093 Src
:= Source_Text
(Current_Source_File
);
3094 Loc
:= Line_Start
(L
, Current_Source_File
);
3096 -- If comment, keep looking
3098 if Src
(Loc
.. Loc
+ 1) = "--" then
3101 -- Search to first non-blank
3104 while Src
(Loc
) not in Line_Terminator
loop
3108 if Src
(Loc
) /= ' ' and then Src
(Loc
) /= ASCII
.HT
then
3110 -- Loop through characters in string to see if we match
3112 for J
in S
'Range loop
3114 -- If mismatch, then not the case we are looking for
3116 if Src
(Loc
) /= S
(J
) then
3123 -- If we fall through, string matched, if white space or
3124 -- semicolon after the matched string, this is the case
3125 -- we are looking for.
3127 if Src
(Loc
) in Line_Terminator
3128 or else Src
(Loc
) = ' '
3129 or else Src
(Loc
) = ASCII
.HT
3130 or else Src
(Loc
) = ';'
3132 -- So output source lines up to and including this one
3134 Write_Source_Lines
(L
);
3143 -- Line was all blanks, or a comment line, keep looking
3147 end Write_Corresponding_Source
;
3149 -----------------------
3150 -- Write_Discr_Specs --
3151 -----------------------
3153 procedure Write_Discr_Specs
(N
: Node_Id
) is
3158 Specs
:= Discriminant_Specifications
(N
);
3160 if Present
(Specs
) then
3161 Write_Str_With_Col_Check
(" (");
3162 Spec
:= First
(Specs
);
3167 exit when Spec
= Empty
;
3169 -- Add semicolon, unless we are printing original tree and the
3170 -- next specification is part of a list (but not the first
3171 -- element of that list)
3173 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
3180 end Write_Discr_Specs
;
3186 procedure Write_Ekind
(E
: Entity_Id
) is
3187 S
: constant String := Entity_Kind
'Image (Ekind
(E
));
3190 Name_Len
:= S
'Length;
3191 Name_Buffer
(1 .. Name_Len
) := S
;
3192 Set_Casing
(Mixed_Case
);
3193 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3200 procedure Write_Id
(N
: Node_Id
) is
3202 -- Deal with outputting Itype
3204 -- Note: if we are printing the full tree with -gnatds, then we may
3205 -- end up picking up the Associated_Node link from a generic template
3206 -- here which overlaps the Entity field, but as documented, Write_Itype
3207 -- is defended against junk calls.
3209 if Nkind
(N
) in N_Entity
then
3211 elsif Nkind
(N
) in N_Has_Entity
then
3212 Write_Itype
(Entity
(N
));
3215 -- Case of a defining identifier
3217 if Nkind
(N
) = N_Defining_Identifier
then
3219 -- If defining identifier has an interface name (and no
3220 -- address clause), then we output the interface name.
3222 if (Is_Imported
(N
) or else Is_Exported
(N
))
3223 and then Present
(Interface_Name
(N
))
3224 and then No
(Address_Clause
(N
))
3226 String_To_Name_Buffer
(Strval
(Interface_Name
(N
)));
3227 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3229 -- If no interface name (or inactive because there was
3230 -- an address clause), then just output the Chars name.
3233 Write_Name_With_Col_Check
(Chars
(N
));
3236 -- Case of selector of an expanded name where the expanded name
3237 -- has an associated entity, output this entity.
3239 elsif Nkind
(Parent
(N
)) = N_Expanded_Name
3240 and then Selector_Name
(Parent
(N
)) = N
3241 and then Present
(Entity
(Parent
(N
)))
3243 Write_Id
(Entity
(Parent
(N
)));
3245 -- For any other node with an associated entity, output it
3247 elsif Nkind
(N
) in N_Has_Entity
3248 and then Present
(Entity_Or_Associated_Node
(N
))
3249 and then Nkind
(Entity_Or_Associated_Node
(N
)) in N_Entity
3251 Write_Id
(Entity
(N
));
3253 -- All other cases, we just print the Chars field
3256 Write_Name_With_Col_Check
(Chars
(N
));
3260 -----------------------
3261 -- Write_Identifiers --
3262 -----------------------
3264 function Write_Identifiers
(Node
: Node_Id
) return Boolean is
3266 Sprint_Node
(Defining_Identifier
(Node
));
3268 -- The remainder of the declaration must be printed unless we are
3269 -- printing the original tree and this is not the last identifier
3272 not Dump_Original_Only
or else not More_Ids
(Node
);
3274 end Write_Identifiers
;
3276 ------------------------
3277 -- Write_Implicit_Def --
3278 ------------------------
3280 procedure Write_Implicit_Def
(E
: Entity_Id
) is
3285 when E_Array_Subtype
=>
3286 Write_Str_With_Col_Check
("subtype ");
3288 Write_Str_With_Col_Check
(" is ");
3289 Write_Id
(Base_Type
(E
));
3290 Write_Str_With_Col_Check
(" (");
3292 Ind
:= First_Index
(E
);
3293 while Present
(Ind
) loop
3297 if Present
(Ind
) then
3304 when E_Signed_Integer_Subtype | E_Enumeration_Subtype
=>
3305 Write_Str_With_Col_Check
("subtype ");
3308 Write_Id
(Etype
(E
));
3309 Write_Str_With_Col_Check
(" range ");
3310 Sprint_Node
(Scalar_Range
(E
));
3314 Write_Str_With_Col_Check
("type ");
3316 Write_Str_With_Col_Check
(" is <");
3321 end Write_Implicit_Def
;
3327 procedure Write_Indent
is
3328 Loc
: constant Source_Ptr
:= Sloc
(Dump_Node
);
3331 if Indent_Annull_Flag
then
3332 Indent_Annull_Flag
:= False;
3334 if Dump_Source_Text
and then Loc
> No_Location
then
3335 if Get_Source_File_Index
(Loc
) = Current_Source_File
then
3337 (Get_Physical_Line_Number
(Sloc
(Dump_Node
)));
3343 for J
in 1 .. Indent
loop
3349 ------------------------------
3350 -- Write_Indent_Identifiers --
3351 ------------------------------
3353 function Write_Indent_Identifiers
(Node
: Node_Id
) return Boolean is
3355 -- We need to start a new line for every node, except in the case
3356 -- where we are printing the original tree and this is not the first
3357 -- defining identifier in the list.
3359 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
3362 -- If printing original tree and this is not the first defining
3363 -- identifier in the list, then the previous call to this procedure
3364 -- printed only the name, and we add a comma to separate the names.
3370 Sprint_Node
(Defining_Identifier
(Node
));
3372 -- The remainder of the declaration must be printed unless we are
3373 -- printing the original tree and this is not the last identifier
3376 not Dump_Original_Only
or else not More_Ids
(Node
);
3378 end Write_Indent_Identifiers
;
3380 -----------------------------------
3381 -- Write_Indent_Identifiers_Sloc --
3382 -----------------------------------
3384 function Write_Indent_Identifiers_Sloc
(Node
: Node_Id
) return Boolean is
3386 -- We need to start a new line for every node, except in the case
3387 -- where we are printing the original tree and this is not the first
3388 -- defining identifier in the list.
3390 if not Dump_Original_Only
or else not Prev_Ids
(Node
) then
3393 -- If printing original tree and this is not the first defining
3394 -- identifier in the list, then the previous call to this procedure
3395 -- printed only the name, and we add a comma to separate the names.
3402 Sprint_Node
(Defining_Identifier
(Node
));
3404 -- The remainder of the declaration must be printed unless we are
3405 -- printing the original tree and this is not the last identifier
3407 return not Dump_Original_Only
or else not More_Ids
(Node
);
3408 end Write_Indent_Identifiers_Sloc
;
3410 ----------------------
3411 -- Write_Indent_Str --
3412 ----------------------
3414 procedure Write_Indent_Str
(S
: String) is
3416 Write_Corresponding_Source
(S
);
3419 end Write_Indent_Str
;
3421 ---------------------------
3422 -- Write_Indent_Str_Sloc --
3423 ---------------------------
3425 procedure Write_Indent_Str_Sloc
(S
: String) is
3427 Write_Corresponding_Source
(S
);
3430 end Write_Indent_Str_Sloc
;
3436 procedure Write_Itype
(Typ
: Entity_Id
) is
3438 procedure Write_Header
(T
: Boolean := True);
3439 -- Write type if T is True, subtype if T is false
3445 procedure Write_Header
(T
: Boolean := True) is
3448 Write_Str
("[type ");
3450 Write_Str
("[subtype ");
3453 Write_Name_With_Col_Check
(Chars
(Typ
));
3457 -- Start of processing for Write_Itype
3460 if Nkind
(Typ
) in N_Entity
3461 and then Is_Itype
(Typ
)
3462 and then not Itype_Printed
(Typ
)
3464 -- Itype to be printed
3467 B
: constant Node_Id
:= Etype
(Typ
);
3469 P
: constant Node_Id
:= Parent
(Typ
);
3471 S
: constant Saved_Output_Buffer
:= Save_Output_Buffer
;
3472 -- Save current output buffer
3474 Old_Sloc
: Source_Ptr
;
3475 -- Save sloc of related node, so it is not modified when
3476 -- printing with -gnatD.
3479 -- Write indentation at start of line
3481 for J
in 1 .. Indent
loop
3485 -- If we have a constructed declaration, print it
3487 if Present
(P
) and then Nkind
(P
) in N_Declaration
then
3489 -- We must set Itype_Printed true before the recursive call to
3490 -- print the node, otherwise we get an infinite recursion!
3492 Set_Itype_Printed
(Typ
, True);
3494 -- Write the declaration enclosed in [], avoiding new line
3495 -- at start of declaration, and semicolon at end.
3497 -- Note: The itype may be imported from another unit, in which
3498 -- case we do not want to modify the Sloc of the declaration.
3499 -- Otherwise the itype may appear to be in the current unit,
3500 -- and the back-end will reject a reference out of scope.
3503 Indent_Annull_Flag
:= True;
3504 Old_Sloc
:= Sloc
(P
);
3506 Set_Sloc
(P
, Old_Sloc
);
3507 Write_Erase_Char
(';');
3509 -- If no constructed declaration, then we have to concoct the
3510 -- source corresponding to the type entity that we have at hand.
3515 -- Access types and subtypes
3518 Write_Header
(Ekind
(Typ
) = E_Access_Type
);
3519 Write_Str
("access ");
3521 if Is_Access_Constant
(Typ
) then
3522 Write_Str
("constant ");
3523 elsif Can_Never_Be_Null
(Typ
) then
3524 Write_Str
("not null ");
3527 Write_Id
(Directly_Designated_Type
(Typ
));
3529 -- Array types and string types
3531 when E_Array_Type | E_String_Type
=>
3533 Write_Str
("array (");
3535 X
:= First_Index
(Typ
);
3539 if not Is_Constrained
(Typ
) then
3540 Write_Str
(" range <>");
3548 Write_Str
(") of ");
3549 Sprint_Node
(Component_Type
(Typ
));
3551 -- Array subtypes and string subtypes
3553 when E_Array_Subtype | E_String_Subtype
=>
3554 Write_Header
(False);
3555 Write_Id
(Etype
(Typ
));
3558 X
:= First_Index
(Typ
);
3568 -- Signed integer types, and modular integer subtypes
3570 when E_Signed_Integer_Type |
3571 E_Signed_Integer_Subtype |
3572 E_Modular_Integer_Subtype
=>
3574 Write_Header
(Ekind
(Typ
) = E_Signed_Integer_Type
);
3576 if Ekind
(Typ
) = E_Signed_Integer_Type
then
3582 -- Print bounds if different from base type
3585 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3586 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
3591 -- B can either be a scalar type, in which case the
3592 -- declaration of Typ may constrain it with different
3593 -- bounds, or a private type, in which case we know
3594 -- that the declaration of Typ cannot have a scalar
3597 if Is_Scalar_Type
(B
) then
3598 LE
:= Type_Low_Bound
(B
);
3599 HE
:= Type_High_Bound
(B
);
3607 and then Nkind
(L
) = N_Integer_Literal
3608 and then Nkind
(H
) = N_Integer_Literal
3609 and then Nkind
(LE
) = N_Integer_Literal
3610 and then Nkind
(HE
) = N_Integer_Literal
3611 and then UI_Eq
(Intval
(L
), Intval
(LE
))
3612 and then UI_Eq
(Intval
(H
), Intval
(HE
)))
3617 Write_Str
(" range ");
3618 Sprint_Node
(Type_Low_Bound
(Typ
));
3620 Sprint_Node
(Type_High_Bound
(Typ
));
3624 -- Modular integer types
3626 when E_Modular_Integer_Type
=>
3628 Write_Str
(" mod ");
3629 Write_Uint_With_Col_Check
(Modulus
(Typ
), Auto
);
3631 -- Floating point types and subtypes
3633 when E_Floating_Point_Type |
3634 E_Floating_Point_Subtype
=>
3636 Write_Header
(Ekind
(Typ
) = E_Floating_Point_Type
);
3638 if Ekind
(Typ
) = E_Floating_Point_Type
then
3642 Write_Id
(Etype
(Typ
));
3644 if Digits_Value
(Typ
) /= Digits_Value
(Etype
(Typ
)) then
3645 Write_Str
(" digits ");
3646 Write_Uint_With_Col_Check
3647 (Digits_Value
(Typ
), Decimal
);
3650 -- Print bounds if not different from base type
3653 L
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3654 H
: constant Node_Id
:= Type_High_Bound
(Typ
);
3655 LE
: constant Node_Id
:= Type_Low_Bound
(B
);
3656 HE
: constant Node_Id
:= Type_High_Bound
(B
);
3659 if Nkind
(L
) = N_Real_Literal
3660 and then Nkind
(H
) = N_Real_Literal
3661 and then Nkind
(LE
) = N_Real_Literal
3662 and then Nkind
(HE
) = N_Real_Literal
3663 and then UR_Eq
(Realval
(L
), Realval
(LE
))
3664 and then UR_Eq
(Realval
(H
), Realval
(HE
))
3669 Write_Str
(" range ");
3670 Sprint_Node
(Type_Low_Bound
(Typ
));
3672 Sprint_Node
(Type_High_Bound
(Typ
));
3678 when E_Record_Subtype
=>
3679 Write_Header
(False);
3680 Write_Str
("record");
3686 C
:= First_Entity
(Typ
);
3687 while Present
(C
) loop
3691 Write_Id
(Etype
(C
));
3697 Write_Indent_Str
(" end record");
3701 when E_Class_Wide_Type
=>
3703 Write_Name_With_Col_Check
(Chars
(Etype
(Typ
)));
3704 Write_Str
("'Class");
3708 when E_Subprogram_Type
=>
3711 if Etype
(Typ
) = Standard_Void_Type
then
3712 Write_Str
("procedure");
3714 Write_Str
("function");
3717 if Present
(First_Entity
(Typ
)) then
3724 Param
:= First_Entity
(Typ
);
3729 if Ekind
(Param
) = E_In_Out_Parameter
then
3730 Write_Str
("in out ");
3731 elsif Ekind
(Param
) = E_Out_Parameter
then
3735 Write_Id
(Etype
(Param
));
3736 Next_Entity
(Param
);
3737 exit when No
(Param
);
3745 if Etype
(Typ
) /= Standard_Void_Type
then
3746 Write_Str
(" return ");
3747 Write_Id
(Etype
(Typ
));
3750 -- For all other Itypes, print ??? (fill in later)
3753 Write_Header
(True);
3759 -- Add terminating bracket and restore output buffer
3763 Restore_Output_Buffer
(S
);
3766 Set_Itype_Printed
(Typ
);
3770 -------------------------------
3771 -- Write_Name_With_Col_Check --
3772 -------------------------------
3774 procedure Write_Name_With_Col_Check
(N
: Name_Id
) is
3778 Get_Name_String
(N
);
3780 -- Deal with -gnatI which replaces digits in an internal
3781 -- name by three dots (e.g. R7b becomes R...b).
3783 if Debug_Flag_II
and then Name_Buffer
(1) in 'A' .. 'Z' then
3785 while J
< Name_Len
loop
3786 exit when Name_Buffer
(J
) not in 'A' .. 'Z';
3790 if Name_Buffer
(J
) in '0' .. '9' then
3791 Write_Str_With_Col_Check
(Name_Buffer
(1 .. J
- 1));
3794 while J
<= Name_Len
loop
3795 if Name_Buffer
(J
) not in '0' .. '9' then
3796 Write_Str
(Name_Buffer
(J
.. Name_Len
));
3808 -- Fall through for normal case
3810 Write_Str_With_Col_Check
(Name_Buffer
(1 .. Name_Len
));
3811 end Write_Name_With_Col_Check
;
3813 ------------------------------------
3814 -- Write_Name_With_Col_Check_Sloc --
3815 ------------------------------------
3817 procedure Write_Name_With_Col_Check_Sloc
(N
: Name_Id
) is
3819 Get_Name_String
(N
);
3820 Write_Str_With_Col_Check_Sloc
(Name_Buffer
(1 .. Name_Len
));
3821 end Write_Name_With_Col_Check_Sloc
;
3823 --------------------
3824 -- Write_Operator --
3825 --------------------
3827 procedure Write_Operator
(N
: Node_Id
; S
: String) is
3828 F
: Natural := S
'First;
3829 T
: Natural := S
'Last;
3832 -- If no overflow check, just write string out, and we are done
3834 if not Do_Overflow_Check
(N
) then
3837 -- If overflow check, we want to surround the operator with curly
3838 -- brackets, but not include spaces within the brackets.
3851 Write_Str_Sloc
(S
(F
.. T
));
3854 if S
(S
'Last) = ' ' then
3860 -----------------------
3861 -- Write_Param_Specs --
3862 -----------------------
3864 procedure Write_Param_Specs
(N
: Node_Id
) is
3870 Specs
:= Parameter_Specifications
(N
);
3872 if Is_Non_Empty_List
(Specs
) then
3873 Write_Str_With_Col_Check
(" (");
3874 Spec
:= First
(Specs
);
3878 Formal
:= Defining_Identifier
(Spec
);
3880 exit when Spec
= Empty
;
3882 -- Add semicolon, unless we are printing original tree and the
3883 -- next specification is part of a list (but not the first
3884 -- element of that list)
3886 if not Dump_Original_Only
or else not Prev_Ids
(Spec
) then
3891 -- Write out any extra formals
3893 while Present
(Extra_Formal
(Formal
)) loop
3894 Formal
:= Extra_Formal
(Formal
);
3896 Write_Name_With_Col_Check
(Chars
(Formal
));
3898 Write_Name_With_Col_Check
(Chars
(Etype
(Formal
)));
3903 end Write_Param_Specs
;
3905 -----------------------
3906 -- Write_Rewrite_Str --
3907 -----------------------
3909 procedure Write_Rewrite_Str
(S
: String) is
3911 if not Dump_Generated_Only
then
3912 if S
'Length = 3 and then S
= ">>>" then
3915 Write_Str_With_Col_Check
(S
);
3918 end Write_Rewrite_Str
;
3920 -----------------------
3921 -- Write_Source_Line --
3922 -----------------------
3924 procedure Write_Source_Line
(L
: Physical_Line_Number
) is
3926 Src
: Source_Buffer_Ptr
;
3930 if Dump_Source_Text
then
3931 Src
:= Source_Text
(Current_Source_File
);
3932 Loc
:= Line_Start
(L
, Current_Source_File
);
3935 -- See if line is a comment line, if not, and if not line one,
3936 -- precede with blank line.
3939 while Src
(Scn
) = ' ' or else Src
(Scn
) = ASCII
.HT
loop
3943 if (Src
(Scn
) in Line_Terminator
3944 or else Src
(Scn
.. Scn
+ 1) /= "--")
3950 -- Now write the source text of the line
3953 Write_Int
(Int
(L
));
3956 while Src
(Loc
) not in Line_Terminator
loop
3957 Write_Char
(Src
(Loc
));
3961 end Write_Source_Line
;
3963 ------------------------
3964 -- Write_Source_Lines --
3965 ------------------------
3967 procedure Write_Source_Lines
(L
: Physical_Line_Number
) is
3969 while Last_Line_Printed
< L
loop
3970 Last_Line_Printed
:= Last_Line_Printed
+ 1;
3971 Write_Source_Line
(Last_Line_Printed
);
3973 end Write_Source_Lines
;
3975 --------------------
3976 -- Write_Str_Sloc --
3977 --------------------
3979 procedure Write_Str_Sloc
(S
: String) is
3981 for J
in S
'Range loop
3982 Write_Char_Sloc
(S
(J
));
3986 ------------------------------
3987 -- Write_Str_With_Col_Check --
3988 ------------------------------
3990 procedure Write_Str_With_Col_Check
(S
: String) is
3992 if Int
(S
'Last) + Column
> Line_Limit
then
3993 Write_Indent_Str
(" ");
3995 if S
(S
'First) = ' ' then
3996 Write_Str
(S
(S
'First + 1 .. S
'Last));
4004 end Write_Str_With_Col_Check
;
4006 -----------------------------------
4007 -- Write_Str_With_Col_Check_Sloc --
4008 -----------------------------------
4010 procedure Write_Str_With_Col_Check_Sloc
(S
: String) is
4012 if Int
(S
'Last) + Column
> Line_Limit
then
4013 Write_Indent_Str
(" ");
4015 if S
(S
'First) = ' ' then
4016 Write_Str_Sloc
(S
(S
'First + 1 .. S
'Last));
4024 end Write_Str_With_Col_Check_Sloc
;
4026 -------------------------------
4027 -- Write_Uint_With_Col_Check --
4028 -------------------------------
4030 procedure Write_Uint_With_Col_Check
(U
: Uint
; Format
: UI_Format
) is
4032 Col_Check
(UI_Decimal_Digits_Hi
(U
));
4033 UI_Write
(U
, Format
);
4034 end Write_Uint_With_Col_Check
;
4036 ------------------------------------
4037 -- Write_Uint_With_Col_Check_Sloc --
4038 ------------------------------------
4040 procedure Write_Uint_With_Col_Check_Sloc
(U
: Uint
; Format
: UI_Format
) is
4042 Col_Check
(UI_Decimal_Digits_Hi
(U
));
4044 UI_Write
(U
, Format
);
4045 end Write_Uint_With_Col_Check_Sloc
;
4047 -------------------------------------
4048 -- Write_Ureal_With_Col_Check_Sloc --
4049 -------------------------------------
4051 procedure Write_Ureal_With_Col_Check_Sloc
(U
: Ureal
) is
4052 D
: constant Uint
:= Denominator
(U
);
4053 N
: constant Uint
:= Numerator
(U
);
4057 (UI_Decimal_Digits_Hi
(D
) + UI_Decimal_Digits_Hi
(N
) + 4);
4060 end Write_Ureal_With_Col_Check_Sloc
;