]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S P R I N T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1d005acc | 9 | -- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
0f1a6a0b | 26 | with Aspects; use Aspects; |
996ae0b0 RK |
27 | with Atree; use Atree; |
28 | with Casing; use Casing; | |
07fc65c4 | 29 | with Csets; use Csets; |
996ae0b0 RK |
30 | with Debug; use Debug; |
31 | with Einfo; use Einfo; | |
32 | with Lib; use Lib; | |
33 | with Namet; use Namet; | |
34 | with Nlists; use Nlists; | |
35 | with Opt; use Opt; | |
36 | with Output; use Output; | |
37 | with Rtsfind; use Rtsfind; | |
6a2afd13 | 38 | with Sem_Eval; use Sem_Eval; |
99cf6c77 | 39 | with Sem_Util; use Sem_Util; |
996ae0b0 RK |
40 | with Sinfo; use Sinfo; |
41 | with Sinput; use Sinput; | |
07fc65c4 | 42 | with Sinput.D; use Sinput.D; |
996ae0b0 RK |
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; | |
49 | ||
50 | package body Sprint is | |
39485a7b ES |
51 | Current_Source_File : Source_File_Index; |
52 | -- Index of source file whose generated code is being dumped | |
996ae0b0 | 53 | |
39485a7b ES |
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. | |
996ae0b0 | 59 | |
d3e16619 AC |
60 | First_Debug_Sloc : Source_Ptr; |
61 | -- Sloc of first byte of the current output file if we are generating a | |
62 | -- source debug file. | |
63 | ||
996ae0b0 RK |
64 | Debug_Sloc : Source_Ptr; |
65 | -- Sloc of first byte of line currently being written if we are | |
66 | -- generating a source debug file. | |
67 | ||
68 | Dump_Original_Only : Boolean; | |
69 | -- Set True if the -gnatdo (dump original tree) flag is set | |
70 | ||
71 | Dump_Generated_Only : Boolean; | |
0ac2a660 | 72 | -- Set True if the -gnatdG (dump generated tree) debug flag is set |
9596236a | 73 | -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). |
996ae0b0 RK |
74 | |
75 | Dump_Freeze_Null : Boolean; | |
7096a67b AC |
76 | -- Set True if empty freeze nodes and non-source null statements output. |
77 | -- Note that freeze nodes containing freeze actions are always output, | |
78 | -- as are freeze nodes for itypes, which in general have the effect of | |
79 | -- causing elaboration of the itype. | |
996ae0b0 | 80 | |
39485a7b ES |
81 | Freeze_Indent : Int := 0; |
82 | -- Keep track of freeze indent level (controls output of blank lines before | |
83 | -- procedures within expression freeze actions). Relevant only if we are | |
84 | -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't | |
85 | -- output these blank lines in any case. | |
86 | ||
996ae0b0 RK |
87 | Indent : Int := 0; |
88 | -- Number of columns for current line output indentation | |
89 | ||
90 | Indent_Annull_Flag : Boolean := False; | |
91 | -- Set True if subsequent Write_Indent call to be ignored, gets reset | |
92 | -- by this call, so it is only active to suppress a single indent call. | |
93 | ||
39485a7b ES |
94 | Last_Line_Printed : Physical_Line_Number; |
95 | -- This keeps track of the physical line number of the last source line | |
96 | -- that has been output. The value is only valid in Dump_Source_Text mode. | |
97 | ||
07fc65c4 GB |
98 | ------------------------------- |
99 | -- Operator Precedence Table -- | |
100 | ------------------------------- | |
101 | ||
102 | -- This table is used to decide whether a subexpression needs to be | |
103 | -- parenthesized. The rule is that if an operand of an operator (which | |
104 | -- for this purpose includes AND THEN and OR ELSE) is itself an operator | |
105 | -- with a lower precedence than the operator (or equal precedence if | |
106 | -- appearing as the right operand), then parentheses are required. | |
107 | ||
91b1417d | 108 | Op_Prec : constant array (N_Subexpr) of Short_Short_Integer := |
07fc65c4 GB |
109 | (N_Op_And => 1, |
110 | N_Op_Or => 1, | |
111 | N_Op_Xor => 1, | |
112 | N_And_Then => 1, | |
113 | N_Or_Else => 1, | |
114 | ||
115 | N_In => 2, | |
116 | N_Not_In => 2, | |
117 | N_Op_Eq => 2, | |
118 | N_Op_Ge => 2, | |
119 | N_Op_Gt => 2, | |
120 | N_Op_Le => 2, | |
121 | N_Op_Lt => 2, | |
122 | N_Op_Ne => 2, | |
123 | ||
124 | N_Op_Add => 3, | |
125 | N_Op_Concat => 3, | |
126 | N_Op_Subtract => 3, | |
127 | N_Op_Plus => 3, | |
128 | N_Op_Minus => 3, | |
129 | ||
130 | N_Op_Divide => 4, | |
131 | N_Op_Mod => 4, | |
132 | N_Op_Rem => 4, | |
133 | N_Op_Multiply => 4, | |
134 | ||
135 | N_Op_Expon => 5, | |
136 | N_Op_Abs => 5, | |
137 | N_Op_Not => 5, | |
138 | ||
139 | others => 6); | |
140 | ||
141 | procedure Sprint_Left_Opnd (N : Node_Id); | |
142 | -- Print left operand of operator, parenthesizing if necessary | |
143 | ||
144 | procedure Sprint_Right_Opnd (N : Node_Id); | |
145 | -- Print right operand of operator, parenthesizing if necessary | |
146 | ||
996ae0b0 RK |
147 | ----------------------- |
148 | -- Local Subprograms -- | |
149 | ----------------------- | |
150 | ||
151 | procedure Col_Check (N : Nat); | |
152 | -- Check that at least N characters remain on current line, and if not, | |
153 | -- then start an extra line with two characters extra indentation for | |
154 | -- continuing text on the next line. | |
155 | ||
39485a7b ES |
156 | procedure Extra_Blank_Line; |
157 | -- In some situations we write extra blank lines to separate the generated | |
158 | -- code to make it more readable. However, these extra blank lines are not | |
159 | -- generated in Dump_Source_Text mode, since there the source text lines | |
160 | -- output with preceding blank lines are quite sufficient as separators. | |
161 | -- This procedure writes a blank line if Dump_Source_Text is False. | |
162 | ||
996ae0b0 RK |
163 | procedure Indent_Annull; |
164 | -- Causes following call to Write_Indent to be ignored. This is used when | |
165 | -- a higher level node wants to stop a lower level node from starting a | |
166 | -- new line, when it would otherwise be inclined to do so (e.g. the case | |
167 | -- of an accept statement called from an accept alternative with a guard) | |
168 | ||
169 | procedure Indent_Begin; | |
170 | -- Increase indentation level | |
171 | ||
172 | procedure Indent_End; | |
173 | -- Decrease indentation level | |
174 | ||
07fc65c4 GB |
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). | |
996ae0b0 RK |
178 | |
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 @). | |
183 | ||
184 | procedure Set_Debug_Sloc; | |
39485a7b | 185 | -- If Dump_Node is non-empty, this routine sets the appropriate value |
996ae0b0 | 186 | -- in its Sloc field, from the current location in the debug source file |
39485a7b | 187 | -- that is currently being written. |
996ae0b0 | 188 | |
edd63e9b ES |
189 | procedure Sprint_And_List (List : List_Id); |
190 | -- Print the given list with items separated by vertical "and" | |
191 | ||
1c54829e AC |
192 | procedure Sprint_Aspect_Specifications |
193 | (Node : Node_Id; | |
194 | Semicolon : Boolean); | |
c159409f | 195 | -- Node is a declaration node that has aspect specifications (Has_Aspects |
1c54829e AC |
196 | -- flag set True). It outputs the aspect specifications. For the case |
197 | -- of Semicolon = True, it is called after outputting the terminating | |
198 | -- semicolon for the related node. The effect is to remove the semicolon | |
199 | -- and print the aspect specifications followed by a terminating semicolon. | |
200 | -- For the case of Semicolon False, no semicolon is removed or output, and | |
201 | -- all the aspects are printed on a single line. | |
0f1a6a0b | 202 | |
996ae0b0 RK |
203 | procedure Sprint_Bar_List (List : List_Id); |
204 | -- Print the given list with items separated by vertical bars | |
205 | ||
0c1edb56 ES |
206 | procedure Sprint_End_Label |
207 | (Node : Node_Id; | |
208 | Default : Node_Id); | |
209 | -- Print the end label for a Handled_Sequence_Of_Statements in a body. | |
97779c34 | 210 | -- If there is no end label, use the defining identifier of the enclosing |
0c1edb56 ES |
211 | -- construct. If the end label is present, treat it as a reference to the |
212 | -- defining entity of the construct: this guarantees that it carries the | |
213 | -- proper sloc information for debugging purposes. | |
214 | ||
996ae0b0 RK |
215 | procedure Sprint_Node_Actual (Node : Node_Id); |
216 | -- This routine prints its node argument. It is a lower level routine than | |
217 | -- Sprint_Node, in that it does not bother about rewritten trees. | |
218 | ||
219 | procedure Sprint_Node_Sloc (Node : Node_Id); | |
220 | -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode, | |
221 | -- sets the Sloc of the current debug node to be a copy of the Sloc | |
222 | -- of the sprinted node Node. Note that this is done after printing | |
223 | -- Node, so that the Sloc is the proper updated value for the debug file. | |
224 | ||
0c1edb56 ES |
225 | procedure Update_Itype (Node : Node_Id); |
226 | -- Update the Sloc of an itype that is not attached to the tree, when | |
227 | -- debugging expanded code. This routine is called from nodes whose | |
228 | -- type can be an Itype, such as defining_identifiers that may be of | |
229 | -- an anonymous access type, or ranges in slices. | |
230 | ||
996ae0b0 RK |
231 | procedure Write_Char_Sloc (C : Character); |
232 | -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is | |
233 | -- called to ensure that the current node has a proper Sloc set. | |
234 | ||
07fc65c4 GB |
235 | procedure Write_Condition_And_Reason (Node : Node_Id); |
236 | -- Write Condition and Reason codes of Raise_xxx_Error node | |
237 | ||
39485a7b ES |
238 | procedure Write_Corresponding_Source (S : String); |
239 | -- If S is a string with a single keyword (possibly followed by a space), | |
240 | -- and if the next non-comment non-blank source line matches this keyword, | |
241 | -- then output all source lines up to this matching line. | |
242 | ||
996ae0b0 | 243 | procedure Write_Discr_Specs (N : Node_Id); |
3354f96d | 244 | -- Output discriminant specification for node, which is any of the type |
996ae0b0 RK |
245 | -- declarations that can have discriminants. |
246 | ||
247 | procedure Write_Ekind (E : Entity_Id); | |
653da906 | 248 | -- Write the String corresponding to the Ekind without "E_" |
996ae0b0 RK |
249 | |
250 | procedure Write_Id (N : Node_Id); | |
251 | -- N is a node with a Chars field. This procedure writes the name that | |
252 | -- will be used in the generated code associated with the name. For a | |
253 | -- node with no associated entity, this is simply the Chars field. For | |
254 | -- the case where there is an entity associated with the node, we print | |
255 | -- the name associated with the entity (since it may have been encoded). | |
256 | -- One other special case is that an entity has an active external name | |
257 | -- (i.e. an external name present with no address clause), then this | |
653da906 RD |
258 | -- external name is output. This procedure also deals with outputting |
259 | -- declarations of referenced itypes, if not output earlier. | |
996ae0b0 RK |
260 | |
261 | function Write_Identifiers (Node : Node_Id) return Boolean; | |
262 | -- Handle node where the grammar has a list of defining identifiers, but | |
263 | -- the tree has a separate declaration for each identifier. Handles the | |
264 | -- printing of the defining identifier, and returns True if the type and | |
265 | -- initialization information is to be printed, False if it is to be | |
266 | -- skipped (the latter case happens when printing defining identifiers | |
267 | -- other than the first in the original tree output case). | |
268 | ||
269 | procedure Write_Implicit_Def (E : Entity_Id); | |
270 | pragma Warnings (Off, Write_Implicit_Def); | |
271 | -- Write the definition of the implicit type E according to its Ekind | |
272 | -- For now a debugging procedure, but might be used in the future. | |
273 | ||
274 | procedure Write_Indent; | |
275 | -- Start a new line and write indentation spacing | |
276 | ||
277 | function Write_Indent_Identifiers (Node : Node_Id) return Boolean; | |
278 | -- Like Write_Identifiers except that each new printed declaration | |
279 | -- is at the start of a new line. | |
280 | ||
281 | function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; | |
282 | -- Like Write_Indent_Identifiers except that in Debug_Generated_Code | |
3354f96d | 283 | -- mode, the Sloc of the current debug node is set to point to the |
996ae0b0 RK |
284 | -- first output identifier. |
285 | ||
286 | procedure Write_Indent_Str (S : String); | |
287 | -- Start a new line and write indent spacing followed by given string | |
288 | ||
289 | procedure Write_Indent_Str_Sloc (S : String); | |
290 | -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode, | |
291 | -- the Sloc of the current node is set to the first non-blank character | |
292 | -- in the string S. | |
293 | ||
653da906 RD |
294 | procedure Write_Itype (Typ : Entity_Id); |
295 | -- If Typ is an Itype that has not been written yet, write it. If Typ is | |
296 | -- any other kind of entity or tree node, the call is ignored. | |
297 | ||
996ae0b0 RK |
298 | procedure Write_Name_With_Col_Check (N : Name_Id); |
299 | -- Write name (using Write_Name) with initial column check, and possible | |
300 | -- initial Write_Indent (to get new line) if current line is too full. | |
301 | ||
302 | procedure Write_Name_With_Col_Check_Sloc (N : Name_Id); | |
303 | -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code | |
304 | -- mode, sets Sloc of current debug node to first character of name. | |
305 | ||
306 | procedure Write_Operator (N : Node_Id; S : String); | |
307 | -- Like Write_Str_Sloc, used for operators, encloses the string in | |
308 | -- characters {} if the Do_Overflow flag is set on the node N. | |
309 | ||
310 | procedure Write_Param_Specs (N : Node_Id); | |
58009744 AC |
311 | -- Output parameter specifications for node N (which is a subprogram, or |
312 | -- entry or entry family or access-subprogram-definition, all of which | |
313 | -- have a Parameter_Specificatioons field). | |
996ae0b0 RK |
314 | |
315 | procedure Write_Rewrite_Str (S : String); | |
316 | -- Writes out a string (typically containing <<< or >>>}) for a node | |
317 | -- created by rewriting the tree. Suppressed if we are outputting the | |
318 | -- generated code only, since in this case we don't specially mark nodes | |
319 | -- created by rewriting). | |
320 | ||
39485a7b ES |
321 | procedure Write_Source_Line (L : Physical_Line_Number); |
322 | -- If writing of interspersed source lines is enabled, then write the given | |
323 | -- line from the source file, preceded by Eol, then an extra blank line if | |
324 | -- the line has at least one blank, is not a comment and is not line one, | |
325 | -- then "--" and the line number followed by period followed by text of the | |
326 | -- source line (without terminating Eol). If interspersed source line | |
327 | -- output not enabled, then the call has no effect. | |
328 | ||
329 | procedure Write_Source_Lines (L : Physical_Line_Number); | |
330 | -- If writing of interspersed source lines is enabled, then writes source | |
331 | -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If | |
332 | -- interspersed source line output not enabled, then call has no effect. | |
333 | ||
996ae0b0 RK |
334 | procedure Write_Str_Sloc (S : String); |
335 | -- Like Write_Str, but sets debug Sloc of current debug node to first | |
336 | -- non-blank character if a current debug node is active. | |
337 | ||
338 | procedure Write_Str_With_Col_Check (S : String); | |
339 | -- Write string (using Write_Str) with initial column check, and possible | |
340 | -- initial Write_Indent (to get new line) if current line is too full. | |
341 | ||
342 | procedure Write_Str_With_Col_Check_Sloc (S : String); | |
3354f96d | 343 | -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug |
996ae0b0 RK |
344 | -- node to first non-blank character if a current debug node is active. |
345 | ||
ff7139c3 AC |
346 | procedure Write_Subprogram_Name (N : Node_Id); |
347 | -- N is the Name field of a function call or procedure statement call. | |
348 | -- The effect of the call is to output the name, preceded by a $ if the | |
349 | -- call is identified as an implicit call to a run time routine. | |
350 | ||
653da906 RD |
351 | procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); |
352 | -- Write Uint (using UI_Write) with initial column check, and possible | |
353 | -- initial Write_Indent (to get new line) if current line is too full. | |
354 | -- The format parameter determines the output format (see UI_Write). | |
355 | ||
996ae0b0 RK |
356 | procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format); |
357 | -- Write Uint (using UI_Write) with initial column check, and possible | |
358 | -- initial Write_Indent (to get new line) if current line is too full. | |
359 | -- The format parameter determines the output format (see UI_Write). | |
360 | -- In addition, in Debug_Generated_Code mode, sets the current node | |
361 | -- Sloc to the first character of the output value. | |
362 | ||
363 | procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal); | |
364 | -- Write Ureal (using same output format as UR_Write) with column checks | |
365 | -- and a possible initial Write_Indent (to get new line) if current line | |
366 | -- is too full. In addition, in Debug_Generated_Code mode, sets the | |
367 | -- current node Sloc to the first character of the output value. | |
368 | ||
369 | --------------- | |
370 | -- Col_Check -- | |
371 | --------------- | |
372 | ||
373 | procedure Col_Check (N : Nat) is | |
374 | begin | |
dcd8728b | 375 | if N + Column > Sprint_Line_Limit then |
996ae0b0 RK |
376 | Write_Indent_Str (" "); |
377 | end if; | |
378 | end Col_Check; | |
379 | ||
39485a7b ES |
380 | ---------------------- |
381 | -- Extra_Blank_Line -- | |
382 | ---------------------- | |
383 | ||
384 | procedure Extra_Blank_Line is | |
385 | begin | |
386 | if not Dump_Source_Text then | |
387 | Write_Indent; | |
388 | end if; | |
389 | end Extra_Blank_Line; | |
390 | ||
996ae0b0 RK |
391 | ------------------- |
392 | -- Indent_Annull -- | |
393 | ------------------- | |
394 | ||
395 | procedure Indent_Annull is | |
396 | begin | |
397 | Indent_Annull_Flag := True; | |
398 | end Indent_Annull; | |
399 | ||
400 | ------------------ | |
401 | -- Indent_Begin -- | |
402 | ------------------ | |
403 | ||
404 | procedure Indent_Begin is | |
405 | begin | |
406 | Indent := Indent + 3; | |
407 | end Indent_Begin; | |
408 | ||
409 | ---------------- | |
410 | -- Indent_End -- | |
411 | ---------------- | |
412 | ||
413 | procedure Indent_End is | |
414 | begin | |
415 | Indent := Indent - 3; | |
416 | end Indent_End; | |
417 | ||
418 | -------- | |
07fc65c4 | 419 | -- pg -- |
996ae0b0 RK |
420 | -------- |
421 | ||
0c1edb56 | 422 | procedure pg (Arg : Union_Id) is |
996ae0b0 RK |
423 | begin |
424 | Dump_Generated_Only := True; | |
2287a75d AC |
425 | Dump_Original_Only := False; |
426 | Dump_Freeze_Null := True; | |
39485a7b | 427 | Current_Source_File := No_Source_File; |
0c1edb56 ES |
428 | |
429 | if Arg in List_Range then | |
3ffd18f1 | 430 | Sprint_Node_List (List_Id (Arg), New_Lines => True); |
0c1edb56 ES |
431 | |
432 | elsif Arg in Node_Range then | |
433 | Sprint_Node (Node_Id (Arg)); | |
434 | ||
435 | else | |
436 | null; | |
437 | end if; | |
438 | ||
07fc65c4 GB |
439 | Write_Eol; |
440 | end pg; | |
996ae0b0 RK |
441 | |
442 | -------- | |
07fc65c4 | 443 | -- po -- |
996ae0b0 RK |
444 | -------- |
445 | ||
0c1edb56 | 446 | procedure po (Arg : Union_Id) is |
996ae0b0 RK |
447 | begin |
448 | Dump_Generated_Only := False; | |
449 | Dump_Original_Only := True; | |
39485a7b | 450 | Current_Source_File := No_Source_File; |
0c1edb56 ES |
451 | |
452 | if Arg in List_Range then | |
3ffd18f1 | 453 | Sprint_Node_List (List_Id (Arg), New_Lines => True); |
0c1edb56 ES |
454 | |
455 | elsif Arg in Node_Range then | |
456 | Sprint_Node (Node_Id (Arg)); | |
457 | ||
458 | else | |
459 | null; | |
460 | end if; | |
461 | ||
07fc65c4 GB |
462 | Write_Eol; |
463 | end po; | |
996ae0b0 | 464 | |
07fc65c4 GB |
465 | ---------------------- |
466 | -- Print_Debug_Line -- | |
467 | ---------------------- | |
996ae0b0 | 468 | |
07fc65c4 | 469 | procedure Print_Debug_Line (S : String) is |
996ae0b0 | 470 | begin |
07fc65c4 GB |
471 | Write_Debug_Line (S, Debug_Sloc); |
472 | end Print_Debug_Line; | |
996ae0b0 RK |
473 | |
474 | --------------------------- | |
475 | -- Process_TFAI_RR_Flags -- | |
476 | --------------------------- | |
477 | ||
478 | procedure Process_TFAI_RR_Flags (Nod : Node_Id) is | |
479 | begin | |
480 | if Treat_Fixed_As_Integer (Nod) then | |
481 | Write_Char ('#'); | |
482 | end if; | |
483 | ||
484 | if Rounded_Result (Nod) then | |
485 | Write_Char ('@'); | |
486 | end if; | |
487 | end Process_TFAI_RR_Flags; | |
488 | ||
489 | -------- | |
07fc65c4 | 490 | -- ps -- |
996ae0b0 RK |
491 | -------- |
492 | ||
0c1edb56 | 493 | procedure ps (Arg : Union_Id) is |
996ae0b0 RK |
494 | begin |
495 | Dump_Generated_Only := False; | |
496 | Dump_Original_Only := False; | |
39485a7b | 497 | Current_Source_File := No_Source_File; |
0c1edb56 ES |
498 | |
499 | if Arg in List_Range then | |
3ffd18f1 | 500 | Sprint_Node_List (List_Id (Arg), New_Lines => True); |
0c1edb56 ES |
501 | |
502 | elsif Arg in Node_Range then | |
503 | Sprint_Node (Node_Id (Arg)); | |
504 | ||
505 | else | |
506 | null; | |
507 | end if; | |
508 | ||
07fc65c4 GB |
509 | Write_Eol; |
510 | end ps; | |
996ae0b0 RK |
511 | |
512 | -------------------- | |
513 | -- Set_Debug_Sloc -- | |
514 | -------------------- | |
515 | ||
516 | procedure Set_Debug_Sloc is | |
517 | begin | |
39485a7b | 518 | if Debug_Generated_Code and then Present (Dump_Node) then |
d3e16619 AC |
519 | declare |
520 | Loc : constant Source_Ptr := Sloc (Dump_Node); | |
521 | ||
522 | begin | |
523 | -- Do not change the location of nodes defined in package Standard | |
524 | -- and nodes of pragmas scanned by Targparm. | |
525 | ||
526 | if Loc <= Standard_Location then | |
527 | null; | |
528 | ||
529 | -- Update the location of a node which is part of the current .dg | |
530 | -- output. This situation occurs in comma separated parameter | |
531 | -- declarations since each parameter references the same parameter | |
532 | -- type node (ie. obj1, obj2 : <param-type>). | |
533 | ||
534 | -- Note: This case is needed here since we cannot use the routine | |
535 | -- In_Extended_Main_Code_Unit with nodes whose location is a .dg | |
536 | -- file. | |
537 | ||
538 | elsif Loc >= First_Debug_Sloc then | |
539 | Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); | |
540 | ||
541 | -- Do not change the location of nodes which are not part of the | |
542 | -- generated code | |
543 | ||
544 | elsif not In_Extended_Main_Code_Unit (Loc) then | |
545 | null; | |
546 | ||
547 | else | |
548 | Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); | |
549 | end if; | |
550 | end; | |
b6c8e5be AC |
551 | |
552 | -- We do not know the actual end location in the generated code and | |
553 | -- it could be much closer than in the source code, so play safe. | |
554 | ||
555 | if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then | |
556 | Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); | |
557 | end if; | |
558 | ||
39485a7b | 559 | Dump_Node := Empty; |
996ae0b0 RK |
560 | end if; |
561 | end Set_Debug_Sloc; | |
562 | ||
563 | ----------------- | |
564 | -- Source_Dump -- | |
565 | ----------------- | |
566 | ||
567 | procedure Source_Dump is | |
568 | ||
569 | procedure Underline; | |
570 | -- Put underline under string we just printed | |
571 | ||
39485a7b ES |
572 | --------------- |
573 | -- Underline -- | |
574 | --------------- | |
575 | ||
996ae0b0 RK |
576 | procedure Underline is |
577 | Col : constant Int := Column; | |
578 | ||
579 | begin | |
07fc65c4 | 580 | Write_Eol; |
996ae0b0 RK |
581 | |
582 | while Col > Column loop | |
583 | Write_Char ('-'); | |
584 | end loop; | |
585 | ||
07fc65c4 | 586 | Write_Eol; |
996ae0b0 RK |
587 | end Underline; |
588 | ||
6a2afd13 | 589 | -- Start of processing for Source_Dump |
996ae0b0 RK |
590 | |
591 | begin | |
592 | Dump_Generated_Only := Debug_Flag_G or | |
593 | Print_Generated_Code or | |
594 | Debug_Generated_Code; | |
595 | Dump_Original_Only := Debug_Flag_O; | |
596 | Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G; | |
597 | ||
598 | -- Note that we turn off the tree dump flags immediately, before | |
599 | -- starting the dump. This avoids generating two copies of the dump | |
600 | -- if an abort occurs after printing the dump, and more importantly, | |
601 | -- avoids an infinite loop if an abort occurs during the dump. | |
602 | ||
603 | if Debug_Flag_Z then | |
39485a7b | 604 | Current_Source_File := No_Source_File; |
996ae0b0 | 605 | Debug_Flag_Z := False; |
07fc65c4 GB |
606 | Write_Eol; |
607 | Write_Eol; | |
996ae0b0 RK |
608 | Write_Str ("Source recreated from tree of Standard (spec)"); |
609 | Underline; | |
610 | Sprint_Node (Standard_Package_Node); | |
07fc65c4 GB |
611 | Write_Eol; |
612 | Write_Eol; | |
996ae0b0 RK |
613 | end if; |
614 | ||
615 | if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then | |
616 | Debug_Flag_G := False; | |
617 | Debug_Flag_O := False; | |
618 | Debug_Flag_S := False; | |
d3e16619 | 619 | First_Debug_Sloc := No_Location; |
996ae0b0 RK |
620 | |
621 | -- Dump requested units | |
622 | ||
623 | for U in Main_Unit .. Last_Unit loop | |
39485a7b | 624 | Current_Source_File := Source_Index (U); |
996ae0b0 | 625 | |
57d22af2 AC |
626 | -- Dump all units if -gnatdf set, otherwise dump only the source |
627 | -- files that are in the extended main source. Note that, if we | |
628 | -- are generating debug files, generating that of the main unit | |
629 | -- has an effect on the outcome of In_Extended_Main_Source_Unit | |
630 | -- because slocs are rewritten, so we also test for equality of | |
631 | -- Cunit_Entity to work around this effect. | |
996ae0b0 RK |
632 | |
633 | if Debug_Flag_F | |
634 | or else In_Extended_Main_Source_Unit (Cunit_Entity (U)) | |
57d22af2 | 635 | or else Cunit_Entity (U) = Cunit_Entity (Main_Unit) |
996ae0b0 RK |
636 | then |
637 | -- If we are generating debug files, setup to write them | |
638 | ||
639 | if Debug_Generated_Code then | |
07fc65c4 | 640 | Set_Special_Output (Print_Debug_Line'Access); |
996ae0b0 | 641 | Create_Debug_Source (Source_Index (U), Debug_Sloc); |
d3e16619 | 642 | First_Debug_Sloc := Debug_Sloc; |
39485a7b ES |
643 | Write_Source_Line (1); |
644 | Last_Line_Printed := 1; | |
57d22af2 AC |
645 | |
646 | -- If this unit has the same entity as the main unit, for | |
647 | -- example is the spec of a stand-alone instantiation of | |
648 | -- a package and the main unit is the body, its debug file | |
649 | -- will also be the same. Therefore, we need to print again | |
650 | -- the main unit to have both units in the debug file. | |
651 | ||
652 | if U /= Main_Unit | |
653 | and then Cunit_Entity (U) = Cunit_Entity (Main_Unit) | |
654 | then | |
655 | Sprint_Node (Cunit (Main_Unit)); | |
656 | Write_Eol; | |
657 | end if; | |
658 | ||
996ae0b0 | 659 | Sprint_Node (Cunit (U)); |
39485a7b | 660 | Write_Source_Lines (Last_Source_Line (Current_Source_File)); |
07fc65c4 | 661 | Write_Eol; |
996ae0b0 | 662 | Close_Debug_Source; |
e3548b69 | 663 | Cancel_Special_Output; |
996ae0b0 RK |
664 | |
665 | -- Normal output to standard output file | |
666 | ||
667 | else | |
668 | Write_Str ("Source recreated from tree for "); | |
669 | Write_Unit_Name (Unit_Name (U)); | |
670 | Underline; | |
39485a7b ES |
671 | Write_Source_Line (1); |
672 | Last_Line_Printed := 1; | |
996ae0b0 | 673 | Sprint_Node (Cunit (U)); |
39485a7b | 674 | Write_Source_Lines (Last_Source_Line (Current_Source_File)); |
996ae0b0 RK |
675 | Write_Eol; |
676 | Write_Eol; | |
677 | end if; | |
678 | end if; | |
679 | end loop; | |
680 | end if; | |
681 | end Source_Dump; | |
682 | ||
edd63e9b ES |
683 | --------------------- |
684 | -- Sprint_And_List -- | |
685 | --------------------- | |
686 | ||
687 | procedure Sprint_And_List (List : List_Id) is | |
688 | Node : Node_Id; | |
689 | begin | |
690 | if Is_Non_Empty_List (List) then | |
691 | Node := First (List); | |
692 | loop | |
693 | Sprint_Node (Node); | |
694 | Next (Node); | |
695 | exit when Node = Empty; | |
696 | Write_Str (" and "); | |
697 | end loop; | |
698 | end if; | |
699 | end Sprint_And_List; | |
700 | ||
0f1a6a0b AC |
701 | ---------------------------------- |
702 | -- Sprint_Aspect_Specifications -- | |
703 | ---------------------------------- | |
704 | ||
1c54829e AC |
705 | procedure Sprint_Aspect_Specifications |
706 | (Node : Node_Id; | |
707 | Semicolon : Boolean) | |
708 | is | |
c159409f | 709 | AS : constant List_Id := Aspect_Specifications (Node); |
0f1a6a0b AC |
710 | A : Node_Id; |
711 | ||
712 | begin | |
1c54829e AC |
713 | if Semicolon then |
714 | Write_Erase_Char (';'); | |
715 | Indent := Indent + 2; | |
716 | Write_Indent; | |
717 | Write_Str ("with "); | |
718 | Indent := Indent + 5; | |
719 | ||
720 | else | |
721 | Write_Str (" with "); | |
722 | end if; | |
c159409f AC |
723 | |
724 | A := First (AS); | |
725 | loop | |
726 | Sprint_Node (Identifier (A)); | |
727 | ||
728 | if Class_Present (A) then | |
729 | Write_Str ("'Class"); | |
730 | end if; | |
0f1a6a0b | 731 | |
c159409f AC |
732 | if Present (Expression (A)) then |
733 | Write_Str (" => "); | |
734 | Sprint_Node (Expression (A)); | |
735 | end if; | |
0f1a6a0b | 736 | |
c159409f | 737 | Next (A); |
0f1a6a0b | 738 | |
c159409f AC |
739 | exit when No (A); |
740 | Write_Char (','); | |
1c54829e AC |
741 | |
742 | if Semicolon then | |
743 | Write_Indent; | |
744 | end if; | |
c159409f | 745 | end loop; |
0f1a6a0b | 746 | |
1c54829e AC |
747 | if Semicolon then |
748 | Indent := Indent - 7; | |
749 | Write_Char (';'); | |
750 | end if; | |
0f1a6a0b AC |
751 | end Sprint_Aspect_Specifications; |
752 | ||
996ae0b0 RK |
753 | --------------------- |
754 | -- Sprint_Bar_List -- | |
755 | --------------------- | |
756 | ||
757 | procedure Sprint_Bar_List (List : List_Id) is | |
758 | Node : Node_Id; | |
996ae0b0 RK |
759 | begin |
760 | if Is_Non_Empty_List (List) then | |
761 | Node := First (List); | |
996ae0b0 RK |
762 | loop |
763 | Sprint_Node (Node); | |
764 | Next (Node); | |
765 | exit when Node = Empty; | |
766 | Write_Str (" | "); | |
767 | end loop; | |
768 | end if; | |
769 | end Sprint_Bar_List; | |
770 | ||
0c1edb56 ES |
771 | ---------------------- |
772 | -- Sprint_End_Label -- | |
773 | ---------------------- | |
774 | ||
775 | procedure Sprint_End_Label | |
776 | (Node : Node_Id; | |
777 | Default : Node_Id) | |
778 | is | |
779 | begin | |
780 | if Present (Node) | |
781 | and then Present (End_Label (Node)) | |
782 | and then Is_Entity_Name (End_Label (Node)) | |
783 | then | |
784 | Set_Entity (End_Label (Node), Default); | |
785 | ||
786 | -- For a function whose name is an operator, use the qualified name | |
787 | -- created for the defining entity. | |
788 | ||
789 | if Nkind (End_Label (Node)) = N_Operator_Symbol then | |
790 | Set_Chars (End_Label (Node), Chars (Default)); | |
791 | end if; | |
792 | ||
793 | Sprint_Node (End_Label (Node)); | |
794 | else | |
795 | Sprint_Node (Default); | |
796 | end if; | |
797 | end Sprint_End_Label; | |
798 | ||
996ae0b0 RK |
799 | ----------------------- |
800 | -- Sprint_Comma_List -- | |
801 | ----------------------- | |
802 | ||
803 | procedure Sprint_Comma_List (List : List_Id) is | |
804 | Node : Node_Id; | |
805 | ||
806 | begin | |
807 | if Is_Non_Empty_List (List) then | |
808 | Node := First (List); | |
996ae0b0 RK |
809 | loop |
810 | Sprint_Node (Node); | |
811 | Next (Node); | |
812 | exit when Node = Empty; | |
813 | ||
814 | if not Is_Rewrite_Insertion (Node) | |
815 | or else not Dump_Original_Only | |
816 | then | |
817 | Write_Str (", "); | |
818 | end if; | |
996ae0b0 RK |
819 | end loop; |
820 | end if; | |
821 | end Sprint_Comma_List; | |
822 | ||
823 | -------------------------- | |
824 | -- Sprint_Indented_List -- | |
825 | -------------------------- | |
826 | ||
827 | procedure Sprint_Indented_List (List : List_Id) is | |
828 | begin | |
829 | Indent_Begin; | |
830 | Sprint_Node_List (List); | |
831 | Indent_End; | |
832 | end Sprint_Indented_List; | |
833 | ||
07fc65c4 GB |
834 | --------------------- |
835 | -- Sprint_Left_Opnd -- | |
836 | --------------------- | |
837 | ||
838 | procedure Sprint_Left_Opnd (N : Node_Id) is | |
839 | Opnd : constant Node_Id := Left_Opnd (N); | |
840 | ||
841 | begin | |
842 | if Paren_Count (Opnd) /= 0 | |
843 | or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N)) | |
844 | then | |
845 | Sprint_Node (Opnd); | |
846 | ||
847 | else | |
848 | Write_Char ('('); | |
849 | Sprint_Node (Opnd); | |
850 | Write_Char (')'); | |
851 | end if; | |
852 | end Sprint_Left_Opnd; | |
853 | ||
996ae0b0 RK |
854 | ----------------- |
855 | -- Sprint_Node -- | |
856 | ----------------- | |
857 | ||
858 | procedure Sprint_Node (Node : Node_Id) is | |
859 | begin | |
860 | if Is_Rewrite_Insertion (Node) then | |
861 | if not Dump_Original_Only then | |
862 | ||
863 | -- For special cases of nodes that always output <<< >>> | |
864 | -- do not duplicate the output at this point. | |
865 | ||
866 | if Nkind (Node) = N_Freeze_Entity | |
3cd4a210 | 867 | or else Nkind (Node) = N_Freeze_Generic_Entity |
996ae0b0 RK |
868 | or else Nkind (Node) = N_Implicit_Label_Declaration |
869 | then | |
870 | Sprint_Node_Actual (Node); | |
871 | ||
872 | -- Normal case where <<< >>> may be required | |
873 | ||
874 | else | |
875 | Write_Rewrite_Str ("<<<"); | |
876 | Sprint_Node_Actual (Node); | |
877 | Write_Rewrite_Str (">>>"); | |
878 | end if; | |
879 | end if; | |
880 | ||
881 | elsif Is_Rewrite_Substitution (Node) then | |
882 | ||
883 | -- Case of dump generated only | |
884 | ||
885 | if Dump_Generated_Only then | |
886 | Sprint_Node_Actual (Node); | |
887 | ||
888 | -- Case of dump original only | |
889 | ||
890 | elsif Dump_Original_Only then | |
891 | Sprint_Node_Actual (Original_Node (Node)); | |
892 | ||
893 | -- Case of both being dumped | |
894 | ||
895 | else | |
896 | Sprint_Node_Actual (Original_Node (Node)); | |
897 | Write_Rewrite_Str ("<<<"); | |
898 | Sprint_Node_Actual (Node); | |
899 | Write_Rewrite_Str (">>>"); | |
900 | end if; | |
901 | ||
902 | else | |
903 | Sprint_Node_Actual (Node); | |
904 | end if; | |
905 | end Sprint_Node; | |
906 | ||
907 | ------------------------ | |
908 | -- Sprint_Node_Actual -- | |
909 | ------------------------ | |
910 | ||
911 | procedure Sprint_Node_Actual (Node : Node_Id) is | |
39485a7b | 912 | Save_Dump_Node : constant Node_Id := Dump_Node; |
996ae0b0 RK |
913 | |
914 | begin | |
915 | if Node = Empty then | |
916 | return; | |
917 | end if; | |
918 | ||
919 | for J in 1 .. Paren_Count (Node) loop | |
920 | Write_Str_With_Col_Check ("("); | |
921 | end loop; | |
922 | ||
39485a7b | 923 | -- Setup current dump node |
996ae0b0 | 924 | |
39485a7b | 925 | Dump_Node := Node; |
996ae0b0 RK |
926 | |
927 | if Nkind (Node) in N_Subexpr | |
928 | and then Do_Range_Check (Node) | |
929 | then | |
930 | Write_Str_With_Col_Check ("{"); | |
931 | end if; | |
932 | ||
933 | -- Select print circuit based on node kind | |
934 | ||
935 | case Nkind (Node) is | |
996ae0b0 RK |
936 | when N_Abort_Statement => |
937 | Write_Indent_Str_Sloc ("abort "); | |
938 | Sprint_Comma_List (Names (Node)); | |
939 | Write_Char (';'); | |
940 | ||
941 | when N_Abortable_Part => | |
942 | Set_Debug_Sloc; | |
943 | Write_Str_Sloc ("abort "); | |
944 | Sprint_Indented_List (Statements (Node)); | |
945 | ||
946 | when N_Abstract_Subprogram_Declaration => | |
947 | Write_Indent; | |
948 | Sprint_Node (Specification (Node)); | |
949 | Write_Str_With_Col_Check (" is "); | |
c159409f | 950 | Write_Str_Sloc ("abstract;"); |
996ae0b0 RK |
951 | |
952 | when N_Accept_Alternative => | |
953 | Sprint_Node_List (Pragmas_Before (Node)); | |
954 | ||
955 | if Present (Condition (Node)) then | |
956 | Write_Indent_Str ("when "); | |
957 | Sprint_Node (Condition (Node)); | |
958 | Write_Str (" => "); | |
959 | Indent_Annull; | |
960 | end if; | |
961 | ||
962 | Sprint_Node_Sloc (Accept_Statement (Node)); | |
963 | Sprint_Node_List (Statements (Node)); | |
964 | ||
965 | when N_Accept_Statement => | |
966 | Write_Indent_Str_Sloc ("accept "); | |
967 | Write_Id (Entry_Direct_Name (Node)); | |
968 | ||
969 | if Present (Entry_Index (Node)) then | |
970 | Write_Str_With_Col_Check (" ("); | |
971 | Sprint_Node (Entry_Index (Node)); | |
972 | Write_Char (')'); | |
973 | end if; | |
974 | ||
975 | Write_Param_Specs (Node); | |
976 | ||
977 | if Present (Handled_Statement_Sequence (Node)) then | |
978 | Write_Str_With_Col_Check (" do"); | |
979 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
980 | Write_Indent_Str ("end "); | |
981 | Write_Id (Entry_Direct_Name (Node)); | |
982 | end if; | |
983 | ||
984 | Write_Char (';'); | |
985 | ||
986 | when N_Access_Definition => | |
2820d220 | 987 | |
0ab80019 | 988 | -- Ada 2005 (AI-254) |
2820d220 | 989 | |
7324bf49 AC |
990 | if Present (Access_To_Subprogram_Definition (Node)) then |
991 | Sprint_Node (Access_To_Subprogram_Definition (Node)); | |
992 | else | |
0ab80019 | 993 | -- Ada 2005 (AI-231) |
2820d220 | 994 | |
7324bf49 AC |
995 | if Null_Exclusion_Present (Node) then |
996 | Write_Str ("not null "); | |
997 | end if; | |
998 | ||
999 | Write_Str_With_Col_Check_Sloc ("access "); | |
1000 | ||
1001 | if All_Present (Node) then | |
1002 | Write_Str ("all "); | |
1003 | elsif Constant_Present (Node) then | |
1004 | Write_Str ("constant "); | |
1005 | end if; | |
1006 | ||
1007 | Sprint_Node (Subtype_Mark (Node)); | |
1008 | end if; | |
996ae0b0 RK |
1009 | |
1010 | when N_Access_Function_Definition => | |
2820d220 | 1011 | |
0ab80019 | 1012 | -- Ada 2005 (AI-231) |
2820d220 AC |
1013 | |
1014 | if Null_Exclusion_Present (Node) then | |
1015 | Write_Str ("not null "); | |
1016 | end if; | |
1017 | ||
996ae0b0 RK |
1018 | Write_Str_With_Col_Check_Sloc ("access "); |
1019 | ||
1020 | if Protected_Present (Node) then | |
1021 | Write_Str_With_Col_Check ("protected "); | |
1022 | end if; | |
1023 | ||
1024 | Write_Str_With_Col_Check ("function"); | |
1025 | Write_Param_Specs (Node); | |
1026 | Write_Str_With_Col_Check (" return "); | |
244480db | 1027 | Sprint_Node (Result_Definition (Node)); |
996ae0b0 RK |
1028 | |
1029 | when N_Access_Procedure_Definition => | |
0ab80019 AC |
1030 | |
1031 | -- Ada 2005 (AI-231) | |
2820d220 AC |
1032 | |
1033 | if Null_Exclusion_Present (Node) then | |
1034 | Write_Str ("not null "); | |
1035 | end if; | |
1036 | ||
996ae0b0 RK |
1037 | Write_Str_With_Col_Check_Sloc ("access "); |
1038 | ||
1039 | if Protected_Present (Node) then | |
1040 | Write_Str_With_Col_Check ("protected "); | |
1041 | end if; | |
1042 | ||
1043 | Write_Str_With_Col_Check ("procedure"); | |
1044 | Write_Param_Specs (Node); | |
1045 | ||
1046 | when N_Access_To_Object_Definition => | |
1047 | Write_Str_With_Col_Check_Sloc ("access "); | |
1048 | ||
1049 | if All_Present (Node) then | |
1050 | Write_Str_With_Col_Check ("all "); | |
1051 | elsif Constant_Present (Node) then | |
1052 | Write_Str_With_Col_Check ("constant "); | |
1053 | end if; | |
1054 | ||
0ab80019 | 1055 | -- Ada 2005 (AI-231) |
2820d220 AC |
1056 | |
1057 | if Null_Exclusion_Present (Node) then | |
1058 | Write_Str ("not null "); | |
1059 | end if; | |
1060 | ||
996ae0b0 RK |
1061 | Sprint_Node (Subtype_Indication (Node)); |
1062 | ||
1063 | when N_Aggregate => | |
1064 | if Null_Record_Present (Node) then | |
1065 | Write_Str_With_Col_Check_Sloc ("(null record)"); | |
1066 | ||
1067 | else | |
1068 | Write_Str_With_Col_Check_Sloc ("("); | |
1069 | ||
1070 | if Present (Expressions (Node)) then | |
1071 | Sprint_Comma_List (Expressions (Node)); | |
1072 | ||
9013065b AC |
1073 | if Present (Component_Associations (Node)) |
1074 | and then not Is_Empty_List (Component_Associations (Node)) | |
1075 | then | |
996ae0b0 RK |
1076 | Write_Str (", "); |
1077 | end if; | |
1078 | end if; | |
1079 | ||
9013065b AC |
1080 | if Present (Component_Associations (Node)) |
1081 | and then not Is_Empty_List (Component_Associations (Node)) | |
1082 | then | |
996ae0b0 RK |
1083 | Indent_Begin; |
1084 | ||
1085 | declare | |
1086 | Nd : Node_Id; | |
1087 | ||
1088 | begin | |
1089 | Nd := First (Component_Associations (Node)); | |
1090 | ||
1091 | loop | |
1092 | Write_Indent; | |
1093 | Sprint_Node (Nd); | |
1094 | Next (Nd); | |
1095 | exit when No (Nd); | |
1096 | ||
1097 | if not Is_Rewrite_Insertion (Nd) | |
1098 | or else not Dump_Original_Only | |
1099 | then | |
1100 | Write_Str (", "); | |
1101 | end if; | |
1102 | end loop; | |
1103 | end; | |
1104 | ||
1105 | Indent_End; | |
1106 | end if; | |
1107 | ||
1108 | Write_Char (')'); | |
1109 | end if; | |
1110 | ||
1111 | when N_Allocator => | |
1112 | Write_Str_With_Col_Check_Sloc ("new "); | |
0ab80019 AC |
1113 | |
1114 | -- Ada 2005 (AI-231) | |
2820d220 AC |
1115 | |
1116 | if Null_Exclusion_Present (Node) then | |
1117 | Write_Str ("not null "); | |
1118 | end if; | |
1119 | ||
996ae0b0 RK |
1120 | Sprint_Node (Expression (Node)); |
1121 | ||
1122 | if Present (Storage_Pool (Node)) then | |
1123 | Write_Str_With_Col_Check ("[storage_pool = "); | |
1124 | Sprint_Node (Storage_Pool (Node)); | |
1125 | Write_Char (']'); | |
1126 | end if; | |
1127 | ||
1128 | when N_And_Then => | |
07fc65c4 | 1129 | Sprint_Left_Opnd (Node); |
996ae0b0 | 1130 | Write_Str_Sloc (" and then "); |
07fc65c4 | 1131 | Sprint_Right_Opnd (Node); |
996ae0b0 | 1132 | |
19fb051c AC |
1133 | -- Note: the following code for N_Aspect_Specification is not |
1134 | -- normally used, since we deal with aspects as part of a | |
1135 | -- declaration, but it is here in case we deliberately try | |
1136 | -- to print an N_Aspect_Speficiation node (e.g. from GDB). | |
1137 | ||
313d6f2c | 1138 | when N_Aspect_Specification => |
19fb051c AC |
1139 | Sprint_Node (Identifier (Node)); |
1140 | Write_Str (" => "); | |
1141 | Sprint_Node (Expression (Node)); | |
996ae0b0 RK |
1142 | |
1143 | when N_Assignment_Statement => | |
1144 | Write_Indent; | |
1145 | Sprint_Node (Name (Node)); | |
1146 | Write_Str_Sloc (" := "); | |
1147 | Sprint_Node (Expression (Node)); | |
1148 | Write_Char (';'); | |
1149 | ||
1150 | when N_Asynchronous_Select => | |
1151 | Write_Indent_Str_Sloc ("select"); | |
1152 | Indent_Begin; | |
1153 | Sprint_Node (Triggering_Alternative (Node)); | |
1154 | Indent_End; | |
1155 | ||
1156 | -- Note: let the printing of Abortable_Part handle outputting | |
3354f96d | 1157 | -- the ABORT keyword, so that the Sloc can be set correctly. |
996ae0b0 RK |
1158 | |
1159 | Write_Indent_Str ("then "); | |
1160 | Sprint_Node (Abortable_Part (Node)); | |
1161 | Write_Indent_Str ("end select;"); | |
1162 | ||
313d6f2c AC |
1163 | when N_At_Clause => |
1164 | Write_Indent_Str_Sloc ("for "); | |
1165 | Write_Id (Identifier (Node)); | |
1166 | Write_Str_With_Col_Check (" use at "); | |
1167 | Sprint_Node (Expression (Node)); | |
1168 | Write_Char (';'); | |
1169 | ||
996ae0b0 RK |
1170 | when N_Attribute_Definition_Clause => |
1171 | Write_Indent_Str_Sloc ("for "); | |
1172 | Sprint_Node (Name (Node)); | |
1173 | Write_Char ('''); | |
1174 | Write_Name_With_Col_Check (Chars (Node)); | |
1175 | Write_Str_With_Col_Check (" use "); | |
1176 | Sprint_Node (Expression (Node)); | |
1177 | Write_Char (';'); | |
1178 | ||
1179 | when N_Attribute_Reference => | |
1180 | if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then | |
1181 | Write_Indent; | |
1182 | end if; | |
1183 | ||
1184 | Sprint_Node (Prefix (Node)); | |
1185 | Write_Char_Sloc ('''); | |
1186 | Write_Name_With_Col_Check (Attribute_Name (Node)); | |
1187 | Sprint_Paren_Comma_List (Expressions (Node)); | |
1188 | ||
1189 | if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then | |
1190 | Write_Char (';'); | |
1191 | end if; | |
1192 | ||
1193 | when N_Block_Statement => | |
1194 | Write_Indent; | |
1195 | ||
1196 | if Present (Identifier (Node)) | |
1197 | and then (not Has_Created_Identifier (Node) | |
ebdaa81b | 1198 | or else not Dump_Original_Only) |
996ae0b0 RK |
1199 | then |
1200 | Write_Rewrite_Str ("<<<"); | |
1201 | Write_Id (Identifier (Node)); | |
1202 | Write_Str (" : "); | |
1203 | Write_Rewrite_Str (">>>"); | |
1204 | end if; | |
1205 | ||
1206 | if Present (Declarations (Node)) then | |
1207 | Write_Str_With_Col_Check_Sloc ("declare"); | |
1208 | Sprint_Indented_List (Declarations (Node)); | |
1209 | Write_Indent; | |
1210 | end if; | |
1211 | ||
1212 | Write_Str_With_Col_Check_Sloc ("begin"); | |
1213 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
1214 | Write_Indent_Str ("end"); | |
1215 | ||
1216 | if Present (Identifier (Node)) | |
1217 | and then (not Has_Created_Identifier (Node) | |
1218 | or else not Dump_Original_Only) | |
1219 | then | |
1220 | Write_Rewrite_Str ("<<<"); | |
1221 | Write_Char (' '); | |
1222 | Write_Id (Identifier (Node)); | |
1223 | Write_Rewrite_Str (">>>"); | |
1224 | end if; | |
1225 | ||
1226 | Write_Char (';'); | |
1227 | ||
90e491a7 PMR |
1228 | when N_Call_Marker => |
1229 | null; | |
1230 | ||
1231 | -- Enable the following code for debugging purposes only | |
1232 | ||
1233 | -- Write_Indent_Str ("#"); | |
1234 | -- Write_Id (Target (Node)); | |
1235 | -- Write_Char ('#'); | |
1236 | ||
19d846a0 RD |
1237 | when N_Case_Expression => |
1238 | declare | |
8ed7930e AC |
1239 | Has_Parens : constant Boolean := Paren_Count (Node) > 0; |
1240 | Alt : Node_Id; | |
19d846a0 RD |
1241 | |
1242 | begin | |
a53c5613 AC |
1243 | -- The syntax for case_expression does not include parentheses, |
1244 | -- but sometimes parentheses are required, so unconditionally | |
8ed7930e | 1245 | -- generate them here unless already present. |
a53c5613 | 1246 | |
8ed7930e AC |
1247 | if not Has_Parens then |
1248 | Write_Char ('('); | |
1249 | end if; | |
1250 | ||
1251 | Write_Str_With_Col_Check_Sloc ("case "); | |
19d846a0 RD |
1252 | Sprint_Node (Expression (Node)); |
1253 | Write_Str_With_Col_Check (" is"); | |
1254 | ||
1255 | Alt := First (Alternatives (Node)); | |
1256 | loop | |
1257 | Sprint_Node (Alt); | |
1258 | Next (Alt); | |
1259 | exit when No (Alt); | |
1260 | Write_Char (','); | |
1261 | end loop; | |
1262 | ||
8ed7930e AC |
1263 | if not Has_Parens then |
1264 | Write_Char (')'); | |
1265 | end if; | |
19d846a0 RD |
1266 | end; |
1267 | ||
1268 | when N_Case_Expression_Alternative => | |
1269 | Write_Str_With_Col_Check (" when "); | |
1270 | Sprint_Bar_List (Discrete_Choices (Node)); | |
1271 | Write_Str (" => "); | |
1272 | Sprint_Node (Expression (Node)); | |
1273 | ||
996ae0b0 RK |
1274 | when N_Case_Statement => |
1275 | Write_Indent_Str_Sloc ("case "); | |
1276 | Sprint_Node (Expression (Node)); | |
1277 | Write_Str (" is"); | |
1278 | Sprint_Indented_List (Alternatives (Node)); | |
1279 | Write_Indent_Str ("end case;"); | |
1280 | ||
1281 | when N_Case_Statement_Alternative => | |
1282 | Write_Indent_Str_Sloc ("when "); | |
1283 | Sprint_Bar_List (Discrete_Choices (Node)); | |
1284 | Write_Str (" => "); | |
1285 | Sprint_Indented_List (Statements (Node)); | |
1286 | ||
1287 | when N_Character_Literal => | |
dcd8728b | 1288 | if Column > Sprint_Line_Limit - 2 then |
996ae0b0 RK |
1289 | Write_Indent_Str (" "); |
1290 | end if; | |
1291 | ||
1292 | Write_Char_Sloc ('''); | |
82c80734 | 1293 | Write_Char_Code (UI_To_CC (Char_Literal_Value (Node))); |
996ae0b0 RK |
1294 | Write_Char ('''); |
1295 | ||
1296 | when N_Code_Statement => | |
1297 | Write_Indent; | |
1298 | Set_Debug_Sloc; | |
1299 | Sprint_Node (Expression (Node)); | |
1300 | Write_Char (';'); | |
1301 | ||
1302 | when N_Compilation_Unit => | |
1303 | Sprint_Node_List (Context_Items (Node)); | |
1304 | Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node))); | |
1305 | ||
1306 | if Private_Present (Node) then | |
1307 | Write_Indent_Str ("private "); | |
1308 | Indent_Annull; | |
1309 | end if; | |
1310 | ||
1311 | Sprint_Node_Sloc (Unit (Node)); | |
1312 | ||
1313 | if Present (Actions (Aux_Decls_Node (Node))) | |
1314 | or else | |
1315 | Present (Pragmas_After (Aux_Decls_Node (Node))) | |
1316 | then | |
1317 | Write_Indent; | |
1318 | end if; | |
1319 | ||
1320 | Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node))); | |
1321 | Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node))); | |
1322 | ||
1323 | when N_Compilation_Unit_Aux => | |
1324 | null; -- nothing to do, never used, see above | |
1325 | ||
1326 | when N_Component_Association => | |
1327 | Set_Debug_Sloc; | |
1328 | Sprint_Bar_List (Choices (Node)); | |
1329 | Write_Str (" => "); | |
d05ef0ab | 1330 | |
62b80eaf | 1331 | -- Ada 2005 (AI-287): Print the box if present |
19f0526a | 1332 | |
65356e64 AC |
1333 | if Box_Present (Node) then |
1334 | Write_Str_With_Col_Check ("<>"); | |
1335 | else | |
1336 | Sprint_Node (Expression (Node)); | |
1337 | end if; | |
996ae0b0 | 1338 | |
a702c9b9 ES |
1339 | when N_Iterated_Component_Association => |
1340 | Set_Debug_Sloc; | |
1341 | Write_Str (" for "); | |
1342 | Write_Id (Defining_Identifier (Node)); | |
1343 | Write_Str (" in "); | |
ef74daea | 1344 | Sprint_Bar_List (Discrete_Choices (Node)); |
a702c9b9 ES |
1345 | Write_Str (" => "); |
1346 | Sprint_Node (Expression (Node)); | |
1347 | ||
996ae0b0 RK |
1348 | when N_Component_Clause => |
1349 | Write_Indent; | |
1350 | Sprint_Node (Component_Name (Node)); | |
1351 | Write_Str_Sloc (" at "); | |
1352 | Sprint_Node (Position (Node)); | |
1353 | Write_Char (' '); | |
1354 | Write_Str_With_Col_Check ("range "); | |
1355 | Sprint_Node (First_Bit (Node)); | |
1356 | Write_Str (" .. "); | |
1357 | Sprint_Node (Last_Bit (Node)); | |
1358 | Write_Char (';'); | |
1359 | ||
a397db96 AC |
1360 | when N_Component_Definition => |
1361 | Set_Debug_Sloc; | |
9bc43c53 | 1362 | |
0ab80019 | 1363 | -- Ada 2005 (AI-230): Access definition components |
9bc43c53 | 1364 | |
6e937c1c AC |
1365 | if Present (Access_Definition (Node)) then |
1366 | Sprint_Node (Access_Definition (Node)); | |
1367 | ||
1368 | elsif Present (Subtype_Indication (Node)) then | |
1369 | if Aliased_Present (Node) then | |
1370 | Write_Str_With_Col_Check ("aliased "); | |
1371 | end if; | |
1372 | ||
0ab80019 | 1373 | -- Ada 2005 (AI-231) |
2820d220 AC |
1374 | |
1375 | if Null_Exclusion_Present (Node) then | |
1376 | Write_Str (" not null "); | |
1377 | end if; | |
1378 | ||
6e937c1c | 1379 | Sprint_Node (Subtype_Indication (Node)); |
9bc856dd | 1380 | |
6e937c1c | 1381 | else |
9bc856dd | 1382 | Write_Str (" ??? "); |
6e937c1c | 1383 | end if; |
a397db96 | 1384 | |
996ae0b0 RK |
1385 | when N_Component_Declaration => |
1386 | if Write_Indent_Identifiers_Sloc (Node) then | |
1387 | Write_Str (" : "); | |
a397db96 | 1388 | Sprint_Node (Component_Definition (Node)); |
996ae0b0 RK |
1389 | |
1390 | if Present (Expression (Node)) then | |
1391 | Write_Str (" := "); | |
1392 | Sprint_Node (Expression (Node)); | |
1393 | end if; | |
1394 | ||
c159409f | 1395 | Write_Char (';'); |
996ae0b0 RK |
1396 | end if; |
1397 | ||
1398 | when N_Component_List => | |
1399 | if Null_Present (Node) then | |
1400 | Indent_Begin; | |
1401 | Write_Indent_Str_Sloc ("null"); | |
1402 | Write_Char (';'); | |
1403 | Indent_End; | |
1404 | ||
1405 | else | |
1406 | Set_Debug_Sloc; | |
1407 | Sprint_Indented_List (Component_Items (Node)); | |
1408 | Sprint_Node (Variant_Part (Node)); | |
1409 | end if; | |
1410 | ||
2ffcbaa5 AC |
1411 | when N_Compound_Statement => |
1412 | Write_Indent_Str ("do"); | |
1413 | Indent_Begin; | |
1414 | Sprint_Node_List (Actions (Node)); | |
1415 | Indent_End; | |
1416 | Write_Indent_Str ("end;"); | |
1417 | ||
996ae0b0 RK |
1418 | when N_Conditional_Entry_Call => |
1419 | Write_Indent_Str_Sloc ("select"); | |
1420 | Indent_Begin; | |
1421 | Sprint_Node (Entry_Call_Alternative (Node)); | |
1422 | Indent_End; | |
1423 | Write_Indent_Str ("else"); | |
1424 | Sprint_Indented_List (Else_Statements (Node)); | |
1425 | Write_Indent_Str ("end select;"); | |
1426 | ||
996ae0b0 RK |
1427 | when N_Constrained_Array_Definition => |
1428 | Write_Str_With_Col_Check_Sloc ("array "); | |
1429 | Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); | |
1430 | Write_Str (" of "); | |
1431 | ||
a397db96 | 1432 | Sprint_Node (Component_Definition (Node)); |
996ae0b0 | 1433 | |
dac3bede | 1434 | -- A contract node should not appear in the tree. It is a semantic |
d3e16619 AC |
1435 | -- node attached to entry and [generic] subprogram entities. But we |
1436 | -- still provide meaningful output, in case called from the debugger. | |
dac3bede YM |
1437 | |
1438 | when N_Contract => | |
d3e16619 AC |
1439 | declare |
1440 | P : Node_Id; | |
1441 | ||
1442 | begin | |
1443 | Indent_Begin; | |
1444 | Write_Str ("N_Contract node"); | |
1445 | Write_Eol; | |
1446 | ||
1447 | Write_Indent_Str ("Pre_Post_Conditions"); | |
1448 | Indent_Begin; | |
1449 | ||
1450 | P := Pre_Post_Conditions (Node); | |
1451 | while Present (P) loop | |
1452 | Sprint_Node (P); | |
1453 | P := Next_Pragma (P); | |
1454 | end loop; | |
1455 | ||
1456 | Write_Eol; | |
1457 | Indent_End; | |
1458 | ||
1459 | Write_Indent_Str ("Contract_Test_Cases"); | |
1460 | Indent_Begin; | |
1461 | ||
1462 | P := Contract_Test_Cases (Node); | |
1463 | while Present (P) loop | |
1464 | Sprint_Node (P); | |
1465 | P := Next_Pragma (P); | |
1466 | end loop; | |
1467 | ||
1468 | Write_Eol; | |
1469 | Indent_End; | |
1470 | ||
1471 | Write_Indent_Str ("Classifications"); | |
1472 | Indent_Begin; | |
1473 | ||
1474 | P := Classifications (Node); | |
1475 | while Present (P) loop | |
1476 | Sprint_Node (P); | |
1477 | P := Next_Pragma (P); | |
1478 | end loop; | |
1479 | ||
1480 | Write_Eol; | |
1481 | Indent_End; | |
1482 | Indent_End; | |
1483 | end; | |
dac3bede | 1484 | |
996ae0b0 | 1485 | when N_Decimal_Fixed_Point_Definition => |
2f8313ce | 1486 | Write_Str_With_Col_Check_Sloc ("delta "); |
996ae0b0 | 1487 | Sprint_Node (Delta_Expression (Node)); |
2f8313ce | 1488 | Write_Str_With_Col_Check (" digits "); |
996ae0b0 RK |
1489 | Sprint_Node (Digits_Expression (Node)); |
1490 | Sprint_Opt_Node (Real_Range_Specification (Node)); | |
1491 | ||
1492 | when N_Defining_Character_Literal => | |
1493 | Write_Name_With_Col_Check_Sloc (Chars (Node)); | |
1494 | ||
1495 | when N_Defining_Identifier => | |
1496 | Set_Debug_Sloc; | |
1497 | Write_Id (Node); | |
1498 | ||
1499 | when N_Defining_Operator_Symbol => | |
1500 | Write_Name_With_Col_Check_Sloc (Chars (Node)); | |
1501 | ||
1502 | when N_Defining_Program_Unit_Name => | |
1503 | Set_Debug_Sloc; | |
1504 | Sprint_Node (Name (Node)); | |
1505 | Write_Char ('.'); | |
1506 | Write_Id (Defining_Identifier (Node)); | |
1507 | ||
1508 | when N_Delay_Alternative => | |
1509 | Sprint_Node_List (Pragmas_Before (Node)); | |
1510 | ||
1511 | if Present (Condition (Node)) then | |
1512 | Write_Indent; | |
1513 | Write_Str_With_Col_Check ("when "); | |
1514 | Sprint_Node (Condition (Node)); | |
1515 | Write_Str (" => "); | |
1516 | Indent_Annull; | |
1517 | end if; | |
1518 | ||
1519 | Sprint_Node_Sloc (Delay_Statement (Node)); | |
1520 | Sprint_Node_List (Statements (Node)); | |
1521 | ||
1522 | when N_Delay_Relative_Statement => | |
1523 | Write_Indent_Str_Sloc ("delay "); | |
1524 | Sprint_Node (Expression (Node)); | |
1525 | Write_Char (';'); | |
1526 | ||
1527 | when N_Delay_Until_Statement => | |
1528 | Write_Indent_Str_Sloc ("delay until "); | |
1529 | Sprint_Node (Expression (Node)); | |
1530 | Write_Char (';'); | |
1531 | ||
1532 | when N_Delta_Constraint => | |
1533 | Write_Str_With_Col_Check_Sloc ("delta "); | |
1534 | Sprint_Node (Delta_Expression (Node)); | |
1535 | Sprint_Opt_Node (Range_Constraint (Node)); | |
1536 | ||
1537 | when N_Derived_Type_Definition => | |
1538 | if Abstract_Present (Node) then | |
1539 | Write_Str_With_Col_Check ("abstract "); | |
1540 | end if; | |
1541 | ||
be257e99 | 1542 | Write_Str_With_Col_Check ("new "); |
2820d220 | 1543 | |
0ab80019 | 1544 | -- Ada 2005 (AI-231) |
2820d220 AC |
1545 | |
1546 | if Null_Exclusion_Present (Node) then | |
1547 | Write_Str_With_Col_Check ("not null "); | |
1548 | end if; | |
1549 | ||
996ae0b0 RK |
1550 | Sprint_Node (Subtype_Indication (Node)); |
1551 | ||
edd63e9b | 1552 | if Present (Interface_List (Node)) then |
99cf6c77 | 1553 | Write_Str_With_Col_Check (" and "); |
edd63e9b | 1554 | Sprint_And_List (Interface_List (Node)); |
996ae0b0 | 1555 | Write_Str_With_Col_Check (" with "); |
edd63e9b ES |
1556 | end if; |
1557 | ||
1558 | if Present (Record_Extension_Part (Node)) then | |
1559 | if No (Interface_List (Node)) then | |
1560 | Write_Str_With_Col_Check (" with "); | |
1561 | end if; | |
1562 | ||
996ae0b0 RK |
1563 | Sprint_Node (Record_Extension_Part (Node)); |
1564 | end if; | |
1565 | ||
1566 | when N_Designator => | |
1567 | Sprint_Node (Name (Node)); | |
1568 | Write_Char_Sloc ('.'); | |
1569 | Write_Id (Identifier (Node)); | |
1570 | ||
1571 | when N_Digits_Constraint => | |
1572 | Write_Str_With_Col_Check_Sloc ("digits "); | |
1573 | Sprint_Node (Digits_Expression (Node)); | |
1574 | Sprint_Opt_Node (Range_Constraint (Node)); | |
1575 | ||
1576 | when N_Discriminant_Association => | |
1577 | Set_Debug_Sloc; | |
1578 | ||
1579 | if Present (Selector_Names (Node)) then | |
1580 | Sprint_Bar_List (Selector_Names (Node)); | |
1581 | Write_Str (" => "); | |
1582 | end if; | |
1583 | ||
1584 | Set_Debug_Sloc; | |
1585 | Sprint_Node (Expression (Node)); | |
1586 | ||
1587 | when N_Discriminant_Specification => | |
1588 | Set_Debug_Sloc; | |
1589 | ||
1590 | if Write_Identifiers (Node) then | |
1591 | Write_Str (" : "); | |
2820d220 AC |
1592 | |
1593 | if Null_Exclusion_Present (Node) then | |
1594 | Write_Str ("not null "); | |
1595 | end if; | |
1596 | ||
996ae0b0 RK |
1597 | Sprint_Node (Discriminant_Type (Node)); |
1598 | ||
1599 | if Present (Expression (Node)) then | |
1600 | Write_Str (" := "); | |
1601 | Sprint_Node (Expression (Node)); | |
1602 | end if; | |
1603 | else | |
1604 | Write_Str (", "); | |
1605 | end if; | |
1606 | ||
1607 | when N_Elsif_Part => | |
1608 | Write_Indent_Str_Sloc ("elsif "); | |
1609 | Sprint_Node (Condition (Node)); | |
1610 | Write_Str_With_Col_Check (" then"); | |
1611 | Sprint_Indented_List (Then_Statements (Node)); | |
1612 | ||
1613 | when N_Empty => | |
1614 | null; | |
1615 | ||
1616 | when N_Entry_Body => | |
1617 | Write_Indent_Str_Sloc ("entry "); | |
1618 | Write_Id (Defining_Identifier (Node)); | |
1619 | Sprint_Node (Entry_Body_Formal_Part (Node)); | |
1620 | Write_Str_With_Col_Check (" is"); | |
1621 | Sprint_Indented_List (Declarations (Node)); | |
1622 | Write_Indent_Str ("begin"); | |
1623 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
1624 | Write_Indent_Str ("end "); | |
1625 | Write_Id (Defining_Identifier (Node)); | |
1626 | Write_Char (';'); | |
1627 | ||
1628 | when N_Entry_Body_Formal_Part => | |
1629 | if Present (Entry_Index_Specification (Node)) then | |
1630 | Write_Str_With_Col_Check_Sloc (" ("); | |
1631 | Sprint_Node (Entry_Index_Specification (Node)); | |
1632 | Write_Char (')'); | |
1633 | end if; | |
1634 | ||
1635 | Write_Param_Specs (Node); | |
1636 | Write_Str_With_Col_Check_Sloc (" when "); | |
1637 | Sprint_Node (Condition (Node)); | |
1638 | ||
1639 | when N_Entry_Call_Alternative => | |
1640 | Sprint_Node_List (Pragmas_Before (Node)); | |
1641 | Sprint_Node_Sloc (Entry_Call_Statement (Node)); | |
1642 | Sprint_Node_List (Statements (Node)); | |
1643 | ||
1644 | when N_Entry_Call_Statement => | |
1645 | Write_Indent; | |
1646 | Sprint_Node_Sloc (Name (Node)); | |
1647 | Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); | |
1648 | Write_Char (';'); | |
1649 | ||
1650 | when N_Entry_Declaration => | |
1651 | Write_Indent_Str_Sloc ("entry "); | |
1652 | Write_Id (Defining_Identifier (Node)); | |
1653 | ||
1654 | if Present (Discrete_Subtype_Definition (Node)) then | |
1655 | Write_Str_With_Col_Check (" ("); | |
1656 | Sprint_Node (Discrete_Subtype_Definition (Node)); | |
1657 | Write_Char (')'); | |
1658 | end if; | |
1659 | ||
1660 | Write_Param_Specs (Node); | |
c159409f | 1661 | Write_Char (';'); |
996ae0b0 RK |
1662 | |
1663 | when N_Entry_Index_Specification => | |
1664 | Write_Str_With_Col_Check_Sloc ("for "); | |
1665 | Write_Id (Defining_Identifier (Node)); | |
1666 | Write_Str_With_Col_Check (" in "); | |
1667 | Sprint_Node (Discrete_Subtype_Definition (Node)); | |
1668 | ||
1669 | when N_Enumeration_Representation_Clause => | |
1670 | Write_Indent_Str_Sloc ("for "); | |
1671 | Write_Id (Identifier (Node)); | |
1672 | Write_Str_With_Col_Check (" use "); | |
1673 | Sprint_Node (Array_Aggregate (Node)); | |
1674 | Write_Char (';'); | |
1675 | ||
1676 | when N_Enumeration_Type_Definition => | |
1677 | Set_Debug_Sloc; | |
1678 | ||
1679 | -- Skip attempt to print Literals field if it's not there and | |
1680 | -- we are in package Standard (case of Character, which is | |
1681 | -- handled specially (without an explicit literals list). | |
1682 | ||
1683 | if Sloc (Node) > Standard_Location | |
1684 | or else Present (Literals (Node)) | |
1685 | then | |
1686 | Sprint_Paren_Comma_List (Literals (Node)); | |
1687 | end if; | |
1688 | ||
1689 | when N_Error => | |
1690 | Write_Str_With_Col_Check_Sloc ("<error>"); | |
1691 | ||
1692 | when N_Exception_Declaration => | |
1693 | if Write_Indent_Identifiers (Node) then | |
1694 | Write_Str_With_Col_Check (" : "); | |
0c1edb56 ES |
1695 | |
1696 | if Is_Statically_Allocated (Defining_Identifier (Node)) then | |
1697 | Write_Str_With_Col_Check ("static "); | |
1698 | end if; | |
1699 | ||
1700 | Write_Str_Sloc ("exception"); | |
1701 | ||
1702 | if Present (Expression (Node)) then | |
1703 | Write_Str (" := "); | |
1704 | Sprint_Node (Expression (Node)); | |
1705 | end if; | |
1706 | ||
c159409f | 1707 | Write_Char (';'); |
996ae0b0 RK |
1708 | end if; |
1709 | ||
1710 | when N_Exception_Handler => | |
1711 | Write_Indent_Str_Sloc ("when "); | |
1712 | ||
1713 | if Present (Choice_Parameter (Node)) then | |
1714 | Sprint_Node (Choice_Parameter (Node)); | |
1715 | Write_Str (" : "); | |
1716 | end if; | |
1717 | ||
1718 | Sprint_Bar_List (Exception_Choices (Node)); | |
1719 | Write_Str (" => "); | |
1720 | Sprint_Indented_List (Statements (Node)); | |
1721 | ||
1722 | when N_Exception_Renaming_Declaration => | |
1723 | Write_Indent; | |
1724 | Set_Debug_Sloc; | |
1725 | Sprint_Node (Defining_Identifier (Node)); | |
1726 | Write_Str_With_Col_Check (" : exception renames "); | |
1727 | Sprint_Node (Name (Node)); | |
1728 | Write_Char (';'); | |
1729 | ||
1730 | when N_Exit_Statement => | |
1731 | Write_Indent_Str_Sloc ("exit"); | |
1732 | Sprint_Opt_Node (Name (Node)); | |
1733 | ||
1734 | if Present (Condition (Node)) then | |
1735 | Write_Str_With_Col_Check (" when "); | |
1736 | Sprint_Node (Condition (Node)); | |
1737 | end if; | |
1738 | ||
1739 | Write_Char (';'); | |
1740 | ||
fbf5a39b AC |
1741 | when N_Expanded_Name => |
1742 | Sprint_Node (Prefix (Node)); | |
1743 | Write_Char_Sloc ('.'); | |
1744 | Sprint_Node (Selector_Name (Node)); | |
1745 | ||
996ae0b0 RK |
1746 | when N_Explicit_Dereference => |
1747 | Sprint_Node (Prefix (Node)); | |
fbf5a39b | 1748 | Write_Char_Sloc ('.'); |
996ae0b0 RK |
1749 | Write_Str_Sloc ("all"); |
1750 | ||
955871d3 AC |
1751 | when N_Expression_With_Actions => |
1752 | Indent_Begin; | |
fcfb981b | 1753 | Write_Indent_Str_Sloc ("do "); |
955871d3 | 1754 | Indent_Begin; |
955871d3 AC |
1755 | Sprint_Node_List (Actions (Node)); |
1756 | Indent_End; | |
1757 | Write_Indent; | |
1758 | Write_Str_With_Col_Check_Sloc ("in "); | |
1759 | Sprint_Node (Expression (Node)); | |
1760 | Write_Str_With_Col_Check (" end"); | |
1761 | Indent_End; | |
1762 | Write_Indent; | |
1763 | ||
b0186f71 AC |
1764 | when N_Expression_Function => |
1765 | Write_Indent; | |
1766 | Sprint_Node_Sloc (Specification (Node)); | |
1767 | Write_Str (" is"); | |
1768 | Indent_Begin; | |
1769 | Write_Indent; | |
1770 | Sprint_Node (Expression (Node)); | |
1771 | Write_Char (';'); | |
1772 | Indent_End; | |
1773 | ||
39485a7b ES |
1774 | when N_Extended_Return_Statement => |
1775 | Write_Indent_Str_Sloc ("return "); | |
1776 | Sprint_Node_List (Return_Object_Declarations (Node)); | |
1777 | ||
1778 | if Present (Handled_Statement_Sequence (Node)) then | |
1779 | Write_Str_With_Col_Check (" do"); | |
1780 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
1781 | Write_Indent_Str ("end return;"); | |
1782 | else | |
1783 | Write_Indent_Str (";"); | |
1784 | end if; | |
1785 | ||
9eb8d5b4 AC |
1786 | when N_Delta_Aggregate => |
1787 | Write_Str_With_Col_Check_Sloc ("("); | |
1788 | Sprint_Node (Expression (Node)); | |
1789 | Write_Str_With_Col_Check (" with delta "); | |
1790 | Sprint_Comma_List (Component_Associations (Node)); | |
1791 | Write_Char (')'); | |
1792 | ||
996ae0b0 RK |
1793 | when N_Extension_Aggregate => |
1794 | Write_Str_With_Col_Check_Sloc ("("); | |
1795 | Sprint_Node (Ancestor_Part (Node)); | |
1796 | Write_Str_With_Col_Check (" with "); | |
1797 | ||
1798 | if Null_Record_Present (Node) then | |
1799 | Write_Str_With_Col_Check ("null record"); | |
1800 | else | |
1801 | if Present (Expressions (Node)) then | |
1802 | Sprint_Comma_List (Expressions (Node)); | |
1803 | ||
1804 | if Present (Component_Associations (Node)) then | |
1805 | Write_Str (", "); | |
1806 | end if; | |
1807 | end if; | |
1808 | ||
1809 | if Present (Component_Associations (Node)) then | |
1810 | Sprint_Comma_List (Component_Associations (Node)); | |
1811 | end if; | |
1812 | end if; | |
1813 | ||
1814 | Write_Char (')'); | |
1815 | ||
1816 | when N_Floating_Point_Definition => | |
1817 | Write_Str_With_Col_Check_Sloc ("digits "); | |
1818 | Sprint_Node (Digits_Expression (Node)); | |
1819 | Sprint_Opt_Node (Real_Range_Specification (Node)); | |
1820 | ||
1821 | when N_Formal_Decimal_Fixed_Point_Definition => | |
1822 | Write_Str_With_Col_Check_Sloc ("delta <> digits <>"); | |
1823 | ||
1824 | when N_Formal_Derived_Type_Definition => | |
1825 | Write_Str_With_Col_Check_Sloc ("new "); | |
1826 | Sprint_Node (Subtype_Mark (Node)); | |
1827 | ||
ce2b6ba5 JM |
1828 | if Present (Interface_List (Node)) then |
1829 | Write_Str_With_Col_Check (" and "); | |
1830 | Sprint_And_List (Interface_List (Node)); | |
1831 | end if; | |
1832 | ||
996ae0b0 RK |
1833 | if Private_Present (Node) then |
1834 | Write_Str_With_Col_Check (" with private"); | |
1835 | end if; | |
1836 | ||
82c80734 RD |
1837 | when N_Formal_Abstract_Subprogram_Declaration => |
1838 | Write_Indent_Str_Sloc ("with "); | |
1839 | Sprint_Node (Specification (Node)); | |
1840 | ||
1841 | Write_Str_With_Col_Check (" is abstract"); | |
1842 | ||
1843 | if Box_Present (Node) then | |
1844 | Write_Str_With_Col_Check (" <>"); | |
1845 | elsif Present (Default_Name (Node)) then | |
1846 | Write_Str_With_Col_Check (" "); | |
1847 | Sprint_Node (Default_Name (Node)); | |
1848 | end if; | |
1849 | ||
c159409f | 1850 | Write_Char (';'); |
82c80734 RD |
1851 | |
1852 | when N_Formal_Concrete_Subprogram_Declaration => | |
1853 | Write_Indent_Str_Sloc ("with "); | |
1854 | Sprint_Node (Specification (Node)); | |
1855 | ||
1856 | if Box_Present (Node) then | |
1857 | Write_Str_With_Col_Check (" is <>"); | |
1858 | elsif Present (Default_Name (Node)) then | |
1859 | Write_Str_With_Col_Check (" is "); | |
1860 | Sprint_Node (Default_Name (Node)); | |
1861 | end if; | |
1862 | ||
c159409f | 1863 | Write_Char (';'); |
82c80734 | 1864 | |
996ae0b0 RK |
1865 | when N_Formal_Discrete_Type_Definition => |
1866 | Write_Str_With_Col_Check_Sloc ("<>"); | |
1867 | ||
1868 | when N_Formal_Floating_Point_Definition => | |
1869 | Write_Str_With_Col_Check_Sloc ("digits <>"); | |
1870 | ||
1871 | when N_Formal_Modular_Type_Definition => | |
1872 | Write_Str_With_Col_Check_Sloc ("mod <>"); | |
1873 | ||
1874 | when N_Formal_Object_Declaration => | |
1875 | Set_Debug_Sloc; | |
1876 | ||
1877 | if Write_Indent_Identifiers (Node) then | |
1878 | Write_Str (" : "); | |
1879 | ||
1880 | if In_Present (Node) then | |
1881 | Write_Str_With_Col_Check ("in "); | |
1882 | end if; | |
1883 | ||
1884 | if Out_Present (Node) then | |
1885 | Write_Str_With_Col_Check ("out "); | |
1886 | end if; | |
1887 | ||
39485a7b | 1888 | if Present (Subtype_Mark (Node)) then |
996ae0b0 | 1889 | |
39485a7b ES |
1890 | -- Ada 2005 (AI-423): Formal object with null exclusion |
1891 | ||
1892 | if Null_Exclusion_Present (Node) then | |
1893 | Write_Str ("not null "); | |
1894 | end if; | |
1895 | ||
1896 | Sprint_Node (Subtype_Mark (Node)); | |
1897 | ||
1898 | -- Ada 2005 (AI-423): Formal object with access definition | |
1899 | ||
1900 | else | |
1901 | pragma Assert (Present (Access_Definition (Node))); | |
1902 | ||
1903 | Sprint_Node (Access_Definition (Node)); | |
1904 | end if; | |
1905 | ||
1906 | if Present (Default_Expression (Node)) then | |
996ae0b0 | 1907 | Write_Str (" := "); |
39485a7b | 1908 | Sprint_Node (Default_Expression (Node)); |
996ae0b0 RK |
1909 | end if; |
1910 | ||
c159409f | 1911 | Write_Char (';'); |
996ae0b0 RK |
1912 | end if; |
1913 | ||
1914 | when N_Formal_Ordinary_Fixed_Point_Definition => | |
1915 | Write_Str_With_Col_Check_Sloc ("delta <>"); | |
1916 | ||
1917 | when N_Formal_Package_Declaration => | |
1918 | Write_Indent_Str_Sloc ("with package "); | |
1919 | Write_Id (Defining_Identifier (Node)); | |
1920 | Write_Str_With_Col_Check (" is new "); | |
1921 | Sprint_Node (Name (Node)); | |
c159409f | 1922 | Write_Str_With_Col_Check (" (<>);"); |
996ae0b0 RK |
1923 | |
1924 | when N_Formal_Private_Type_Definition => | |
1925 | if Abstract_Present (Node) then | |
1926 | Write_Str_With_Col_Check ("abstract "); | |
1927 | end if; | |
1928 | ||
1929 | if Tagged_Present (Node) then | |
1930 | Write_Str_With_Col_Check ("tagged "); | |
1931 | end if; | |
1932 | ||
1933 | if Limited_Present (Node) then | |
1934 | Write_Str_With_Col_Check ("limited "); | |
1935 | end if; | |
1936 | ||
1937 | Write_Str_With_Col_Check_Sloc ("private"); | |
1938 | ||
d3cb4cc0 AC |
1939 | when N_Formal_Incomplete_Type_Definition => |
1940 | if Tagged_Present (Node) then | |
1941 | Write_Str_With_Col_Check ("is tagged "); | |
1942 | end if; | |
1943 | ||
996ae0b0 RK |
1944 | when N_Formal_Signed_Integer_Type_Definition => |
1945 | Write_Str_With_Col_Check_Sloc ("range <>"); | |
1946 | ||
996ae0b0 RK |
1947 | when N_Formal_Type_Declaration => |
1948 | Write_Indent_Str_Sloc ("type "); | |
1949 | Write_Id (Defining_Identifier (Node)); | |
1950 | ||
1951 | if Present (Discriminant_Specifications (Node)) then | |
1952 | Write_Discr_Specs (Node); | |
1953 | elsif Unknown_Discriminants_Present (Node) then | |
1954 | Write_Str_With_Col_Check ("(<>)"); | |
1955 | end if; | |
1956 | ||
d3cb4cc0 AC |
1957 | if Nkind (Formal_Type_Definition (Node)) /= |
1958 | N_Formal_Incomplete_Type_Definition | |
1959 | then | |
1960 | Write_Str_With_Col_Check (" is "); | |
1961 | end if; | |
1962 | ||
996ae0b0 | 1963 | Sprint_Node (Formal_Type_Definition (Node)); |
c159409f | 1964 | Write_Char (';'); |
996ae0b0 RK |
1965 | |
1966 | when N_Free_Statement => | |
1967 | Write_Indent_Str_Sloc ("free "); | |
1968 | Sprint_Node (Expression (Node)); | |
1969 | Write_Char (';'); | |
1970 | ||
1971 | when N_Freeze_Entity => | |
1972 | if Dump_Original_Only then | |
1973 | null; | |
1974 | ||
7096a67b AC |
1975 | -- A freeze node is output if it has some effect (i.e. non-empty |
1976 | -- actions, or freeze node for an itype, which causes elaboration | |
1977 | -- of the itype), and is also always output if Dump_Freeze_Null | |
1978 | -- is set True. | |
1979 | ||
1980 | elsif Present (Actions (Node)) | |
1981 | or else Is_Itype (Entity (Node)) | |
1982 | or else Dump_Freeze_Null | |
1983 | then | |
996ae0b0 RK |
1984 | Write_Indent; |
1985 | Write_Rewrite_Str ("<<<"); | |
1986 | Write_Str_With_Col_Check_Sloc ("freeze "); | |
1987 | Write_Id (Entity (Node)); | |
1988 | Write_Str (" ["); | |
1989 | ||
1990 | if No (Actions (Node)) then | |
1991 | Write_Char (']'); | |
1992 | ||
1993 | else | |
39485a7b ES |
1994 | -- Output freeze actions. We increment Freeze_Indent during |
1995 | -- this output to avoid generating extra blank lines before | |
1996 | -- any procedures included in the freeze actions. | |
1997 | ||
996ae0b0 RK |
1998 | Freeze_Indent := Freeze_Indent + 1; |
1999 | Sprint_Indented_List (Actions (Node)); | |
2000 | Freeze_Indent := Freeze_Indent - 1; | |
2001 | Write_Indent_Str ("]"); | |
2002 | end if; | |
2003 | ||
2004 | Write_Rewrite_Str (">>>"); | |
2005 | end if; | |
2006 | ||
3cd4a210 AC |
2007 | when N_Freeze_Generic_Entity => |
2008 | if Dump_Original_Only then | |
2009 | null; | |
2010 | ||
2011 | else | |
2012 | Write_Indent; | |
2013 | Write_Str_With_Col_Check_Sloc ("freeze_generic "); | |
2014 | Write_Id (Entity (Node)); | |
2015 | end if; | |
2016 | ||
996ae0b0 RK |
2017 | when N_Full_Type_Declaration => |
2018 | Write_Indent_Str_Sloc ("type "); | |
0c1edb56 | 2019 | Sprint_Node (Defining_Identifier (Node)); |
996ae0b0 RK |
2020 | Write_Discr_Specs (Node); |
2021 | Write_Str_With_Col_Check (" is "); | |
2022 | Sprint_Node (Type_Definition (Node)); | |
c159409f | 2023 | Write_Char (';'); |
996ae0b0 RK |
2024 | |
2025 | when N_Function_Call => | |
2026 | Set_Debug_Sloc; | |
ff7139c3 | 2027 | Write_Subprogram_Name (Name (Node)); |
996ae0b0 RK |
2028 | Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); |
2029 | ||
2030 | when N_Function_Instantiation => | |
2031 | Write_Indent_Str_Sloc ("function "); | |
2032 | Sprint_Node (Defining_Unit_Name (Node)); | |
2033 | Write_Str_With_Col_Check (" is new "); | |
2034 | Sprint_Node (Name (Node)); | |
2035 | Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); | |
c159409f | 2036 | Write_Char (';'); |
996ae0b0 RK |
2037 | |
2038 | when N_Function_Specification => | |
2039 | Write_Str_With_Col_Check_Sloc ("function "); | |
2040 | Sprint_Node (Defining_Unit_Name (Node)); | |
2041 | Write_Param_Specs (Node); | |
2042 | Write_Str_With_Col_Check (" return "); | |
244480db GD |
2043 | |
2044 | -- Ada 2005 (AI-231) | |
2045 | ||
2046 | if Nkind (Result_Definition (Node)) /= N_Access_Definition | |
2047 | and then Null_Exclusion_Present (Node) | |
2048 | then | |
2049 | Write_Str (" not null "); | |
2050 | end if; | |
2051 | ||
2052 | Sprint_Node (Result_Definition (Node)); | |
996ae0b0 RK |
2053 | |
2054 | when N_Generic_Association => | |
2055 | Set_Debug_Sloc; | |
2056 | ||
2057 | if Present (Selector_Name (Node)) then | |
2058 | Sprint_Node (Selector_Name (Node)); | |
2059 | Write_Str (" => "); | |
2060 | end if; | |
2061 | ||
2062 | Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); | |
2063 | ||
2064 | when N_Generic_Function_Renaming_Declaration => | |
2065 | Write_Indent_Str_Sloc ("generic function "); | |
2066 | Sprint_Node (Defining_Unit_Name (Node)); | |
2067 | Write_Str_With_Col_Check (" renames "); | |
2068 | Sprint_Node (Name (Node)); | |
2069 | Write_Char (';'); | |
2070 | ||
2071 | when N_Generic_Package_Declaration => | |
39485a7b | 2072 | Extra_Blank_Line; |
996ae0b0 RK |
2073 | Write_Indent_Str_Sloc ("generic "); |
2074 | Sprint_Indented_List (Generic_Formal_Declarations (Node)); | |
2075 | Write_Indent; | |
2076 | Sprint_Node (Specification (Node)); | |
c159409f | 2077 | Write_Char (';'); |
996ae0b0 RK |
2078 | |
2079 | when N_Generic_Package_Renaming_Declaration => | |
2080 | Write_Indent_Str_Sloc ("generic package "); | |
2081 | Sprint_Node (Defining_Unit_Name (Node)); | |
2082 | Write_Str_With_Col_Check (" renames "); | |
2083 | Sprint_Node (Name (Node)); | |
2084 | Write_Char (';'); | |
2085 | ||
2086 | when N_Generic_Procedure_Renaming_Declaration => | |
2087 | Write_Indent_Str_Sloc ("generic procedure "); | |
2088 | Sprint_Node (Defining_Unit_Name (Node)); | |
2089 | Write_Str_With_Col_Check (" renames "); | |
2090 | Sprint_Node (Name (Node)); | |
2091 | Write_Char (';'); | |
2092 | ||
2093 | when N_Generic_Subprogram_Declaration => | |
39485a7b | 2094 | Extra_Blank_Line; |
996ae0b0 RK |
2095 | Write_Indent_Str_Sloc ("generic "); |
2096 | Sprint_Indented_List (Generic_Formal_Declarations (Node)); | |
2097 | Write_Indent; | |
2098 | Sprint_Node (Specification (Node)); | |
c159409f | 2099 | Write_Char (';'); |
996ae0b0 RK |
2100 | |
2101 | when N_Goto_Statement => | |
2102 | Write_Indent_Str_Sloc ("goto "); | |
2103 | Sprint_Node (Name (Node)); | |
2104 | Write_Char (';'); | |
2105 | ||
2106 | if Nkind (Next (Node)) = N_Label then | |
2107 | Write_Indent; | |
2108 | end if; | |
2109 | ||
2110 | when N_Handled_Sequence_Of_Statements => | |
2111 | Set_Debug_Sloc; | |
2112 | Sprint_Indented_List (Statements (Node)); | |
2113 | ||
2114 | if Present (Exception_Handlers (Node)) then | |
2115 | Write_Indent_Str ("exception"); | |
2116 | Indent_Begin; | |
2117 | Sprint_Node_List (Exception_Handlers (Node)); | |
2118 | Indent_End; | |
2119 | end if; | |
2120 | ||
2121 | if Present (At_End_Proc (Node)) then | |
2122 | Write_Indent_Str ("at end"); | |
2123 | Indent_Begin; | |
2124 | Write_Indent; | |
2125 | Sprint_Node (At_End_Proc (Node)); | |
2126 | Write_Char (';'); | |
2127 | Indent_End; | |
2128 | end if; | |
2129 | ||
2130 | when N_Identifier => | |
2131 | Set_Debug_Sloc; | |
2132 | Write_Id (Node); | |
2133 | ||
9b16cb57 RD |
2134 | when N_If_Expression => |
2135 | declare | |
8ed7930e AC |
2136 | Has_Parens : constant Boolean := Paren_Count (Node) > 0; |
2137 | Condition : constant Node_Id := First (Expressions (Node)); | |
2138 | Then_Expr : constant Node_Id := Next (Condition); | |
9b16cb57 RD |
2139 | |
2140 | begin | |
a53c5613 AC |
2141 | -- The syntax for if_expression does not include parentheses, |
2142 | -- but sometimes parentheses are required, so unconditionally | |
8ed7930e | 2143 | -- generate them here unless already present. |
a53c5613 | 2144 | |
8ed7930e AC |
2145 | if not Has_Parens then |
2146 | Write_Char ('('); | |
2147 | end if; | |
c8d63650 | 2148 | |
8ed7930e | 2149 | Write_Str_With_Col_Check_Sloc ("if "); |
9b16cb57 RD |
2150 | Sprint_Node (Condition); |
2151 | Write_Str_With_Col_Check (" then "); | |
2152 | ||
a90bd866 | 2153 | -- Defense against junk here |
9b16cb57 RD |
2154 | |
2155 | if Present (Then_Expr) then | |
2156 | Sprint_Node (Then_Expr); | |
8ed7930e AC |
2157 | |
2158 | if Present (Next (Then_Expr)) then | |
2159 | Write_Str_With_Col_Check (" else "); | |
2160 | Sprint_Node (Next (Then_Expr)); | |
2161 | end if; | |
9b16cb57 RD |
2162 | end if; |
2163 | ||
8ed7930e AC |
2164 | if not Has_Parens then |
2165 | Write_Char (')'); | |
2166 | end if; | |
9b16cb57 RD |
2167 | end; |
2168 | ||
996ae0b0 RK |
2169 | when N_If_Statement => |
2170 | Write_Indent_Str_Sloc ("if "); | |
2171 | Sprint_Node (Condition (Node)); | |
2172 | Write_Str_With_Col_Check (" then"); | |
2173 | Sprint_Indented_List (Then_Statements (Node)); | |
2174 | Sprint_Opt_Node_List (Elsif_Parts (Node)); | |
2175 | ||
2176 | if Present (Else_Statements (Node)) then | |
2177 | Write_Indent_Str ("else"); | |
2178 | Sprint_Indented_List (Else_Statements (Node)); | |
2179 | end if; | |
2180 | ||
2181 | Write_Indent_Str ("end if;"); | |
2182 | ||
2183 | when N_Implicit_Label_Declaration => | |
2184 | if not Dump_Original_Only then | |
2185 | Write_Indent; | |
2186 | Write_Rewrite_Str ("<<<"); | |
2187 | Set_Debug_Sloc; | |
2188 | Write_Id (Defining_Identifier (Node)); | |
2189 | Write_Str (" : "); | |
2190 | Write_Str_With_Col_Check ("label"); | |
2191 | Write_Rewrite_Str (">>>"); | |
2192 | end if; | |
2193 | ||
2194 | when N_In => | |
07fc65c4 | 2195 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2196 | Write_Str_Sloc (" in "); |
1629f700 RD |
2197 | |
2198 | if Present (Right_Opnd (Node)) then | |
2199 | Sprint_Right_Opnd (Node); | |
2200 | else | |
2201 | Sprint_Bar_List (Alternatives (Node)); | |
2202 | end if; | |
996ae0b0 RK |
2203 | |
2204 | when N_Incomplete_Type_Declaration => | |
2205 | Write_Indent_Str_Sloc ("type "); | |
2206 | Write_Id (Defining_Identifier (Node)); | |
2207 | ||
2208 | if Present (Discriminant_Specifications (Node)) then | |
2209 | Write_Discr_Specs (Node); | |
2210 | elsif Unknown_Discriminants_Present (Node) then | |
2211 | Write_Str_With_Col_Check ("(<>)"); | |
2212 | end if; | |
2213 | ||
2214 | Write_Char (';'); | |
2215 | ||
2216 | when N_Index_Or_Discriminant_Constraint => | |
2217 | Set_Debug_Sloc; | |
2218 | Sprint_Paren_Comma_List (Constraints (Node)); | |
2219 | ||
2220 | when N_Indexed_Component => | |
2221 | Sprint_Node_Sloc (Prefix (Node)); | |
2222 | Sprint_Opt_Paren_Comma_List (Expressions (Node)); | |
2223 | ||
2224 | when N_Integer_Literal => | |
2225 | if Print_In_Hex (Node) then | |
2226 | Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex); | |
2227 | else | |
2228 | Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto); | |
2229 | end if; | |
2230 | ||
2231 | when N_Iteration_Scheme => | |
2232 | if Present (Condition (Node)) then | |
2233 | Write_Str_With_Col_Check_Sloc ("while "); | |
2234 | Sprint_Node (Condition (Node)); | |
2235 | else | |
2236 | Write_Str_With_Col_Check_Sloc ("for "); | |
b4ca2d2c | 2237 | |
57d62f0c AC |
2238 | if Present (Iterator_Specification (Node)) then |
2239 | Sprint_Node (Iterator_Specification (Node)); | |
2240 | else | |
2241 | Sprint_Node (Loop_Parameter_Specification (Node)); | |
2242 | end if; | |
996ae0b0 RK |
2243 | end if; |
2244 | ||
2245 | Write_Char (' '); | |
2246 | ||
57d62f0c AC |
2247 | when N_Iterator_Specification => |
2248 | Set_Debug_Sloc; | |
2249 | Write_Id (Defining_Identifier (Node)); | |
2250 | ||
2251 | if Present (Subtype_Indication (Node)) then | |
2252 | Write_Str_With_Col_Check (" : "); | |
2253 | Sprint_Node (Subtype_Indication (Node)); | |
2254 | end if; | |
2255 | ||
2256 | if Of_Present (Node) then | |
2257 | Write_Str_With_Col_Check (" of "); | |
2258 | else | |
2259 | Write_Str_With_Col_Check (" in "); | |
2260 | end if; | |
2261 | ||
2262 | if Reverse_Present (Node) then | |
2263 | Write_Str_With_Col_Check ("reverse "); | |
2264 | end if; | |
2265 | ||
2266 | Sprint_Node (Name (Node)); | |
2267 | ||
996ae0b0 RK |
2268 | when N_Itype_Reference => |
2269 | Write_Indent_Str_Sloc ("reference "); | |
2270 | Write_Id (Itype (Node)); | |
2271 | ||
2272 | when N_Label => | |
2273 | Write_Indent_Str_Sloc ("<<"); | |
2274 | Write_Id (Identifier (Node)); | |
2275 | Write_Str (">>"); | |
2276 | ||
2277 | when N_Loop_Parameter_Specification => | |
2278 | Set_Debug_Sloc; | |
2279 | Write_Id (Defining_Identifier (Node)); | |
2280 | Write_Str_With_Col_Check (" in "); | |
2281 | ||
2282 | if Reverse_Present (Node) then | |
2283 | Write_Str_With_Col_Check ("reverse "); | |
2284 | end if; | |
2285 | ||
2286 | Sprint_Node (Discrete_Subtype_Definition (Node)); | |
2287 | ||
2288 | when N_Loop_Statement => | |
2289 | Write_Indent; | |
2290 | ||
2291 | if Present (Identifier (Node)) | |
2292 | and then (not Has_Created_Identifier (Node) | |
2293 | or else not Dump_Original_Only) | |
2294 | then | |
2295 | Write_Rewrite_Str ("<<<"); | |
2296 | Write_Id (Identifier (Node)); | |
2297 | Write_Str (" : "); | |
2298 | Write_Rewrite_Str (">>>"); | |
2299 | Sprint_Node (Iteration_Scheme (Node)); | |
2300 | Write_Str_With_Col_Check_Sloc ("loop"); | |
2301 | Sprint_Indented_List (Statements (Node)); | |
2302 | Write_Indent_Str ("end loop "); | |
2303 | Write_Rewrite_Str ("<<<"); | |
2304 | Write_Id (Identifier (Node)); | |
2305 | Write_Rewrite_Str (">>>"); | |
2306 | Write_Char (';'); | |
2307 | ||
2308 | else | |
2309 | Sprint_Node (Iteration_Scheme (Node)); | |
2310 | Write_Str_With_Col_Check_Sloc ("loop"); | |
2311 | Sprint_Indented_List (Statements (Node)); | |
2312 | Write_Indent_Str ("end loop;"); | |
2313 | end if; | |
2314 | ||
2315 | when N_Mod_Clause => | |
2316 | Sprint_Node_List (Pragmas_Before (Node)); | |
2317 | Write_Str_With_Col_Check_Sloc ("at mod "); | |
2318 | Sprint_Node (Expression (Node)); | |
2319 | ||
2320 | when N_Modular_Type_Definition => | |
2321 | Write_Str_With_Col_Check_Sloc ("mod "); | |
2322 | Sprint_Node (Expression (Node)); | |
2323 | ||
2324 | when N_Not_In => | |
07fc65c4 | 2325 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2326 | Write_Str_Sloc (" not in "); |
1629f700 RD |
2327 | |
2328 | if Present (Right_Opnd (Node)) then | |
2329 | Sprint_Right_Opnd (Node); | |
2330 | else | |
2331 | Sprint_Bar_List (Alternatives (Node)); | |
2332 | end if; | |
996ae0b0 RK |
2333 | |
2334 | when N_Null => | |
2335 | Write_Str_With_Col_Check_Sloc ("null"); | |
2336 | ||
2337 | when N_Null_Statement => | |
2338 | if Comes_From_Source (Node) | |
2339 | or else Dump_Freeze_Null | |
2340 | or else not Is_List_Member (Node) | |
2341 | or else (No (Prev (Node)) and then No (Next (Node))) | |
2342 | then | |
2343 | Write_Indent_Str_Sloc ("null;"); | |
2344 | end if; | |
2345 | ||
2346 | when N_Number_Declaration => | |
2347 | Set_Debug_Sloc; | |
2348 | ||
2349 | if Write_Indent_Identifiers (Node) then | |
2350 | Write_Str_With_Col_Check (" : constant "); | |
2351 | Write_Str (" := "); | |
2352 | Sprint_Node (Expression (Node)); | |
2353 | Write_Char (';'); | |
2354 | end if; | |
2355 | ||
2356 | when N_Object_Declaration => | |
fbf5a39b | 2357 | Set_Debug_Sloc; |
996ae0b0 | 2358 | |
fbf5a39b | 2359 | if Write_Indent_Identifiers (Node) then |
b99282c4 RD |
2360 | declare |
2361 | Def_Id : constant Entity_Id := Defining_Identifier (Node); | |
0c1edb56 | 2362 | |
b99282c4 RD |
2363 | begin |
2364 | Write_Str_With_Col_Check (" : "); | |
996ae0b0 | 2365 | |
b99282c4 RD |
2366 | if Is_Statically_Allocated (Def_Id) then |
2367 | Write_Str_With_Col_Check ("static "); | |
2368 | end if; | |
996ae0b0 | 2369 | |
b99282c4 RD |
2370 | if Aliased_Present (Node) then |
2371 | Write_Str_With_Col_Check ("aliased "); | |
2372 | end if; | |
996ae0b0 | 2373 | |
b99282c4 RD |
2374 | if Constant_Present (Node) then |
2375 | Write_Str_With_Col_Check ("constant "); | |
2376 | end if; | |
2820d220 | 2377 | |
b99282c4 | 2378 | -- Ada 2005 (AI-231) |
2820d220 | 2379 | |
b99282c4 RD |
2380 | if Null_Exclusion_Present (Node) then |
2381 | Write_Str_With_Col_Check ("not null "); | |
2382 | end if; | |
996ae0b0 | 2383 | |
52d9ba4d | 2384 | -- Print type. We used to print the Object_Definition from |
bb012790 | 2385 | -- the node, but it is much more useful to print the Etype |
7b966a95 AC |
2386 | -- of the defining identifier for the case where the nominal |
2387 | -- type is an unconstrained array type. For example, this | |
2388 | -- will be a clear reference to the Itype with the bounds | |
2389 | -- in the case of a type like String. The object after | |
2390 | -- all is constrained, even if its nominal subtype is | |
bb012790 AC |
2391 | -- unconstrained. |
2392 | ||
7b966a95 AC |
2393 | declare |
2394 | Odef : constant Node_Id := Object_Definition (Node); | |
2395 | ||
2396 | begin | |
2397 | if Nkind (Odef) = N_Identifier | |
cc6f5d75 | 2398 | and then Present (Etype (Odef)) |
7b966a95 AC |
2399 | and then Is_Array_Type (Etype (Odef)) |
2400 | and then not Is_Constrained (Etype (Odef)) | |
2401 | and then Present (Etype (Def_Id)) | |
2402 | then | |
2403 | Sprint_Node (Etype (Def_Id)); | |
2404 | ||
52d9ba4d | 2405 | -- In other cases, the nominal type is fine to print |
7b966a95 AC |
2406 | |
2407 | else | |
2408 | Sprint_Node (Odef); | |
2409 | end if; | |
2410 | end; | |
996ae0b0 | 2411 | |
194d6f3f JS |
2412 | if Present (Expression (Node)) |
2413 | and then Expression (Node) /= Error | |
2414 | then | |
b99282c4 RD |
2415 | Write_Str (" := "); |
2416 | Sprint_Node (Expression (Node)); | |
2417 | end if; | |
2418 | ||
c159409f | 2419 | Write_Char (';'); |
b99282c4 RD |
2420 | |
2421 | -- Handle implicit importation and implicit exportation of | |
2422 | -- object declarations: | |
2423 | -- $pragma import (Convention_Id, Def_Id, "..."); | |
2424 | -- $pragma export (Convention_Id, Def_Id, "..."); | |
2425 | ||
2426 | if Is_Internal (Def_Id) | |
2427 | and then Present (Interface_Name (Def_Id)) | |
2428 | then | |
2429 | Write_Indent_Str_Sloc ("$pragma "); | |
2430 | ||
2431 | if Is_Imported (Def_Id) then | |
2432 | Write_Str ("import ("); | |
2433 | ||
2434 | else pragma Assert (Is_Exported (Def_Id)); | |
2435 | Write_Str ("export ("); | |
2436 | end if; | |
2437 | ||
2438 | declare | |
2439 | Prefix : constant String := "Convention_"; | |
2440 | S : constant String := Convention (Def_Id)'Img; | |
2441 | ||
2442 | begin | |
2443 | Name_Len := S'Last - Prefix'Last; | |
2444 | Name_Buffer (1 .. Name_Len) := | |
2445 | S (Prefix'Last + 1 .. S'Last); | |
2446 | Set_Casing (All_Lower_Case); | |
2447 | Write_Str (Name_Buffer (1 .. Name_Len)); | |
2448 | end; | |
2449 | ||
2450 | Write_Str (", "); | |
2451 | Write_Id (Def_Id); | |
2452 | Write_Str (", "); | |
2453 | Write_String_Table_Entry | |
2454 | (Strval (Interface_Name (Def_Id))); | |
2455 | Write_Str (");"); | |
2456 | end if; | |
2457 | end; | |
fbf5a39b | 2458 | end if; |
996ae0b0 RK |
2459 | |
2460 | when N_Object_Renaming_Declaration => | |
2461 | Write_Indent; | |
2462 | Set_Debug_Sloc; | |
2463 | Sprint_Node (Defining_Identifier (Node)); | |
2464 | Write_Str (" : "); | |
6e937c1c | 2465 | |
0ab80019 | 2466 | -- Ada 2005 (AI-230): Access renamings |
6e937c1c AC |
2467 | |
2468 | if Present (Access_Definition (Node)) then | |
2469 | Sprint_Node (Access_Definition (Node)); | |
2470 | ||
2471 | elsif Present (Subtype_Mark (Node)) then | |
39485a7b ES |
2472 | |
2473 | -- Ada 2005 (AI-423): Object renaming with a null exclusion | |
2474 | ||
2475 | if Null_Exclusion_Present (Node) then | |
2476 | Write_Str ("not null "); | |
2477 | end if; | |
2478 | ||
6e937c1c AC |
2479 | Sprint_Node (Subtype_Mark (Node)); |
2480 | ||
2481 | else | |
9bc856dd | 2482 | Write_Str (" ??? "); |
6e937c1c AC |
2483 | end if; |
2484 | ||
996ae0b0 RK |
2485 | Write_Str_With_Col_Check (" renames "); |
2486 | Sprint_Node (Name (Node)); | |
2487 | Write_Char (';'); | |
2488 | ||
2489 | when N_Op_Abs => | |
2490 | Write_Operator (Node, "abs "); | |
07fc65c4 | 2491 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2492 | |
2493 | when N_Op_Add => | |
07fc65c4 | 2494 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2495 | Write_Operator (Node, " + "); |
07fc65c4 | 2496 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2497 | |
2498 | when N_Op_And => | |
07fc65c4 | 2499 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2500 | Write_Operator (Node, " and "); |
07fc65c4 | 2501 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2502 | |
2503 | when N_Op_Concat => | |
07fc65c4 | 2504 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2505 | Write_Operator (Node, " & "); |
07fc65c4 | 2506 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2507 | |
2508 | when N_Op_Divide => | |
07fc65c4 | 2509 | Sprint_Left_Opnd (Node); |
996ae0b0 RK |
2510 | Write_Char (' '); |
2511 | Process_TFAI_RR_Flags (Node); | |
2512 | Write_Operator (Node, "/ "); | |
07fc65c4 | 2513 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2514 | |
2515 | when N_Op_Eq => | |
07fc65c4 | 2516 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2517 | Write_Operator (Node, " = "); |
07fc65c4 | 2518 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2519 | |
2520 | when N_Op_Expon => | |
07fc65c4 | 2521 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2522 | Write_Operator (Node, " ** "); |
07fc65c4 | 2523 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2524 | |
2525 | when N_Op_Ge => | |
07fc65c4 | 2526 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2527 | Write_Operator (Node, " >= "); |
07fc65c4 | 2528 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2529 | |
2530 | when N_Op_Gt => | |
07fc65c4 | 2531 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2532 | Write_Operator (Node, " > "); |
07fc65c4 | 2533 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2534 | |
2535 | when N_Op_Le => | |
07fc65c4 | 2536 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2537 | Write_Operator (Node, " <= "); |
07fc65c4 | 2538 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2539 | |
2540 | when N_Op_Lt => | |
07fc65c4 | 2541 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2542 | Write_Operator (Node, " < "); |
07fc65c4 | 2543 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2544 | |
2545 | when N_Op_Minus => | |
2546 | Write_Operator (Node, "-"); | |
07fc65c4 | 2547 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2548 | |
2549 | when N_Op_Mod => | |
07fc65c4 | 2550 | Sprint_Left_Opnd (Node); |
996ae0b0 RK |
2551 | |
2552 | if Treat_Fixed_As_Integer (Node) then | |
2553 | Write_Str (" #"); | |
2554 | end if; | |
2555 | ||
2556 | Write_Operator (Node, " mod "); | |
07fc65c4 | 2557 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2558 | |
2559 | when N_Op_Multiply => | |
07fc65c4 | 2560 | Sprint_Left_Opnd (Node); |
996ae0b0 RK |
2561 | Write_Char (' '); |
2562 | Process_TFAI_RR_Flags (Node); | |
2563 | Write_Operator (Node, "* "); | |
07fc65c4 | 2564 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2565 | |
2566 | when N_Op_Ne => | |
07fc65c4 | 2567 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2568 | Write_Operator (Node, " /= "); |
07fc65c4 | 2569 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2570 | |
2571 | when N_Op_Not => | |
2572 | Write_Operator (Node, "not "); | |
07fc65c4 | 2573 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2574 | |
2575 | when N_Op_Or => | |
07fc65c4 | 2576 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2577 | Write_Operator (Node, " or "); |
07fc65c4 | 2578 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2579 | |
2580 | when N_Op_Plus => | |
2581 | Write_Operator (Node, "+"); | |
07fc65c4 | 2582 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2583 | |
2584 | when N_Op_Rem => | |
07fc65c4 | 2585 | Sprint_Left_Opnd (Node); |
996ae0b0 RK |
2586 | |
2587 | if Treat_Fixed_As_Integer (Node) then | |
2588 | Write_Str (" #"); | |
2589 | end if; | |
2590 | ||
2591 | Write_Operator (Node, " rem "); | |
07fc65c4 | 2592 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2593 | |
2594 | when N_Op_Shift => | |
2595 | Set_Debug_Sloc; | |
2596 | Write_Id (Node); | |
2597 | Write_Char ('!'); | |
2598 | Write_Str_With_Col_Check ("("); | |
2599 | Sprint_Node (Left_Opnd (Node)); | |
2600 | Write_Str (", "); | |
2601 | Sprint_Node (Right_Opnd (Node)); | |
2602 | Write_Char (')'); | |
2603 | ||
2604 | when N_Op_Subtract => | |
07fc65c4 | 2605 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2606 | Write_Operator (Node, " - "); |
07fc65c4 | 2607 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2608 | |
2609 | when N_Op_Xor => | |
07fc65c4 | 2610 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2611 | Write_Operator (Node, " xor "); |
07fc65c4 | 2612 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2613 | |
2614 | when N_Operator_Symbol => | |
2615 | Write_Name_With_Col_Check_Sloc (Chars (Node)); | |
2616 | ||
2617 | when N_Ordinary_Fixed_Point_Definition => | |
2618 | Write_Str_With_Col_Check_Sloc ("delta "); | |
2619 | Sprint_Node (Delta_Expression (Node)); | |
2620 | Sprint_Opt_Node (Real_Range_Specification (Node)); | |
2621 | ||
2622 | when N_Or_Else => | |
07fc65c4 | 2623 | Sprint_Left_Opnd (Node); |
996ae0b0 | 2624 | Write_Str_Sloc (" or else "); |
07fc65c4 | 2625 | Sprint_Right_Opnd (Node); |
996ae0b0 RK |
2626 | |
2627 | when N_Others_Choice => | |
2628 | if All_Others (Node) then | |
2629 | Write_Str_With_Col_Check ("all "); | |
2630 | end if; | |
2631 | ||
2632 | Write_Str_With_Col_Check_Sloc ("others"); | |
2633 | ||
2634 | when N_Package_Body => | |
39485a7b | 2635 | Extra_Blank_Line; |
996ae0b0 RK |
2636 | Write_Indent_Str_Sloc ("package body "); |
2637 | Sprint_Node (Defining_Unit_Name (Node)); | |
2638 | Write_Str (" is"); | |
2639 | Sprint_Indented_List (Declarations (Node)); | |
2640 | ||
2641 | if Present (Handled_Statement_Sequence (Node)) then | |
2642 | Write_Indent_Str ("begin"); | |
2643 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
2644 | end if; | |
2645 | ||
2646 | Write_Indent_Str ("end "); | |
0c1edb56 ES |
2647 | Sprint_End_Label |
2648 | (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node)); | |
996ae0b0 RK |
2649 | Write_Char (';'); |
2650 | ||
2651 | when N_Package_Body_Stub => | |
2652 | Write_Indent_Str_Sloc ("package body "); | |
2653 | Sprint_Node (Defining_Identifier (Node)); | |
2654 | Write_Str_With_Col_Check (" is separate;"); | |
2655 | ||
2656 | when N_Package_Declaration => | |
39485a7b | 2657 | Extra_Blank_Line; |
996ae0b0 RK |
2658 | Write_Indent; |
2659 | Sprint_Node_Sloc (Specification (Node)); | |
c159409f | 2660 | Write_Char (';'); |
996ae0b0 | 2661 | |
31dd3f4b ES |
2662 | -- If this is an instantiation, get the aspects from the original |
2663 | -- instantiation node. | |
2664 | ||
2665 | if Is_Generic_Instance (Defining_Entity (Node)) | |
573e5dd6 RD |
2666 | and then Has_Aspects |
2667 | (Package_Instantiation (Defining_Entity (Node))) | |
31dd3f4b ES |
2668 | then |
2669 | Sprint_Aspect_Specifications | |
2670 | (Package_Instantiation (Defining_Entity (Node)), | |
2671 | Semicolon => True); | |
2672 | end if; | |
2673 | ||
996ae0b0 | 2674 | when N_Package_Instantiation => |
39485a7b | 2675 | Extra_Blank_Line; |
996ae0b0 RK |
2676 | Write_Indent_Str_Sloc ("package "); |
2677 | Sprint_Node (Defining_Unit_Name (Node)); | |
2678 | Write_Str (" is new "); | |
2679 | Sprint_Node (Name (Node)); | |
2680 | Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); | |
c159409f | 2681 | Write_Char (';'); |
996ae0b0 RK |
2682 | |
2683 | when N_Package_Renaming_Declaration => | |
2684 | Write_Indent_Str_Sloc ("package "); | |
2685 | Sprint_Node (Defining_Unit_Name (Node)); | |
2686 | Write_Str_With_Col_Check (" renames "); | |
2687 | Sprint_Node (Name (Node)); | |
2688 | Write_Char (';'); | |
2689 | ||
2690 | when N_Package_Specification => | |
2691 | Write_Str_With_Col_Check_Sloc ("package "); | |
2692 | Sprint_Node (Defining_Unit_Name (Node)); | |
1c54829e | 2693 | |
31dd3f4b | 2694 | if Nkind (Parent (Node)) = N_Generic_Package_Declaration |
1c54829e AC |
2695 | and then Has_Aspects (Parent (Node)) |
2696 | then | |
2697 | Sprint_Aspect_Specifications | |
2698 | (Parent (Node), Semicolon => False); | |
31dd3f4b ES |
2699 | |
2700 | -- An instantiation is rewritten as a package declaration, but | |
2701 | -- the aspects belong to the instantiation node. | |
2702 | ||
2703 | elsif Nkind (Parent (Node)) = N_Package_Declaration then | |
2704 | declare | |
2705 | Pack : constant Entity_Id := Defining_Entity (Node); | |
2706 | ||
2707 | begin | |
2708 | if not Is_Generic_Instance (Pack) then | |
2709 | if Has_Aspects (Parent (Node)) then | |
2710 | Sprint_Aspect_Specifications | |
2711 | (Parent (Node), Semicolon => False); | |
2712 | end if; | |
2713 | end if; | |
2714 | end; | |
1c54829e AC |
2715 | end if; |
2716 | ||
996ae0b0 RK |
2717 | Write_Str (" is"); |
2718 | Sprint_Indented_List (Visible_Declarations (Node)); | |
2719 | ||
2720 | if Present (Private_Declarations (Node)) then | |
2721 | Write_Indent_Str ("private"); | |
2722 | Sprint_Indented_List (Private_Declarations (Node)); | |
2723 | end if; | |
2724 | ||
2725 | Write_Indent_Str ("end "); | |
2726 | Sprint_Node (Defining_Unit_Name (Node)); | |
2727 | ||
2728 | when N_Parameter_Association => | |
2729 | Sprint_Node_Sloc (Selector_Name (Node)); | |
2730 | Write_Str (" => "); | |
2731 | Sprint_Node (Explicit_Actual_Parameter (Node)); | |
2732 | ||
2733 | when N_Parameter_Specification => | |
2734 | Set_Debug_Sloc; | |
2735 | ||
2736 | if Write_Identifiers (Node) then | |
2737 | Write_Str (" : "); | |
2738 | ||
2739 | if In_Present (Node) then | |
2740 | Write_Str_With_Col_Check ("in "); | |
2741 | end if; | |
2742 | ||
2743 | if Out_Present (Node) then | |
2744 | Write_Str_With_Col_Check ("out "); | |
2745 | end if; | |
2746 | ||
1baa4d2d TQ |
2747 | -- Ada 2005 (AI-231): Parameter specification may carry null |
2748 | -- exclusion. Do not print it now if this is an access formal, | |
2749 | -- it is emitted when the access definition is displayed. | |
2820d220 | 2750 | |
39485a7b | 2751 | if Null_Exclusion_Present (Node) |
89f0276a | 2752 | and then Nkind (Parameter_Type (Node)) /= N_Access_Definition |
39485a7b | 2753 | then |
2820d220 AC |
2754 | Write_Str ("not null "); |
2755 | end if; | |
89f0276a RD |
2756 | |
2757 | if Aliased_Present (Node) then | |
2758 | Write_Str ("aliased "); | |
2759 | end if; | |
2820d220 | 2760 | |
996ae0b0 RK |
2761 | Sprint_Node (Parameter_Type (Node)); |
2762 | ||
2763 | if Present (Expression (Node)) then | |
2764 | Write_Str (" := "); | |
2765 | Sprint_Node (Expression (Node)); | |
2766 | end if; | |
2767 | else | |
2768 | Write_Str (", "); | |
2769 | end if; | |
2770 | ||
f28573f4 ES |
2771 | when N_Pop_Constraint_Error_Label => |
2772 | Write_Indent_Str ("%pop_constraint_error_label"); | |
2773 | ||
2774 | when N_Pop_Program_Error_Label => | |
2775 | Write_Indent_Str ("%pop_program_error_label"); | |
2776 | ||
2777 | when N_Pop_Storage_Error_Label => | |
2778 | Write_Indent_Str ("%pop_storage_error_label"); | |
2779 | ||
0f1a6a0b AC |
2780 | when N_Private_Extension_Declaration => |
2781 | Write_Indent_Str_Sloc ("type "); | |
2782 | Write_Id (Defining_Identifier (Node)); | |
2783 | ||
2784 | if Present (Discriminant_Specifications (Node)) then | |
2785 | Write_Discr_Specs (Node); | |
2786 | elsif Unknown_Discriminants_Present (Node) then | |
2787 | Write_Str_With_Col_Check ("(<>)"); | |
2788 | end if; | |
2789 | ||
2790 | Write_Str_With_Col_Check (" is new "); | |
2791 | Sprint_Node (Subtype_Indication (Node)); | |
2792 | ||
2793 | if Present (Interface_List (Node)) then | |
2794 | Write_Str_With_Col_Check (" and "); | |
2795 | Sprint_And_List (Interface_List (Node)); | |
2796 | end if; | |
2797 | ||
c159409f | 2798 | Write_Str_With_Col_Check (" with private;"); |
0f1a6a0b AC |
2799 | |
2800 | when N_Private_Type_Declaration => | |
2801 | Write_Indent_Str_Sloc ("type "); | |
2802 | Write_Id (Defining_Identifier (Node)); | |
2803 | ||
2804 | if Present (Discriminant_Specifications (Node)) then | |
2805 | Write_Discr_Specs (Node); | |
2806 | elsif Unknown_Discriminants_Present (Node) then | |
2807 | Write_Str_With_Col_Check ("(<>)"); | |
2808 | end if; | |
2809 | ||
2810 | Write_Str (" is "); | |
2811 | ||
2812 | if Tagged_Present (Node) then | |
2813 | Write_Str_With_Col_Check ("tagged "); | |
2814 | end if; | |
2815 | ||
2816 | if Limited_Present (Node) then | |
2817 | Write_Str_With_Col_Check ("limited "); | |
2818 | end if; | |
2819 | ||
c159409f | 2820 | Write_Str_With_Col_Check ("private;"); |
0f1a6a0b | 2821 | |
f28573f4 ES |
2822 | when N_Push_Constraint_Error_Label => |
2823 | Write_Indent_Str ("%push_constraint_error_label ("); | |
2824 | ||
2825 | if Present (Exception_Label (Node)) then | |
2826 | Write_Name_With_Col_Check (Chars (Exception_Label (Node))); | |
2827 | end if; | |
2828 | ||
2829 | Write_Str (")"); | |
2830 | ||
2831 | when N_Push_Program_Error_Label => | |
2832 | Write_Indent_Str ("%push_program_error_label ("); | |
2833 | ||
2834 | if Present (Exception_Label (Node)) then | |
2835 | Write_Name_With_Col_Check (Chars (Exception_Label (Node))); | |
2836 | end if; | |
2837 | ||
2838 | Write_Str (")"); | |
2839 | ||
2840 | when N_Push_Storage_Error_Label => | |
2841 | Write_Indent_Str ("%push_storage_error_label ("); | |
2842 | ||
2843 | if Present (Exception_Label (Node)) then | |
2844 | Write_Name_With_Col_Check (Chars (Exception_Label (Node))); | |
2845 | end if; | |
2846 | ||
2847 | Write_Str (")"); | |
2848 | ||
996ae0b0 RK |
2849 | when N_Pragma => |
2850 | Write_Indent_Str_Sloc ("pragma "); | |
6e759c2a | 2851 | Write_Name_With_Col_Check (Pragma_Name_Unmapped (Node)); |
996ae0b0 RK |
2852 | |
2853 | if Present (Pragma_Argument_Associations (Node)) then | |
2854 | Sprint_Opt_Paren_Comma_List | |
2855 | (Pragma_Argument_Associations (Node)); | |
2856 | end if; | |
2857 | ||
2858 | Write_Char (';'); | |
2859 | ||
2860 | when N_Pragma_Argument_Association => | |
2861 | Set_Debug_Sloc; | |
2862 | ||
2863 | if Chars (Node) /= No_Name then | |
2864 | Write_Name_With_Col_Check (Chars (Node)); | |
2865 | Write_Str (" => "); | |
2866 | end if; | |
2867 | ||
2868 | Sprint_Node (Expression (Node)); | |
2869 | ||
996ae0b0 RK |
2870 | when N_Procedure_Call_Statement => |
2871 | Write_Indent; | |
2872 | Set_Debug_Sloc; | |
ff7139c3 | 2873 | Write_Subprogram_Name (Name (Node)); |
996ae0b0 RK |
2874 | Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); |
2875 | Write_Char (';'); | |
2876 | ||
2877 | when N_Procedure_Instantiation => | |
2878 | Write_Indent_Str_Sloc ("procedure "); | |
2879 | Sprint_Node (Defining_Unit_Name (Node)); | |
2880 | Write_Str_With_Col_Check (" is new "); | |
2881 | Sprint_Node (Name (Node)); | |
2882 | Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); | |
c159409f | 2883 | Write_Char (';'); |
996ae0b0 RK |
2884 | |
2885 | when N_Procedure_Specification => | |
2886 | Write_Str_With_Col_Check_Sloc ("procedure "); | |
2887 | Sprint_Node (Defining_Unit_Name (Node)); | |
2888 | Write_Param_Specs (Node); | |
2889 | ||
2890 | when N_Protected_Body => | |
2891 | Write_Indent_Str_Sloc ("protected body "); | |
2892 | Write_Id (Defining_Identifier (Node)); | |
2893 | Write_Str (" is"); | |
2894 | Sprint_Indented_List (Declarations (Node)); | |
2895 | Write_Indent_Str ("end "); | |
2896 | Write_Id (Defining_Identifier (Node)); | |
2897 | Write_Char (';'); | |
2898 | ||
2899 | when N_Protected_Body_Stub => | |
2900 | Write_Indent_Str_Sloc ("protected body "); | |
2901 | Write_Id (Defining_Identifier (Node)); | |
2902 | Write_Str_With_Col_Check (" is separate;"); | |
2903 | ||
2904 | when N_Protected_Definition => | |
2905 | Set_Debug_Sloc; | |
2906 | Sprint_Indented_List (Visible_Declarations (Node)); | |
2907 | ||
2908 | if Present (Private_Declarations (Node)) then | |
2909 | Write_Indent_Str ("private"); | |
2910 | Sprint_Indented_List (Private_Declarations (Node)); | |
2911 | end if; | |
2912 | ||
2913 | Write_Indent_Str ("end "); | |
2914 | ||
2915 | when N_Protected_Type_Declaration => | |
2916 | Write_Indent_Str_Sloc ("protected type "); | |
0c1edb56 | 2917 | Sprint_Node (Defining_Identifier (Node)); |
996ae0b0 | 2918 | Write_Discr_Specs (Node); |
edd63e9b ES |
2919 | |
2920 | if Present (Interface_List (Node)) then | |
2921 | Write_Str (" is new "); | |
2922 | Sprint_And_List (Interface_List (Node)); | |
2923 | Write_Str (" with "); | |
2924 | else | |
2925 | Write_Str (" is"); | |
2926 | end if; | |
2927 | ||
996ae0b0 RK |
2928 | Sprint_Node (Protected_Definition (Node)); |
2929 | Write_Id (Defining_Identifier (Node)); | |
c159409f | 2930 | Write_Char (';'); |
996ae0b0 RK |
2931 | |
2932 | when N_Qualified_Expression => | |
2933 | Sprint_Node (Subtype_Mark (Node)); | |
2934 | Write_Char_Sloc ('''); | |
07fc65c4 GB |
2935 | |
2936 | -- Print expression, make sure we have at least one level of | |
2937 | -- parentheses around the expression. For cases of qualified | |
2938 | -- expressions in the source, this is always the case, but | |
2939 | -- for generated qualifications, there may be no explicit | |
2940 | -- parentheses present. | |
2941 | ||
2942 | if Paren_Count (Expression (Node)) /= 0 then | |
2943 | Sprint_Node (Expression (Node)); | |
1adaea16 | 2944 | |
07fc65c4 GB |
2945 | else |
2946 | Write_Char ('('); | |
2947 | Sprint_Node (Expression (Node)); | |
1adaea16 AC |
2948 | |
2949 | -- Odd case, for the qualified expressions used in machine | |
2950 | -- code the argument may be a procedure call, resulting in | |
2951 | -- a junk semicolon before the right parent, get rid of it. | |
2952 | ||
2953 | Write_Erase_Char (';'); | |
2954 | ||
2955 | -- Now we can add the terminating right paren | |
2956 | ||
07fc65c4 GB |
2957 | Write_Char (')'); |
2958 | end if; | |
996ae0b0 | 2959 | |
a961aa79 AC |
2960 | when N_Quantified_Expression => |
2961 | Write_Str (" for"); | |
2962 | ||
2963 | if All_Present (Node) then | |
2964 | Write_Str (" all "); | |
2965 | else | |
2966 | Write_Str (" some "); | |
2967 | end if; | |
2968 | ||
57a8057a AC |
2969 | if Present (Iterator_Specification (Node)) then |
2970 | Sprint_Node (Iterator_Specification (Node)); | |
2971 | else | |
2972 | Sprint_Node (Loop_Parameter_Specification (Node)); | |
2973 | end if; | |
2974 | ||
a961aa79 AC |
2975 | Write_Str (" => "); |
2976 | Sprint_Node (Condition (Node)); | |
2977 | ||
c8d63650 RD |
2978 | when N_Raise_Expression => |
2979 | declare | |
2980 | Has_Parens : constant Boolean := Paren_Count (Node) > 0; | |
2981 | ||
2982 | begin | |
2983 | -- The syntax for raise_expression does not include parentheses | |
2984 | -- but sometimes parentheses are required, so unconditionally | |
2985 | -- generate them here unless already present. | |
2986 | ||
2987 | if not Has_Parens then | |
2988 | Write_Char ('('); | |
2989 | end if; | |
2990 | ||
2991 | Write_Str_With_Col_Check_Sloc ("raise "); | |
2992 | Sprint_Node (Name (Node)); | |
2993 | ||
2994 | if Present (Expression (Node)) then | |
2995 | Write_Str_With_Col_Check (" with "); | |
2996 | Sprint_Node (Expression (Node)); | |
2997 | end if; | |
2998 | ||
2999 | if not Has_Parens then | |
3000 | Write_Char (')'); | |
3001 | end if; | |
3002 | end; | |
3003 | ||
996ae0b0 RK |
3004 | when N_Raise_Constraint_Error => |
3005 | ||
3006 | -- This node can be used either as a subexpression or as a | |
3007 | -- statement form. The following test is a reasonably reliable | |
3008 | -- way to distinguish the two cases. | |
3009 | ||
3010 | if Is_List_Member (Node) | |
3011 | and then Nkind (Parent (Node)) not in N_Subexpr | |
3012 | then | |
3013 | Write_Indent; | |
3014 | end if; | |
3015 | ||
3016 | Write_Str_With_Col_Check_Sloc ("[constraint_error"); | |
07fc65c4 | 3017 | Write_Condition_And_Reason (Node); |
996ae0b0 RK |
3018 | |
3019 | when N_Raise_Program_Error => | |
996ae0b0 | 3020 | |
07fc65c4 GB |
3021 | -- This node can be used either as a subexpression or as a |
3022 | -- statement form. The following test is a reasonably reliable | |
3023 | -- way to distinguish the two cases. | |
3024 | ||
3025 | if Is_List_Member (Node) | |
3026 | and then Nkind (Parent (Node)) not in N_Subexpr | |
3027 | then | |
3028 | Write_Indent; | |
996ae0b0 RK |
3029 | end if; |
3030 | ||
07fc65c4 GB |
3031 | Write_Str_With_Col_Check_Sloc ("[program_error"); |
3032 | Write_Condition_And_Reason (Node); | |
996ae0b0 RK |
3033 | |
3034 | when N_Raise_Storage_Error => | |
996ae0b0 | 3035 | |
07fc65c4 GB |
3036 | -- This node can be used either as a subexpression or as a |
3037 | -- statement form. The following test is a reasonably reliable | |
3038 | -- way to distinguish the two cases. | |
3039 | ||
3040 | if Is_List_Member (Node) | |
3041 | and then Nkind (Parent (Node)) not in N_Subexpr | |
3042 | then | |
3043 | Write_Indent; | |
996ae0b0 RK |
3044 | end if; |
3045 | ||
07fc65c4 GB |
3046 | Write_Str_With_Col_Check_Sloc ("[storage_error"); |
3047 | Write_Condition_And_Reason (Node); | |
996ae0b0 RK |
3048 | |
3049 | when N_Raise_Statement => | |
3050 | Write_Indent_Str_Sloc ("raise "); | |
3051 | Sprint_Node (Name (Node)); | |
32a21096 AC |
3052 | |
3053 | if Present (Expression (Node)) then | |
3054 | Write_Str_With_Col_Check_Sloc (" with "); | |
3055 | Sprint_Node (Expression (Node)); | |
3056 | end if; | |
3057 | ||
996ae0b0 RK |
3058 | Write_Char (';'); |
3059 | ||
3060 | when N_Range => | |
3061 | Sprint_Node (Low_Bound (Node)); | |
3062 | Write_Str_Sloc (" .. "); | |
3063 | Sprint_Node (High_Bound (Node)); | |
0c1edb56 | 3064 | Update_Itype (Node); |
996ae0b0 RK |
3065 | |
3066 | when N_Range_Constraint => | |
3067 | Write_Str_With_Col_Check_Sloc ("range "); | |
3068 | Sprint_Node (Range_Expression (Node)); | |
3069 | ||
3070 | when N_Real_Literal => | |
3071 | Write_Ureal_With_Col_Check_Sloc (Realval (Node)); | |
3072 | ||
3073 | when N_Real_Range_Specification => | |
3074 | Write_Str_With_Col_Check_Sloc ("range "); | |
3075 | Sprint_Node (Low_Bound (Node)); | |
3076 | Write_Str (" .. "); | |
3077 | Sprint_Node (High_Bound (Node)); | |
3078 | ||
3079 | when N_Record_Definition => | |
3080 | if Abstract_Present (Node) then | |
3081 | Write_Str_With_Col_Check ("abstract "); | |
3082 | end if; | |
3083 | ||
3084 | if Tagged_Present (Node) then | |
3085 | Write_Str_With_Col_Check ("tagged "); | |
3086 | end if; | |
3087 | ||
3088 | if Limited_Present (Node) then | |
3089 | Write_Str_With_Col_Check ("limited "); | |
3090 | end if; | |
3091 | ||
3092 | if Null_Present (Node) then | |
3093 | Write_Str_With_Col_Check_Sloc ("null record"); | |
3094 | ||
3095 | else | |
3096 | Write_Str_With_Col_Check_Sloc ("record"); | |
3097 | Sprint_Node (Component_List (Node)); | |
3098 | Write_Indent_Str ("end record"); | |
3099 | end if; | |
3100 | ||
3101 | when N_Record_Representation_Clause => | |
3102 | Write_Indent_Str_Sloc ("for "); | |
3103 | Sprint_Node (Identifier (Node)); | |
3104 | Write_Str_With_Col_Check (" use record "); | |
3105 | ||
3106 | if Present (Mod_Clause (Node)) then | |
3107 | Sprint_Node (Mod_Clause (Node)); | |
3108 | end if; | |
3109 | ||
3110 | Sprint_Indented_List (Component_Clauses (Node)); | |
3111 | Write_Indent_Str ("end record;"); | |
3112 | ||
3113 | when N_Reference => | |
3114 | Sprint_Node (Prefix (Node)); | |
3115 | Write_Str_With_Col_Check_Sloc ("'reference"); | |
3116 | ||
3117 | when N_Requeue_Statement => | |
3118 | Write_Indent_Str_Sloc ("requeue "); | |
3119 | Sprint_Node (Name (Node)); | |
3120 | ||
3121 | if Abort_Present (Node) then | |
3122 | Write_Str_With_Col_Check (" with abort"); | |
3123 | end if; | |
3124 | ||
3125 | Write_Char (';'); | |
3126 | ||
327503f1 JM |
3127 | -- Don't we want to print more detail??? |
3128 | ||
3129 | -- Doc of this extended syntax belongs in sinfo.ads and/or | |
3130 | -- sprint.ads ??? | |
3131 | ||
327503f1 JM |
3132 | when N_SCIL_Dispatch_Table_Tag_Init => |
3133 | Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); | |
3134 | ||
3135 | when N_SCIL_Dispatching_Call => | |
3136 | Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); | |
3137 | ||
82878151 AC |
3138 | when N_SCIL_Membership_Test => |
3139 | Write_Indent_Str ("[N_SCIL_Membership_Test]"); | |
3140 | ||
b99282c4 | 3141 | when N_Simple_Return_Statement => |
996ae0b0 RK |
3142 | if Present (Expression (Node)) then |
3143 | Write_Indent_Str_Sloc ("return "); | |
3144 | Sprint_Node (Expression (Node)); | |
3145 | Write_Char (';'); | |
3146 | else | |
3147 | Write_Indent_Str_Sloc ("return;"); | |
3148 | end if; | |
3149 | ||
3150 | when N_Selective_Accept => | |
3151 | Write_Indent_Str_Sloc ("select"); | |
3152 | ||
3153 | declare | |
3154 | Alt_Node : Node_Id; | |
996ae0b0 RK |
3155 | begin |
3156 | Alt_Node := First (Select_Alternatives (Node)); | |
3157 | loop | |
3158 | Indent_Begin; | |
3159 | Sprint_Node (Alt_Node); | |
3160 | Indent_End; | |
3161 | Next (Alt_Node); | |
3162 | exit when No (Alt_Node); | |
3163 | Write_Indent_Str ("or"); | |
3164 | end loop; | |
3165 | end; | |
3166 | ||
3167 | if Present (Else_Statements (Node)) then | |
3168 | Write_Indent_Str ("else"); | |
3169 | Sprint_Indented_List (Else_Statements (Node)); | |
3170 | end if; | |
3171 | ||
3172 | Write_Indent_Str ("end select;"); | |
3173 | ||
3174 | when N_Signed_Integer_Type_Definition => | |
3175 | Write_Str_With_Col_Check_Sloc ("range "); | |
3176 | Sprint_Node (Low_Bound (Node)); | |
3177 | Write_Str (" .. "); | |
3178 | Sprint_Node (High_Bound (Node)); | |
3179 | ||
3180 | when N_Single_Protected_Declaration => | |
3181 | Write_Indent_Str_Sloc ("protected "); | |
3182 | Write_Id (Defining_Identifier (Node)); | |
3183 | Write_Str (" is"); | |
3184 | Sprint_Node (Protected_Definition (Node)); | |
3185 | Write_Id (Defining_Identifier (Node)); | |
c159409f | 3186 | Write_Char (';'); |
996ae0b0 RK |
3187 | |
3188 | when N_Single_Task_Declaration => | |
3189 | Write_Indent_Str_Sloc ("task "); | |
0c1edb56 | 3190 | Sprint_Node (Defining_Identifier (Node)); |
996ae0b0 RK |
3191 | |
3192 | if Present (Task_Definition (Node)) then | |
3193 | Write_Str (" is"); | |
3194 | Sprint_Node (Task_Definition (Node)); | |
996ae0b0 RK |
3195 | end if; |
3196 | ||
c159409f | 3197 | Write_Char (';'); |
996ae0b0 | 3198 | |
fbf5a39b | 3199 | when N_Selected_Component => |
996ae0b0 RK |
3200 | Sprint_Node (Prefix (Node)); |
3201 | Write_Char_Sloc ('.'); | |
3202 | Sprint_Node (Selector_Name (Node)); | |
3203 | ||
3204 | when N_Slice => | |
3205 | Set_Debug_Sloc; | |
3206 | Sprint_Node (Prefix (Node)); | |
3207 | Write_Str_With_Col_Check (" ("); | |
3208 | Sprint_Node (Discrete_Range (Node)); | |
3209 | Write_Char (')'); | |
3210 | ||
3211 | when N_String_Literal => | |
dcd8728b | 3212 | if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then |
996ae0b0 RK |
3213 | Write_Indent_Str (" "); |
3214 | end if; | |
3215 | ||
3216 | Set_Debug_Sloc; | |
3217 | Write_String_Table_Entry (Strval (Node)); | |
3218 | ||
3219 | when N_Subprogram_Body => | |
39485a7b ES |
3220 | |
3221 | -- Output extra blank line unless we are in freeze actions | |
3222 | ||
996ae0b0 | 3223 | if Freeze_Indent = 0 then |
39485a7b | 3224 | Extra_Blank_Line; |
996ae0b0 RK |
3225 | end if; |
3226 | ||
3227 | Write_Indent; | |
1c218ac3 AC |
3228 | |
3229 | if Present (Corresponding_Spec (Node)) then | |
3230 | Sprint_Node_Sloc (Parent (Corresponding_Spec (Node))); | |
3231 | else | |
3232 | Sprint_Node_Sloc (Specification (Node)); | |
3233 | end if; | |
3234 | ||
996ae0b0 RK |
3235 | Write_Str (" is"); |
3236 | ||
3237 | Sprint_Indented_List (Declarations (Node)); | |
3238 | Write_Indent_Str ("begin"); | |
3239 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
3240 | ||
3241 | Write_Indent_Str ("end "); | |
0c1edb56 ES |
3242 | |
3243 | Sprint_End_Label | |
3244 | (Handled_Statement_Sequence (Node), | |
3245 | Defining_Unit_Name (Specification (Node))); | |
996ae0b0 RK |
3246 | Write_Char (';'); |
3247 | ||
3248 | if Is_List_Member (Node) | |
3249 | and then Present (Next (Node)) | |
3250 | and then Nkind (Next (Node)) /= N_Subprogram_Body | |
3251 | then | |
3252 | Write_Indent; | |
3253 | end if; | |
3254 | ||
3255 | when N_Subprogram_Body_Stub => | |
3256 | Write_Indent; | |
3257 | Sprint_Node_Sloc (Specification (Node)); | |
3258 | Write_Str_With_Col_Check (" is separate;"); | |
3259 | ||
3260 | when N_Subprogram_Declaration => | |
3261 | Write_Indent; | |
3262 | Sprint_Node_Sloc (Specification (Node)); | |
edd63e9b ES |
3263 | |
3264 | if Nkind (Specification (Node)) = N_Procedure_Specification | |
3265 | and then Null_Present (Specification (Node)) | |
3266 | then | |
3267 | Write_Str_With_Col_Check (" is null"); | |
3268 | end if; | |
3269 | ||
c159409f | 3270 | Write_Char (';'); |
996ae0b0 | 3271 | |
996ae0b0 RK |
3272 | when N_Subprogram_Renaming_Declaration => |
3273 | Write_Indent; | |
3274 | Sprint_Node (Specification (Node)); | |
3275 | Write_Str_With_Col_Check_Sloc (" renames "); | |
3276 | Sprint_Node (Name (Node)); | |
3277 | Write_Char (';'); | |
3278 | ||
3279 | when N_Subtype_Declaration => | |
3280 | Write_Indent_Str_Sloc ("subtype "); | |
0c1edb56 | 3281 | Sprint_Node (Defining_Identifier (Node)); |
996ae0b0 | 3282 | Write_Str (" is "); |
2820d220 | 3283 | |
0ab80019 | 3284 | -- Ada 2005 (AI-231) |
2820d220 AC |
3285 | |
3286 | if Null_Exclusion_Present (Node) then | |
3287 | Write_Str ("not null "); | |
3288 | end if; | |
3289 | ||
996ae0b0 | 3290 | Sprint_Node (Subtype_Indication (Node)); |
c159409f | 3291 | Write_Char (';'); |
996ae0b0 RK |
3292 | |
3293 | when N_Subtype_Indication => | |
3294 | Sprint_Node_Sloc (Subtype_Mark (Node)); | |
3295 | Write_Char (' '); | |
3296 | Sprint_Node (Constraint (Node)); | |
3297 | ||
3298 | when N_Subunit => | |
3299 | Write_Indent_Str_Sloc ("separate ("); | |
3300 | Sprint_Node (Name (Node)); | |
3301 | Write_Char (')'); | |
39485a7b | 3302 | Extra_Blank_Line; |
996ae0b0 RK |
3303 | Sprint_Node (Proper_Body (Node)); |
3304 | ||
ae33543c ES |
3305 | when N_Target_Name => |
3306 | Write_Char ('@'); | |
3307 | ||
996ae0b0 RK |
3308 | when N_Task_Body => |
3309 | Write_Indent_Str_Sloc ("task body "); | |
3310 | Write_Id (Defining_Identifier (Node)); | |
3311 | Write_Str (" is"); | |
3312 | Sprint_Indented_List (Declarations (Node)); | |
3313 | Write_Indent_Str ("begin"); | |
3314 | Sprint_Node (Handled_Statement_Sequence (Node)); | |
3315 | Write_Indent_Str ("end "); | |
0c1edb56 ES |
3316 | Sprint_End_Label |
3317 | (Handled_Statement_Sequence (Node), Defining_Identifier (Node)); | |
996ae0b0 RK |
3318 | Write_Char (';'); |
3319 | ||
3320 | when N_Task_Body_Stub => | |
3321 | Write_Indent_Str_Sloc ("task body "); | |
3322 | Write_Id (Defining_Identifier (Node)); | |
3323 | Write_Str_With_Col_Check (" is separate;"); | |
3324 | ||
3325 | when N_Task_Definition => | |
3326 | Set_Debug_Sloc; | |
3327 | Sprint_Indented_List (Visible_Declarations (Node)); | |
3328 | ||
3329 | if Present (Private_Declarations (Node)) then | |
3330 | Write_Indent_Str ("private"); | |
3331 | Sprint_Indented_List (Private_Declarations (Node)); | |
3332 | end if; | |
3333 | ||
3334 | Write_Indent_Str ("end "); | |
0c1edb56 | 3335 | Sprint_End_Label (Node, Defining_Identifier (Parent (Node))); |
996ae0b0 RK |
3336 | |
3337 | when N_Task_Type_Declaration => | |
3338 | Write_Indent_Str_Sloc ("task type "); | |
0c1edb56 | 3339 | Sprint_Node (Defining_Identifier (Node)); |
996ae0b0 | 3340 | Write_Discr_Specs (Node); |
6e937c1c | 3341 | |
edd63e9b ES |
3342 | if Present (Interface_List (Node)) then |
3343 | Write_Str (" is new "); | |
3344 | Sprint_And_List (Interface_List (Node)); | |
3345 | end if; | |
3346 | ||
996ae0b0 | 3347 | if Present (Task_Definition (Node)) then |
edd63e9b ES |
3348 | if No (Interface_List (Node)) then |
3349 | Write_Str (" is"); | |
3350 | else | |
3351 | Write_Str (" with "); | |
3352 | end if; | |
3353 | ||
996ae0b0 | 3354 | Sprint_Node (Task_Definition (Node)); |
996ae0b0 RK |
3355 | end if; |
3356 | ||
c159409f | 3357 | Write_Char (';'); |
996ae0b0 RK |
3358 | |
3359 | when N_Terminate_Alternative => | |
3360 | Sprint_Node_List (Pragmas_Before (Node)); | |
996ae0b0 RK |
3361 | Write_Indent; |
3362 | ||
3363 | if Present (Condition (Node)) then | |
3364 | Write_Str_With_Col_Check ("when "); | |
3365 | Sprint_Node (Condition (Node)); | |
3366 | Write_Str (" => "); | |
3367 | end if; | |
3368 | ||
3369 | Write_Str_With_Col_Check_Sloc ("terminate;"); | |
3370 | Sprint_Node_List (Pragmas_After (Node)); | |
3371 | ||
3372 | when N_Timed_Entry_Call => | |
3373 | Write_Indent_Str_Sloc ("select"); | |
3374 | Indent_Begin; | |
3375 | Sprint_Node (Entry_Call_Alternative (Node)); | |
3376 | Indent_End; | |
3377 | Write_Indent_Str ("or"); | |
3378 | Indent_Begin; | |
3379 | Sprint_Node (Delay_Alternative (Node)); | |
3380 | Indent_End; | |
3381 | Write_Indent_Str ("end select;"); | |
3382 | ||
3383 | when N_Triggering_Alternative => | |
3384 | Sprint_Node_List (Pragmas_Before (Node)); | |
3385 | Sprint_Node_Sloc (Triggering_Statement (Node)); | |
3386 | Sprint_Node_List (Statements (Node)); | |
3387 | ||
3388 | when N_Type_Conversion => | |
3389 | Set_Debug_Sloc; | |
3390 | Sprint_Node (Subtype_Mark (Node)); | |
3391 | Col_Check (4); | |
3392 | ||
3393 | if Conversion_OK (Node) then | |
3394 | Write_Char ('?'); | |
3395 | end if; | |
3396 | ||
3397 | if Float_Truncate (Node) then | |
3398 | Write_Char ('^'); | |
3399 | end if; | |
3400 | ||
3401 | if Rounded_Result (Node) then | |
3402 | Write_Char ('@'); | |
3403 | end if; | |
3404 | ||
3405 | Write_Char ('('); | |
3406 | Sprint_Node (Expression (Node)); | |
3407 | Write_Char (')'); | |
3408 | ||
3409 | when N_Unchecked_Expression => | |
3410 | Col_Check (10); | |
3411 | Write_Str ("`("); | |
3412 | Sprint_Node_Sloc (Expression (Node)); | |
3413 | Write_Char (')'); | |
3414 | ||
3415 | when N_Unchecked_Type_Conversion => | |
3416 | Sprint_Node (Subtype_Mark (Node)); | |
3417 | Write_Char ('!'); | |
3418 | Write_Str_With_Col_Check ("("); | |
3419 | Sprint_Node_Sloc (Expression (Node)); | |
3420 | Write_Char (')'); | |
3421 | ||
3422 | when N_Unconstrained_Array_Definition => | |
3423 | Write_Str_With_Col_Check_Sloc ("array ("); | |
3424 | ||
3425 | declare | |
3426 | Node1 : Node_Id; | |
996ae0b0 RK |
3427 | begin |
3428 | Node1 := First (Subtype_Marks (Node)); | |
3429 | loop | |
3430 | Sprint_Node (Node1); | |
3431 | Write_Str_With_Col_Check (" range <>"); | |
3432 | Next (Node1); | |
3433 | exit when Node1 = Empty; | |
3434 | Write_Str (", "); | |
3435 | end loop; | |
3436 | end; | |
3437 | ||
3438 | Write_Str (") of "); | |
a397db96 | 3439 | Sprint_Node (Component_Definition (Node)); |
996ae0b0 RK |
3440 | |
3441 | when N_Unused_At_Start | N_Unused_At_End => | |
3442 | Write_Indent_Str ("***** Error, unused node encountered *****"); | |
07fc65c4 | 3443 | Write_Eol; |
996ae0b0 RK |
3444 | |
3445 | when N_Use_Package_Clause => | |
3446 | Write_Indent_Str_Sloc ("use "); | |
851e9f19 | 3447 | Sprint_Node_Sloc (Name (Node)); |
996ae0b0 RK |
3448 | Write_Char (';'); |
3449 | ||
3450 | when N_Use_Type_Clause => | |
3451 | Write_Indent_Str_Sloc ("use type "); | |
851e9f19 | 3452 | Sprint_Node_Sloc (Subtype_Mark (Node)); |
996ae0b0 RK |
3453 | Write_Char (';'); |
3454 | ||
3455 | when N_Validate_Unchecked_Conversion => | |
3456 | Write_Indent_Str_Sloc ("validate unchecked_conversion ("); | |
3457 | Sprint_Node (Source_Type (Node)); | |
3458 | Write_Str (", "); | |
3459 | Sprint_Node (Target_Type (Node)); | |
3460 | Write_Str (");"); | |
3461 | ||
daf82dd8 HK |
3462 | when N_Variable_Reference_Marker => |
3463 | null; | |
3464 | ||
3465 | -- Enable the following code for debugging purposes only | |
3466 | ||
3467 | -- if Is_Read (Node) and then Is_Write (Node) then | |
3468 | -- Write_Indent_Str ("rw#"); | |
3469 | ||
3470 | -- elsif Is_Read (Node) then | |
3471 | -- Write_Indent_Str ("r#"); | |
3472 | ||
3473 | -- else | |
3474 | -- pragma Assert (Is_Write (Node)); | |
3475 | -- Write_Indent_Str ("w#"); | |
3476 | -- end if; | |
3477 | ||
3478 | -- Write_Id (Target (Node)); | |
3479 | -- Write_Char ('#'); | |
3480 | ||
996ae0b0 RK |
3481 | when N_Variant => |
3482 | Write_Indent_Str_Sloc ("when "); | |
3483 | Sprint_Bar_List (Discrete_Choices (Node)); | |
3484 | Write_Str (" => "); | |
3485 | Sprint_Node (Component_List (Node)); | |
3486 | ||
3487 | when N_Variant_Part => | |
3488 | Indent_Begin; | |
3489 | Write_Indent_Str_Sloc ("case "); | |
3490 | Sprint_Node (Name (Node)); | |
3491 | Write_Str (" is "); | |
3492 | Sprint_Indented_List (Variants (Node)); | |
3493 | Write_Indent_Str ("end case"); | |
3494 | Indent_End; | |
3495 | ||
3496 | when N_With_Clause => | |
3497 | ||
3498 | -- Special test, if we are dumping the original tree only, | |
3499 | -- then we want to eliminate the bogus with clauses that | |
3500 | -- correspond to the non-existent children of Text_IO. | |
3501 | ||
3502 | if Dump_Original_Only | |
2bd67690 | 3503 | and then Is_Text_IO_Special_Unit (Name (Node)) |
996ae0b0 RK |
3504 | then |
3505 | null; | |
3506 | ||
3507 | -- Normal case, output the with clause | |
3508 | ||
3509 | else | |
3510 | if First_Name (Node) or else not Dump_Original_Only then | |
19f0526a | 3511 | |
0ab80019 | 3512 | -- Ada 2005 (AI-50217): Print limited with_clauses |
19f0526a | 3513 | |
9bc856dd AC |
3514 | if Private_Present (Node) and Limited_Present (Node) then |
3515 | Write_Indent_Str ("limited private with "); | |
3516 | ||
3517 | elsif Private_Present (Node) then | |
3518 | Write_Indent_Str ("private with "); | |
3519 | ||
3520 | elsif Limited_Present (Node) then | |
657a9dd9 | 3521 | Write_Indent_Str ("limited with "); |
9bc856dd | 3522 | |
657a9dd9 AC |
3523 | else |
3524 | Write_Indent_Str ("with "); | |
3525 | end if; | |
3526 | ||
996ae0b0 RK |
3527 | else |
3528 | Write_Str (", "); | |
3529 | end if; | |
3530 | ||
3531 | Sprint_Node_Sloc (Name (Node)); | |
3532 | ||
3533 | if Last_Name (Node) or else not Dump_Original_Only then | |
3534 | Write_Char (';'); | |
3535 | end if; | |
3536 | end if; | |
996ae0b0 RK |
3537 | end case; |
3538 | ||
1c54829e AC |
3539 | -- Print aspects, except for special case of package declaration, |
3540 | -- where the aspects are printed inside the package specification. | |
3541 | ||
7271429c | 3542 | if Has_Aspects (Node) |
92a68a04 HK |
3543 | and then not Nkind_In (Node, N_Generic_Package_Declaration, |
3544 | N_Package_Declaration) | |
1bd9b6a5 | 3545 | and then not Is_Empty_List (Aspect_Specifications (Node)) |
7271429c | 3546 | then |
1c54829e | 3547 | Sprint_Aspect_Specifications (Node, Semicolon => True); |
c159409f AC |
3548 | end if; |
3549 | ||
92a68a04 | 3550 | if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then |
996ae0b0 RK |
3551 | Write_Str ("}"); |
3552 | end if; | |
3553 | ||
3554 | for J in 1 .. Paren_Count (Node) loop | |
3555 | Write_Char (')'); | |
3556 | end loop; | |
3557 | ||
39485a7b | 3558 | Dump_Node := Save_Dump_Node; |
996ae0b0 RK |
3559 | end Sprint_Node_Actual; |
3560 | ||
3561 | ---------------------- | |
3562 | -- Sprint_Node_List -- | |
3563 | ---------------------- | |
3564 | ||
3ffd18f1 | 3565 | procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is |
996ae0b0 RK |
3566 | Node : Node_Id; |
3567 | ||
3568 | begin | |
3569 | if Is_Non_Empty_List (List) then | |
3570 | Node := First (List); | |
3571 | ||
3572 | loop | |
3573 | Sprint_Node (Node); | |
3574 | Next (Node); | |
3575 | exit when Node = Empty; | |
3576 | end loop; | |
3577 | end if; | |
3ffd18f1 AC |
3578 | |
3579 | if New_Lines and then Column /= 1 then | |
3580 | Write_Eol; | |
3581 | end if; | |
996ae0b0 RK |
3582 | end Sprint_Node_List; |
3583 | ||
3584 | ---------------------- | |
3585 | -- Sprint_Node_Sloc -- | |
3586 | ---------------------- | |
3587 | ||
3588 | procedure Sprint_Node_Sloc (Node : Node_Id) is | |
3589 | begin | |
3590 | Sprint_Node (Node); | |
3591 | ||
39485a7b ES |
3592 | if Debug_Generated_Code and then Present (Dump_Node) then |
3593 | Set_Sloc (Dump_Node, Sloc (Node)); | |
3594 | Dump_Node := Empty; | |
996ae0b0 RK |
3595 | end if; |
3596 | end Sprint_Node_Sloc; | |
3597 | ||
3598 | --------------------- | |
3599 | -- Sprint_Opt_Node -- | |
3600 | --------------------- | |
3601 | ||
3602 | procedure Sprint_Opt_Node (Node : Node_Id) is | |
3603 | begin | |
3604 | if Present (Node) then | |
3605 | Write_Char (' '); | |
3606 | Sprint_Node (Node); | |
3607 | end if; | |
3608 | end Sprint_Opt_Node; | |
3609 | ||
3610 | -------------------------- | |
3611 | -- Sprint_Opt_Node_List -- | |
3612 | -------------------------- | |
3613 | ||
3614 | procedure Sprint_Opt_Node_List (List : List_Id) is | |
3615 | begin | |
3616 | if Present (List) then | |
3617 | Sprint_Node_List (List); | |
3618 | end if; | |
3619 | end Sprint_Opt_Node_List; | |
3620 | ||
3621 | --------------------------------- | |
3622 | -- Sprint_Opt_Paren_Comma_List -- | |
3623 | --------------------------------- | |
3624 | ||
3625 | procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is | |
3626 | begin | |
3627 | if Is_Non_Empty_List (List) then | |
3628 | Write_Char (' '); | |
3629 | Sprint_Paren_Comma_List (List); | |
3630 | end if; | |
3631 | end Sprint_Opt_Paren_Comma_List; | |
3632 | ||
3633 | ----------------------------- | |
3634 | -- Sprint_Paren_Comma_List -- | |
3635 | ----------------------------- | |
3636 | ||
3637 | procedure Sprint_Paren_Comma_List (List : List_Id) is | |
3638 | N : Node_Id; | |
3639 | Node_Exists : Boolean := False; | |
3640 | ||
3641 | begin | |
3642 | ||
3643 | if Is_Non_Empty_List (List) then | |
3644 | ||
3645 | if Dump_Original_Only then | |
3646 | N := First (List); | |
996ae0b0 | 3647 | while Present (N) loop |
996ae0b0 RK |
3648 | if not Is_Rewrite_Insertion (N) then |
3649 | Node_Exists := True; | |
3650 | exit; | |
3651 | end if; | |
3652 | ||
3653 | Next (N); | |
3654 | end loop; | |
3655 | ||
3656 | if not Node_Exists then | |
3657 | return; | |
3658 | end if; | |
3659 | end if; | |
3660 | ||
3661 | Write_Str_With_Col_Check ("("); | |
3662 | Sprint_Comma_List (List); | |
3663 | Write_Char (')'); | |
3664 | end if; | |
3665 | end Sprint_Paren_Comma_List; | |
3666 | ||
07fc65c4 GB |
3667 | ---------------------- |
3668 | -- Sprint_Right_Opnd -- | |
3669 | ---------------------- | |
3670 | ||
3671 | procedure Sprint_Right_Opnd (N : Node_Id) is | |
3672 | Opnd : constant Node_Id := Right_Opnd (N); | |
3673 | ||
3674 | begin | |
3675 | if Paren_Count (Opnd) /= 0 | |
3676 | or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) | |
3677 | then | |
3678 | Sprint_Node (Opnd); | |
3679 | ||
3680 | else | |
3681 | Write_Char ('('); | |
3682 | Sprint_Node (Opnd); | |
3683 | Write_Char (')'); | |
3684 | end if; | |
3685 | end Sprint_Right_Opnd; | |
3686 | ||
0c1edb56 ES |
3687 | ------------------ |
3688 | -- Update_Itype -- | |
3689 | ------------------ | |
3690 | ||
3691 | procedure Update_Itype (Node : Node_Id) is | |
3692 | begin | |
3693 | if Present (Etype (Node)) | |
3694 | and then Is_Itype (Etype (Node)) | |
3695 | and then Debug_Generated_Code | |
3696 | then | |
3697 | Set_Sloc (Etype (Node), Sloc (Node)); | |
3698 | end if; | |
3699 | end Update_Itype; | |
3700 | ||
996ae0b0 RK |
3701 | --------------------- |
3702 | -- Write_Char_Sloc -- | |
3703 | --------------------- | |
3704 | ||
3705 | procedure Write_Char_Sloc (C : Character) is | |
3706 | begin | |
3707 | if Debug_Generated_Code and then C /= ' ' then | |
3708 | Set_Debug_Sloc; | |
3709 | end if; | |
3710 | ||
3711 | Write_Char (C); | |
3712 | end Write_Char_Sloc; | |
3713 | ||
07fc65c4 GB |
3714 | -------------------------------- |
3715 | -- Write_Condition_And_Reason -- | |
3716 | -------------------------------- | |
3717 | ||
3718 | procedure Write_Condition_And_Reason (Node : Node_Id) is | |
39485a7b ES |
3719 | Cond : constant Node_Id := Condition (Node); |
3720 | Image : constant String := RT_Exception_Code'Image | |
3721 | (RT_Exception_Code'Val | |
3722 | (UI_To_Int (Reason (Node)))); | |
07fc65c4 GB |
3723 | |
3724 | begin | |
39485a7b ES |
3725 | if Present (Cond) then |
3726 | ||
3727 | -- If condition is a single entity, or NOT with a single entity, | |
3728 | -- output all on one line, since it will likely fit just fine. | |
3729 | ||
3730 | if Is_Entity_Name (Cond) | |
3731 | or else (Nkind (Cond) = N_Op_Not | |
3732 | and then Is_Entity_Name (Right_Opnd (Cond))) | |
3733 | then | |
3734 | Write_Str_With_Col_Check (" when "); | |
3735 | Sprint_Node (Cond); | |
3736 | Write_Char (' '); | |
3737 | ||
3738 | -- Otherwise for more complex condition, multiple lines | |
3739 | ||
3740 | else | |
3741 | Write_Str_With_Col_Check (" when"); | |
3742 | Indent := Indent + 2; | |
3743 | Write_Indent; | |
3744 | Sprint_Node (Cond); | |
3745 | Write_Indent; | |
3746 | Indent := Indent - 2; | |
3747 | end if; | |
3748 | ||
3749 | -- If no condition, just need a space (all on one line) | |
3750 | ||
3751 | else | |
3752 | Write_Char (' '); | |
07fc65c4 GB |
3753 | end if; |
3754 | ||
39485a7b ES |
3755 | -- Write the reason |
3756 | ||
3757 | Write_Char ('"'); | |
07fc65c4 GB |
3758 | |
3759 | for J in 4 .. Image'Last loop | |
3760 | if Image (J) = '_' then | |
3761 | Write_Char (' '); | |
3762 | else | |
3763 | Write_Char (Fold_Lower (Image (J))); | |
3764 | end if; | |
3765 | end loop; | |
3766 | ||
3767 | Write_Str ("""]"); | |
3768 | end Write_Condition_And_Reason; | |
3769 | ||
39485a7b ES |
3770 | -------------------------------- |
3771 | -- Write_Corresponding_Source -- | |
3772 | -------------------------------- | |
3773 | ||
3774 | procedure Write_Corresponding_Source (S : String) is | |
3775 | Loc : Source_Ptr; | |
3776 | Src : Source_Buffer_Ptr; | |
3777 | ||
3778 | begin | |
9c5719f6 AC |
3779 | -- Ignore if there is no current source file, or we're not in dump |
3780 | -- source text mode, or if in freeze actions. | |
39485a7b | 3781 | |
cd644ae2 | 3782 | if Current_Source_File > No_Source_File |
9c5719f6 AC |
3783 | and then Dump_Source_Text |
3784 | and then Freeze_Indent = 0 | |
3785 | then | |
39485a7b ES |
3786 | |
3787 | -- Ignore null string | |
3788 | ||
3789 | if S = "" then | |
3790 | return; | |
3791 | end if; | |
3792 | ||
3793 | -- Ignore space or semicolon at end of given string | |
3794 | ||
3795 | if S (S'Last) = ' ' or else S (S'Last) = ';' then | |
3796 | Write_Corresponding_Source (S (S'First .. S'Last - 1)); | |
3797 | return; | |
3798 | end if; | |
3799 | ||
3800 | -- Loop to look at next lines not yet printed in source file | |
3801 | ||
3802 | for L in | |
3803 | Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File) | |
3804 | loop | |
3805 | Src := Source_Text (Current_Source_File); | |
3806 | Loc := Line_Start (L, Current_Source_File); | |
3807 | ||
3808 | -- If comment, keep looking | |
3809 | ||
3810 | if Src (Loc .. Loc + 1) = "--" then | |
3811 | null; | |
3812 | ||
3813 | -- Search to first non-blank | |
3814 | ||
3815 | else | |
3816 | while Src (Loc) not in Line_Terminator loop | |
3817 | ||
3818 | -- Non-blank found | |
3819 | ||
3820 | if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then | |
3821 | ||
3822 | -- Loop through characters in string to see if we match | |
3823 | ||
3824 | for J in S'Range loop | |
3825 | ||
3826 | -- If mismatch, then not the case we are looking for | |
3827 | ||
3828 | if Src (Loc) /= S (J) then | |
3829 | return; | |
3830 | end if; | |
3831 | ||
3832 | Loc := Loc + 1; | |
3833 | end loop; | |
3834 | ||
3835 | -- If we fall through, string matched, if white space or | |
3836 | -- semicolon after the matched string, this is the case | |
3837 | -- we are looking for. | |
3838 | ||
3839 | if Src (Loc) in Line_Terminator | |
3840 | or else Src (Loc) = ' ' | |
3841 | or else Src (Loc) = ASCII.HT | |
3842 | or else Src (Loc) = ';' | |
3843 | then | |
3844 | -- So output source lines up to and including this one | |
3845 | ||
3846 | Write_Source_Lines (L); | |
3847 | return; | |
3848 | end if; | |
3849 | end if; | |
3850 | ||
3851 | Loc := Loc + 1; | |
3852 | end loop; | |
3853 | end if; | |
3854 | ||
3855 | -- Line was all blanks, or a comment line, keep looking | |
3856 | ||
3857 | end loop; | |
3858 | end if; | |
3859 | end Write_Corresponding_Source; | |
3860 | ||
15ce9ca2 AC |
3861 | ----------------------- |
3862 | -- Write_Discr_Specs -- | |
3863 | ----------------------- | |
996ae0b0 RK |
3864 | |
3865 | procedure Write_Discr_Specs (N : Node_Id) is | |
15ce9ca2 AC |
3866 | Specs : List_Id; |
3867 | Spec : Node_Id; | |
996ae0b0 RK |
3868 | |
3869 | begin | |
3870 | Specs := Discriminant_Specifications (N); | |
3871 | ||
3872 | if Present (Specs) then | |
3873 | Write_Str_With_Col_Check (" ("); | |
3874 | Spec := First (Specs); | |
3875 | ||
3876 | loop | |
3877 | Sprint_Node (Spec); | |
3878 | Next (Spec); | |
3879 | exit when Spec = Empty; | |
3880 | ||
3881 | -- Add semicolon, unless we are printing original tree and the | |
3882 | -- next specification is part of a list (but not the first | |
3883 | -- element of that list) | |
3884 | ||
3885 | if not Dump_Original_Only or else not Prev_Ids (Spec) then | |
3886 | Write_Str ("; "); | |
3887 | end if; | |
3888 | end loop; | |
3889 | ||
3890 | Write_Char (')'); | |
3891 | end if; | |
3892 | end Write_Discr_Specs; | |
3893 | ||
3894 | ----------------- | |
3895 | -- Write_Ekind -- | |
3896 | ----------------- | |
3897 | ||
3898 | procedure Write_Ekind (E : Entity_Id) is | |
3899 | S : constant String := Entity_Kind'Image (Ekind (E)); | |
3900 | ||
3901 | begin | |
3902 | Name_Len := S'Length; | |
3903 | Name_Buffer (1 .. Name_Len) := S; | |
3904 | Set_Casing (Mixed_Case); | |
3905 | Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); | |
3906 | end Write_Ekind; | |
3907 | ||
3908 | -------------- | |
3909 | -- Write_Id -- | |
3910 | -------------- | |
3911 | ||
3912 | procedure Write_Id (N : Node_Id) is | |
3913 | begin | |
653da906 RD |
3914 | -- Deal with outputting Itype |
3915 | ||
3916 | -- Note: if we are printing the full tree with -gnatds, then we may | |
3917 | -- end up picking up the Associated_Node link from a generic template | |
3918 | -- here which overlaps the Entity field, but as documented, Write_Itype | |
3919 | -- is defended against junk calls. | |
3920 | ||
3921 | if Nkind (N) in N_Entity then | |
3922 | Write_Itype (N); | |
3923 | elsif Nkind (N) in N_Has_Entity then | |
3924 | Write_Itype (Entity (N)); | |
3925 | end if; | |
3926 | ||
996ae0b0 RK |
3927 | -- Case of a defining identifier |
3928 | ||
3929 | if Nkind (N) = N_Defining_Identifier then | |
3930 | ||
3931 | -- If defining identifier has an interface name (and no | |
3932 | -- address clause), then we output the interface name. | |
3933 | ||
3934 | if (Is_Imported (N) or else Is_Exported (N)) | |
3935 | and then Present (Interface_Name (N)) | |
3936 | and then No (Address_Clause (N)) | |
3937 | then | |
3938 | String_To_Name_Buffer (Strval (Interface_Name (N))); | |
3939 | Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); | |
3940 | ||
3941 | -- If no interface name (or inactive because there was | |
3942 | -- an address clause), then just output the Chars name. | |
3943 | ||
3944 | else | |
3945 | Write_Name_With_Col_Check (Chars (N)); | |
3946 | end if; | |
3947 | ||
3948 | -- Case of selector of an expanded name where the expanded name | |
4ca17219 AC |
3949 | -- has an associated entity, output this entity. Check that the |
3950 | -- entity or associated node is of the right kind, see above. | |
996ae0b0 RK |
3951 | |
3952 | elsif Nkind (Parent (N)) = N_Expanded_Name | |
3953 | and then Selector_Name (Parent (N)) = N | |
4ca17219 AC |
3954 | and then Present (Entity_Or_Associated_Node (Parent (N))) |
3955 | and then Nkind (Entity (Parent (N))) in N_Entity | |
996ae0b0 RK |
3956 | then |
3957 | Write_Id (Entity (Parent (N))); | |
3958 | ||
9596236a | 3959 | -- For any other node with an associated entity, output it |
996ae0b0 RK |
3960 | |
3961 | elsif Nkind (N) in N_Has_Entity | |
9596236a AC |
3962 | and then Present (Entity_Or_Associated_Node (N)) |
3963 | and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity | |
996ae0b0 RK |
3964 | then |
3965 | Write_Id (Entity (N)); | |
3966 | ||
3967 | -- All other cases, we just print the Chars field | |
3968 | ||
3969 | else | |
3970 | Write_Name_With_Col_Check (Chars (N)); | |
3971 | end if; | |
3972 | end Write_Id; | |
3973 | ||
3974 | ----------------------- | |
3975 | -- Write_Identifiers -- | |
3976 | ----------------------- | |
3977 | ||
3978 | function Write_Identifiers (Node : Node_Id) return Boolean is | |
3979 | begin | |
3980 | Sprint_Node (Defining_Identifier (Node)); | |
0c1edb56 | 3981 | Update_Itype (Defining_Identifier (Node)); |
996ae0b0 RK |
3982 | |
3983 | -- The remainder of the declaration must be printed unless we are | |
3984 | -- printing the original tree and this is not the last identifier | |
3985 | ||
3986 | return | |
3987 | not Dump_Original_Only or else not More_Ids (Node); | |
3988 | ||
3989 | end Write_Identifiers; | |
3990 | ||
3991 | ------------------------ | |
3992 | -- Write_Implicit_Def -- | |
3993 | ------------------------ | |
3994 | ||
3995 | procedure Write_Implicit_Def (E : Entity_Id) is | |
3996 | Ind : Node_Id; | |
3997 | ||
3998 | begin | |
3999 | case Ekind (E) is | |
4000 | when E_Array_Subtype => | |
4001 | Write_Str_With_Col_Check ("subtype "); | |
4002 | Write_Id (E); | |
4003 | Write_Str_With_Col_Check (" is "); | |
4004 | Write_Id (Base_Type (E)); | |
4005 | Write_Str_With_Col_Check (" ("); | |
4006 | ||
4007 | Ind := First_Index (E); | |
996ae0b0 RK |
4008 | while Present (Ind) loop |
4009 | Sprint_Node (Ind); | |
4010 | Next_Index (Ind); | |
4011 | ||
4012 | if Present (Ind) then | |
4013 | Write_Str (", "); | |
4014 | end if; | |
4015 | end loop; | |
4016 | ||
4017 | Write_Str (");"); | |
4018 | ||
d8f43ee6 HK |
4019 | when E_Enumeration_Subtype |
4020 | | E_Signed_Integer_Subtype | |
4021 | => | |
996ae0b0 RK |
4022 | Write_Str_With_Col_Check ("subtype "); |
4023 | Write_Id (E); | |
4024 | Write_Str (" is "); | |
4025 | Write_Id (Etype (E)); | |
4026 | Write_Str_With_Col_Check (" range "); | |
4027 | Sprint_Node (Scalar_Range (E)); | |
4028 | Write_Str (";"); | |
4029 | ||
4030 | when others => | |
4031 | Write_Str_With_Col_Check ("type "); | |
4032 | Write_Id (E); | |
4033 | Write_Str_With_Col_Check (" is <"); | |
4034 | Write_Ekind (E); | |
4035 | Write_Str (">;"); | |
4036 | end case; | |
996ae0b0 RK |
4037 | end Write_Implicit_Def; |
4038 | ||
4039 | ------------------ | |
4040 | -- Write_Indent -- | |
4041 | ------------------ | |
4042 | ||
4043 | procedure Write_Indent is | |
39485a7b ES |
4044 | Loc : constant Source_Ptr := Sloc (Dump_Node); |
4045 | ||
996ae0b0 RK |
4046 | begin |
4047 | if Indent_Annull_Flag then | |
4048 | Indent_Annull_Flag := False; | |
4049 | else | |
0c1edb56 ES |
4050 | -- Deal with Dump_Source_Text output. Note that we ignore implicit |
4051 | -- label declarations, since they typically have the sloc of the | |
4052 | -- corresponding label, which really messes up the -gnatL output. | |
4053 | ||
4054 | if Dump_Source_Text | |
4055 | and then Loc > No_Location | |
4056 | and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration | |
4057 | then | |
39485a7b ES |
4058 | if Get_Source_File_Index (Loc) = Current_Source_File then |
4059 | Write_Source_Lines | |
4060 | (Get_Physical_Line_Number (Sloc (Dump_Node))); | |
4061 | end if; | |
4062 | end if; | |
4063 | ||
07fc65c4 GB |
4064 | Write_Eol; |
4065 | ||
996ae0b0 RK |
4066 | for J in 1 .. Indent loop |
4067 | Write_Char (' '); | |
4068 | end loop; | |
4069 | end if; | |
4070 | end Write_Indent; | |
4071 | ||
4072 | ------------------------------ | |
4073 | -- Write_Indent_Identifiers -- | |
4074 | ------------------------------ | |
4075 | ||
4076 | function Write_Indent_Identifiers (Node : Node_Id) return Boolean is | |
4077 | begin | |
4078 | -- We need to start a new line for every node, except in the case | |
4079 | -- where we are printing the original tree and this is not the first | |
4080 | -- defining identifier in the list. | |
4081 | ||
4082 | if not Dump_Original_Only or else not Prev_Ids (Node) then | |
4083 | Write_Indent; | |
4084 | ||
4085 | -- If printing original tree and this is not the first defining | |
4086 | -- identifier in the list, then the previous call to this procedure | |
4087 | -- printed only the name, and we add a comma to separate the names. | |
4088 | ||
4089 | else | |
4090 | Write_Str (", "); | |
4091 | end if; | |
4092 | ||
4093 | Sprint_Node (Defining_Identifier (Node)); | |
4094 | ||
4095 | -- The remainder of the declaration must be printed unless we are | |
4096 | -- printing the original tree and this is not the last identifier | |
4097 | ||
4098 | return | |
4099 | not Dump_Original_Only or else not More_Ids (Node); | |
996ae0b0 RK |
4100 | end Write_Indent_Identifiers; |
4101 | ||
4102 | ----------------------------------- | |
4103 | -- Write_Indent_Identifiers_Sloc -- | |
4104 | ----------------------------------- | |
4105 | ||
4106 | function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is | |
4107 | begin | |
4108 | -- We need to start a new line for every node, except in the case | |
4109 | -- where we are printing the original tree and this is not the first | |
4110 | -- defining identifier in the list. | |
4111 | ||
4112 | if not Dump_Original_Only or else not Prev_Ids (Node) then | |
4113 | Write_Indent; | |
4114 | ||
4115 | -- If printing original tree and this is not the first defining | |
4116 | -- identifier in the list, then the previous call to this procedure | |
4117 | -- printed only the name, and we add a comma to separate the names. | |
4118 | ||
4119 | else | |
4120 | Write_Str (", "); | |
4121 | end if; | |
4122 | ||
4123 | Set_Debug_Sloc; | |
4124 | Sprint_Node (Defining_Identifier (Node)); | |
4125 | ||
4126 | -- The remainder of the declaration must be printed unless we are | |
4127 | -- printing the original tree and this is not the last identifier | |
4128 | ||
39485a7b | 4129 | return not Dump_Original_Only or else not More_Ids (Node); |
996ae0b0 RK |
4130 | end Write_Indent_Identifiers_Sloc; |
4131 | ||
4132 | ---------------------- | |
4133 | -- Write_Indent_Str -- | |
4134 | ---------------------- | |
4135 | ||
4136 | procedure Write_Indent_Str (S : String) is | |
4137 | begin | |
39485a7b | 4138 | Write_Corresponding_Source (S); |
996ae0b0 RK |
4139 | Write_Indent; |
4140 | Write_Str (S); | |
4141 | end Write_Indent_Str; | |
4142 | ||
4143 | --------------------------- | |
4144 | -- Write_Indent_Str_Sloc -- | |
4145 | --------------------------- | |
4146 | ||
4147 | procedure Write_Indent_Str_Sloc (S : String) is | |
4148 | begin | |
39485a7b | 4149 | Write_Corresponding_Source (S); |
996ae0b0 RK |
4150 | Write_Indent; |
4151 | Write_Str_Sloc (S); | |
4152 | end Write_Indent_Str_Sloc; | |
4153 | ||
653da906 RD |
4154 | ----------------- |
4155 | -- Write_Itype -- | |
4156 | ----------------- | |
4157 | ||
4158 | procedure Write_Itype (Typ : Entity_Id) is | |
4159 | ||
4160 | procedure Write_Header (T : Boolean := True); | |
4161 | -- Write type if T is True, subtype if T is false | |
4162 | ||
4163 | ------------------ | |
4164 | -- Write_Header -- | |
4165 | ------------------ | |
4166 | ||
4167 | procedure Write_Header (T : Boolean := True) is | |
4168 | begin | |
4169 | if T then | |
4170 | Write_Str ("[type "); | |
4171 | else | |
4172 | Write_Str ("[subtype "); | |
4173 | end if; | |
4174 | ||
4175 | Write_Name_With_Col_Check (Chars (Typ)); | |
4176 | Write_Str (" is "); | |
4177 | end Write_Header; | |
4178 | ||
4179 | -- Start of processing for Write_Itype | |
4180 | ||
4181 | begin | |
4182 | if Nkind (Typ) in N_Entity | |
4183 | and then Is_Itype (Typ) | |
4184 | and then not Itype_Printed (Typ) | |
4185 | then | |
4186 | -- Itype to be printed | |
4187 | ||
4188 | declare | |
4189 | B : constant Node_Id := Etype (Typ); | |
653da906 | 4190 | P : constant Node_Id := Parent (Typ); |
653da906 RD |
4191 | S : constant Saved_Output_Buffer := Save_Output_Buffer; |
4192 | -- Save current output buffer | |
4193 | ||
62b80eaf ES |
4194 | Old_Sloc : Source_Ptr; |
4195 | -- Save sloc of related node, so it is not modified when | |
4196 | -- printing with -gnatD. | |
4197 | ||
2f8313ce EB |
4198 | X : Node_Id; |
4199 | ||
653da906 RD |
4200 | begin |
4201 | -- Write indentation at start of line | |
4202 | ||
4203 | for J in 1 .. Indent loop | |
4204 | Write_Char (' '); | |
4205 | end loop; | |
4206 | ||
99cf6c77 | 4207 | -- If we have a constructed declaration for the itype, print it |
653da906 | 4208 | |
99cf6c77 RD |
4209 | if Present (P) |
4210 | and then Nkind (P) in N_Declaration | |
4211 | and then Defining_Entity (P) = Typ | |
4212 | then | |
653da906 | 4213 | -- We must set Itype_Printed true before the recursive call to |
a90bd866 | 4214 | -- print the node, otherwise we get an infinite recursion. |
653da906 RD |
4215 | |
4216 | Set_Itype_Printed (Typ, True); | |
4217 | ||
4218 | -- Write the declaration enclosed in [], avoiding new line | |
4219 | -- at start of declaration, and semicolon at end. | |
4220 | ||
62b80eaf ES |
4221 | -- Note: The itype may be imported from another unit, in which |
4222 | -- case we do not want to modify the Sloc of the declaration. | |
4223 | -- Otherwise the itype may appear to be in the current unit, | |
4224 | -- and the back-end will reject a reference out of scope. | |
4225 | ||
653da906 RD |
4226 | Write_Char ('['); |
4227 | Indent_Annull_Flag := True; | |
62b80eaf | 4228 | Old_Sloc := Sloc (P); |
653da906 | 4229 | Sprint_Node (P); |
62b80eaf | 4230 | Set_Sloc (P, Old_Sloc); |
653da906 RD |
4231 | Write_Erase_Char (';'); |
4232 | ||
4233 | -- If no constructed declaration, then we have to concoct the | |
4234 | -- source corresponding to the type entity that we have at hand. | |
4235 | ||
4236 | else | |
4237 | case Ekind (Typ) is | |
4238 | ||
4239 | -- Access types and subtypes | |
4240 | ||
4241 | when Access_Kind => | |
4242 | Write_Header (Ekind (Typ) = E_Access_Type); | |
bed8af19 AC |
4243 | |
4244 | if Can_Never_Be_Null (Typ) then | |
4245 | Write_Str ("not null "); | |
4246 | end if; | |
4247 | ||
653da906 RD |
4248 | Write_Str ("access "); |
4249 | ||
4250 | if Is_Access_Constant (Typ) then | |
4251 | Write_Str ("constant "); | |
653da906 RD |
4252 | end if; |
4253 | ||
4254 | Write_Id (Directly_Designated_Type (Typ)); | |
4255 | ||
a7b37927 | 4256 | -- Array types |
653da906 | 4257 | |
f8c79ade | 4258 | when E_Array_Type => |
653da906 RD |
4259 | Write_Header; |
4260 | Write_Str ("array ("); | |
4261 | ||
4262 | X := First_Index (Typ); | |
4263 | loop | |
4264 | Sprint_Node (X); | |
4265 | ||
4266 | if not Is_Constrained (Typ) then | |
4267 | Write_Str (" range <>"); | |
4268 | end if; | |
4269 | ||
4270 | Next_Index (X); | |
4271 | exit when No (X); | |
4272 | Write_Str (", "); | |
4273 | end loop; | |
4274 | ||
4275 | Write_Str (") of "); | |
fe38726a ES |
4276 | X := Component_Type (Typ); |
4277 | ||
4278 | -- Preserve sloc of component type, which is defined | |
4279 | -- elsewhere than the itype (see comment above). | |
4280 | ||
4281 | Old_Sloc := Sloc (X); | |
4282 | Sprint_Node (X); | |
4283 | Set_Sloc (X, Old_Sloc); | |
653da906 | 4284 | |
b68cf874 AC |
4285 | -- Array subtypes |
4286 | ||
4287 | -- Preserve Sloc of index subtypes, as above | |
653da906 | 4288 | |
a7b37927 | 4289 | when E_Array_Subtype => |
653da906 RD |
4290 | Write_Header (False); |
4291 | Write_Id (Etype (Typ)); | |
4292 | Write_Str (" ("); | |
4293 | ||
4294 | X := First_Index (Typ); | |
4295 | loop | |
b61ebe4f | 4296 | Old_Sloc := Sloc (X); |
653da906 | 4297 | Sprint_Node (X); |
b61ebe4f | 4298 | Set_Sloc (X, Old_Sloc); |
653da906 RD |
4299 | Next_Index (X); |
4300 | exit when No (X); | |
4301 | Write_Str (", "); | |
4302 | end loop; | |
4303 | ||
4304 | Write_Char (')'); | |
4305 | ||
36c73552 AC |
4306 | -- Signed integer types, and modular integer subtypes, |
4307 | -- and also enumeration subtypes. | |
653da906 | 4308 | |
d8f43ee6 HK |
4309 | when E_Enumeration_Subtype |
4310 | | E_Modular_Integer_Subtype | |
4311 | | E_Signed_Integer_Subtype | |
4312 | | E_Signed_Integer_Type | |
4313 | => | |
653da906 RD |
4314 | Write_Header (Ekind (Typ) = E_Signed_Integer_Type); |
4315 | ||
4316 | if Ekind (Typ) = E_Signed_Integer_Type then | |
4317 | Write_Str ("new "); | |
4318 | end if; | |
4319 | ||
4320 | Write_Id (B); | |
4321 | ||
39485a7b | 4322 | -- Print bounds if different from base type |
653da906 RD |
4323 | |
4324 | declare | |
4325 | L : constant Node_Id := Type_Low_Bound (Typ); | |
4326 | H : constant Node_Id := Type_High_Bound (Typ); | |
2f8313ce EB |
4327 | BL : Node_Id; |
4328 | BH : Node_Id; | |
653da906 RD |
4329 | |
4330 | begin | |
39485a7b ES |
4331 | -- B can either be a scalar type, in which case the |
4332 | -- declaration of Typ may constrain it with different | |
4333 | -- bounds, or a private type, in which case we know | |
4334 | -- that the declaration of Typ cannot have a scalar | |
4335 | -- constraint. | |
4336 | ||
4337 | if Is_Scalar_Type (B) then | |
2f8313ce EB |
4338 | BL := Type_Low_Bound (B); |
4339 | BH := Type_High_Bound (B); | |
39485a7b | 4340 | else |
2f8313ce EB |
4341 | BL := Empty; |
4342 | BH := Empty; | |
39485a7b ES |
4343 | end if; |
4344 | ||
2f8313ce | 4345 | if No (BL) |
39485a7b ES |
4346 | or else (True |
4347 | and then Nkind (L) = N_Integer_Literal | |
4348 | and then Nkind (H) = N_Integer_Literal | |
2f8313ce EB |
4349 | and then Nkind (BL) = N_Integer_Literal |
4350 | and then Nkind (BH) = N_Integer_Literal | |
4351 | and then UI_Eq (Intval (L), Intval (BL)) | |
4352 | and then UI_Eq (Intval (H), Intval (BH))) | |
653da906 RD |
4353 | then |
4354 | null; | |
4355 | ||
4356 | else | |
4357 | Write_Str (" range "); | |
2f8313ce | 4358 | Sprint_Node (L); |
653da906 | 4359 | Write_Str (" .. "); |
2f8313ce | 4360 | Sprint_Node (H); |
653da906 RD |
4361 | end if; |
4362 | end; | |
4363 | ||
b61ebe4f | 4364 | -- Modular integer types |
653da906 RD |
4365 | |
4366 | when E_Modular_Integer_Type => | |
4367 | Write_Header; | |
7096a67b | 4368 | Write_Str ("mod "); |
653da906 RD |
4369 | Write_Uint_With_Col_Check (Modulus (Typ), Auto); |
4370 | ||
2f8313ce | 4371 | -- Floating-point types and subtypes |
653da906 | 4372 | |
d8f43ee6 HK |
4373 | when E_Floating_Point_Subtype |
4374 | | E_Floating_Point_Type | |
4375 | => | |
653da906 RD |
4376 | Write_Header (Ekind (Typ) = E_Floating_Point_Type); |
4377 | ||
4378 | if Ekind (Typ) = E_Floating_Point_Type then | |
4379 | Write_Str ("new "); | |
4380 | end if; | |
4381 | ||
2f8313ce | 4382 | Write_Id (B); |
653da906 | 4383 | |
2f8313ce | 4384 | if Digits_Value (Typ) /= Digits_Value (B) then |
653da906 RD |
4385 | Write_Str (" digits "); |
4386 | Write_Uint_With_Col_Check | |
4387 | (Digits_Value (Typ), Decimal); | |
4388 | end if; | |
4389 | ||
4390 | -- Print bounds if not different from base type | |
4391 | ||
4392 | declare | |
4393 | L : constant Node_Id := Type_Low_Bound (Typ); | |
4394 | H : constant Node_Id := Type_High_Bound (Typ); | |
2f8313ce EB |
4395 | BL : constant Node_Id := Type_Low_Bound (B); |
4396 | BH : constant Node_Id := Type_High_Bound (B); | |
653da906 RD |
4397 | |
4398 | begin | |
2f8313ce EB |
4399 | if True |
4400 | and then Nkind (L) = N_Real_Literal | |
653da906 | 4401 | and then Nkind (H) = N_Real_Literal |
2f8313ce EB |
4402 | and then Nkind (BL) = N_Real_Literal |
4403 | and then Nkind (BH) = N_Real_Literal | |
4404 | and then UR_Eq (Realval (L), Realval (BL)) | |
4405 | and then UR_Eq (Realval (H), Realval (BH)) | |
653da906 RD |
4406 | then |
4407 | null; | |
4408 | ||
4409 | else | |
4410 | Write_Str (" range "); | |
2f8313ce | 4411 | Sprint_Node (L); |
653da906 | 4412 | Write_Str (" .. "); |
2f8313ce | 4413 | Sprint_Node (H); |
653da906 RD |
4414 | end if; |
4415 | end; | |
4416 | ||
2f8313ce EB |
4417 | -- Ordinary fixed-point types and subtypes |
4418 | ||
4419 | when E_Ordinary_Fixed_Point_Subtype | |
4420 | | E_Ordinary_Fixed_Point_Type | |
4421 | => | |
4422 | Write_Header (Ekind (Typ) = E_Ordinary_Fixed_Point_Type); | |
4423 | ||
4424 | Write_Str ("delta "); | |
4425 | Write_Ureal_With_Col_Check_Sloc (Delta_Value (Typ)); | |
4426 | Write_Str (" range "); | |
4427 | Sprint_Node (Type_Low_Bound (Typ)); | |
4428 | Write_Str (" .. "); | |
4429 | Sprint_Node (Type_High_Bound (Typ)); | |
4430 | ||
4431 | -- Decimal fixed-point types and subtypes | |
4432 | ||
4433 | when E_Decimal_Fixed_Point_Subtype | |
4434 | | E_Decimal_Fixed_Point_Type | |
4435 | => | |
4436 | Write_Header (Ekind (Typ) = E_Decimal_Fixed_Point_Type); | |
4437 | ||
4438 | Write_Str ("delta "); | |
4439 | Write_Ureal_With_Col_Check_Sloc (Delta_Value (Typ)); | |
4440 | Write_Str (" digits "); | |
4441 | Write_Uint_With_Col_Check (Digits_Value (Typ), Decimal); | |
4442 | ||
653da906 RD |
4443 | -- Record subtypes |
4444 | ||
d8f43ee6 HK |
4445 | when E_Record_Subtype |
4446 | | E_Record_Subtype_With_Private | |
4447 | => | |
653da906 RD |
4448 | Write_Header (False); |
4449 | Write_Str ("record"); | |
4450 | Indent_Begin; | |
4451 | ||
4452 | declare | |
4453 | C : Entity_Id; | |
4454 | begin | |
4455 | C := First_Entity (Typ); | |
4456 | while Present (C) loop | |
4457 | Write_Indent; | |
4458 | Write_Id (C); | |
4459 | Write_Str (" : "); | |
4460 | Write_Id (Etype (C)); | |
4461 | Next_Entity (C); | |
4462 | end loop; | |
4463 | end; | |
4464 | ||
4465 | Indent_End; | |
4466 | Write_Indent_Str (" end record"); | |
4467 | ||
62b80eaf ES |
4468 | -- Class-Wide types |
4469 | ||
d8f43ee6 HK |
4470 | when E_Class_Wide_Subtype |
4471 | | E_Class_Wide_Type | |
4472 | => | |
d7761b2d | 4473 | Write_Header (Ekind (Typ) = E_Class_Wide_Type); |
62b80eaf ES |
4474 | Write_Name_With_Col_Check (Chars (Etype (Typ))); |
4475 | Write_Str ("'Class"); | |
4476 | ||
4477 | -- Subprogram types | |
4478 | ||
4479 | when E_Subprogram_Type => | |
4480 | Write_Header; | |
4481 | ||
4482 | if Etype (Typ) = Standard_Void_Type then | |
4483 | Write_Str ("procedure"); | |
4484 | else | |
4485 | Write_Str ("function"); | |
4486 | end if; | |
4487 | ||
4488 | if Present (First_Entity (Typ)) then | |
4489 | Write_Str (" ("); | |
4490 | ||
4491 | declare | |
4492 | Param : Entity_Id; | |
4493 | ||
4494 | begin | |
4495 | Param := First_Entity (Typ); | |
4496 | loop | |
4497 | Write_Id (Param); | |
4498 | Write_Str (" : "); | |
4499 | ||
4500 | if Ekind (Param) = E_In_Out_Parameter then | |
4501 | Write_Str ("in out "); | |
4502 | elsif Ekind (Param) = E_Out_Parameter then | |
4503 | Write_Str ("out "); | |
4504 | end if; | |
4505 | ||
4506 | Write_Id (Etype (Param)); | |
4507 | Next_Entity (Param); | |
4508 | exit when No (Param); | |
4509 | Write_Str (", "); | |
4510 | end loop; | |
4511 | ||
4512 | Write_Char (')'); | |
4513 | end; | |
4514 | end if; | |
4515 | ||
4516 | if Etype (Typ) /= Standard_Void_Type then | |
4517 | Write_Str (" return "); | |
4518 | Write_Id (Etype (Typ)); | |
4519 | end if; | |
4520 | ||
0c1edb56 ES |
4521 | when E_String_Literal_Subtype => |
4522 | declare | |
2f8313ce | 4523 | L : constant Uint := |
6a2afd13 | 4524 | Expr_Value (String_Literal_Low_Bound (Typ)); |
0c1edb56 ES |
4525 | Len : constant Uint := |
4526 | String_Literal_Length (Typ); | |
4527 | begin | |
b16ffa33 | 4528 | Write_Header (False); |
0c1edb56 | 4529 | Write_Str ("String ("); |
2f8313ce | 4530 | Write_Int (UI_To_Int (L)); |
0c1edb56 | 4531 | Write_Str (" .. "); |
2f8313ce | 4532 | Write_Int (UI_To_Int (L + Len) - 1); |
0c1edb56 ES |
4533 | Write_Str (");"); |
4534 | end; | |
4535 | ||
62b80eaf | 4536 | -- For all other Itypes, print ??? (fill in later) |
653da906 RD |
4537 | |
4538 | when others => | |
4539 | Write_Header (True); | |
4540 | Write_Str ("???"); | |
653da906 RD |
4541 | end case; |
4542 | end if; | |
4543 | ||
4544 | -- Add terminating bracket and restore output buffer | |
4545 | ||
4546 | Write_Char (']'); | |
4547 | Write_Eol; | |
4548 | Restore_Output_Buffer (S); | |
4549 | end; | |
4550 | ||
4551 | Set_Itype_Printed (Typ); | |
4552 | end if; | |
4553 | end Write_Itype; | |
4554 | ||
996ae0b0 RK |
4555 | ------------------------------- |
4556 | -- Write_Name_With_Col_Check -- | |
4557 | ------------------------------- | |
4558 | ||
4559 | procedure Write_Name_With_Col_Check (N : Name_Id) is | |
4560 | J : Natural; | |
b99282c4 RD |
4561 | K : Natural; |
4562 | L : Natural; | |
996ae0b0 RK |
4563 | |
4564 | begin | |
9c5719f6 AC |
4565 | -- Avoid crashing on invalid Name_Ids |
4566 | ||
4567 | if not Is_Valid_Name (N) then | |
4568 | Write_Str ("<invalid name "); | |
4569 | Write_Int (Int (N)); | |
4570 | Write_Str (">"); | |
4571 | return; | |
4572 | end if; | |
4573 | ||
996ae0b0 RK |
4574 | Get_Name_String (N); |
4575 | ||
b99282c4 RD |
4576 | -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an |
4577 | -- upper case letter, nnn is one or more digits and b is a lower case | |
4578 | -- letter by C...b, so that listings do not depend on serial numbers. | |
996ae0b0 | 4579 | |
b99282c4 RD |
4580 | if Debug_Flag_II then |
4581 | J := 1; | |
4582 | while J < Name_Len - 1 loop | |
4583 | if Name_Buffer (J) in 'A' .. 'Z' | |
4584 | and then Name_Buffer (J + 1) in '0' .. '9' | |
4585 | then | |
4586 | K := J + 1; | |
4587 | while K < Name_Len loop | |
4588 | exit when Name_Buffer (K) not in '0' .. '9'; | |
4589 | K := K + 1; | |
4590 | end loop; | |
996ae0b0 | 4591 | |
b99282c4 RD |
4592 | if Name_Buffer (K) in 'a' .. 'z' then |
4593 | L := Name_Len - K + 1; | |
996ae0b0 | 4594 | |
b99282c4 RD |
4595 | Name_Buffer (J + 4 .. J + L + 3) := |
4596 | Name_Buffer (K .. Name_Len); | |
4597 | Name_Buffer (J + 1 .. J + 3) := "..."; | |
4598 | Name_Len := J + L + 3; | |
4599 | J := J + 5; | |
996ae0b0 RK |
4600 | |
4601 | else | |
b99282c4 | 4602 | J := K; |
996ae0b0 | 4603 | end if; |
996ae0b0 | 4604 | |
b99282c4 RD |
4605 | else |
4606 | J := J + 1; | |
4607 | end if; | |
4608 | end loop; | |
996ae0b0 RK |
4609 | end if; |
4610 | ||
4611 | -- Fall through for normal case | |
4612 | ||
4613 | Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); | |
4614 | end Write_Name_With_Col_Check; | |
4615 | ||
4616 | ------------------------------------ | |
4617 | -- Write_Name_With_Col_Check_Sloc -- | |
4618 | ------------------------------------ | |
4619 | ||
4620 | procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is | |
4621 | begin | |
9c5719f6 AC |
4622 | -- Avoid crashing on invalid Name_Ids |
4623 | ||
4624 | if not Is_Valid_Name (N) then | |
4625 | Write_Str ("<invalid name "); | |
4626 | Write_Int (Int (N)); | |
4627 | Write_Str (">"); | |
4628 | return; | |
4629 | end if; | |
4630 | ||
996ae0b0 RK |
4631 | Get_Name_String (N); |
4632 | Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); | |
4633 | end Write_Name_With_Col_Check_Sloc; | |
4634 | ||
4635 | -------------------- | |
4636 | -- Write_Operator -- | |
4637 | -------------------- | |
4638 | ||
4639 | procedure Write_Operator (N : Node_Id; S : String) is | |
4640 | F : Natural := S'First; | |
4641 | T : Natural := S'Last; | |
4642 | ||
4643 | begin | |
07fc65c4 | 4644 | -- If no overflow check, just write string out, and we are done |
996ae0b0 | 4645 | |
07fc65c4 GB |
4646 | if not Do_Overflow_Check (N) then |
4647 | Write_Str_Sloc (S); | |
4648 | ||
4649 | -- If overflow check, we want to surround the operator with curly | |
4650 | -- brackets, but not include spaces within the brackets. | |
4651 | ||
4652 | else | |
4653 | if S (F) = ' ' then | |
4654 | Write_Char (' '); | |
4655 | F := F + 1; | |
4656 | end if; | |
4657 | ||
4658 | if S (T) = ' ' then | |
4659 | T := T - 1; | |
4660 | end if; | |
996ae0b0 | 4661 | |
996ae0b0 RK |
4662 | Write_Char ('{'); |
4663 | Write_Str_Sloc (S (F .. T)); | |
4664 | Write_Char ('}'); | |
996ae0b0 | 4665 | |
07fc65c4 GB |
4666 | if S (S'Last) = ' ' then |
4667 | Write_Char (' '); | |
4668 | end if; | |
996ae0b0 RK |
4669 | end if; |
4670 | end Write_Operator; | |
4671 | ||
4672 | ----------------------- | |
4673 | -- Write_Param_Specs -- | |
4674 | ----------------------- | |
4675 | ||
4676 | procedure Write_Param_Specs (N : Node_Id) is | |
58009744 AC |
4677 | Specs : constant List_Id := Parameter_Specifications (N); |
4678 | Specs_Present : constant Boolean := Is_Non_Empty_List (Specs); | |
4679 | ||
4680 | Ent : Entity_Id; | |
4681 | Extras : Node_Id; | |
996ae0b0 RK |
4682 | Spec : Node_Id; |
4683 | Formal : Node_Id; | |
4684 | ||
58009744 AC |
4685 | Output : Boolean := False; |
4686 | -- Set true if we output at least one parameter | |
4687 | ||
996ae0b0 | 4688 | begin |
58009744 | 4689 | -- Write out explicit specs from Parameter_Speficiations list |
996ae0b0 | 4690 | |
58009744 | 4691 | if Specs_Present then |
996ae0b0 | 4692 | Write_Str_With_Col_Check (" ("); |
58009744 | 4693 | Output := True; |
996ae0b0 | 4694 | |
58009744 | 4695 | Spec := First (Specs); |
996ae0b0 RK |
4696 | loop |
4697 | Sprint_Node (Spec); | |
4698 | Formal := Defining_Identifier (Spec); | |
4699 | Next (Spec); | |
4700 | exit when Spec = Empty; | |
4701 | ||
4702 | -- Add semicolon, unless we are printing original tree and the | |
b61ebe4f AC |
4703 | -- next specification is part of a list (but not the first element |
4704 | -- of that list). | |
996ae0b0 RK |
4705 | |
4706 | if not Dump_Original_Only or else not Prev_Ids (Spec) then | |
4707 | Write_Str ("; "); | |
4708 | end if; | |
4709 | end loop; | |
58009744 | 4710 | end if; |
996ae0b0 | 4711 | |
58009744 | 4712 | -- See if we have extra formals |
996ae0b0 | 4713 | |
58009744 AC |
4714 | if Nkind_In (N, N_Function_Specification, |
4715 | N_Procedure_Specification) | |
4716 | then | |
4717 | Ent := Defining_Entity (N); | |
4718 | ||
4719 | -- Loop to write extra formals (if any) | |
4720 | ||
4721 | if Present (Ent) and then Is_Subprogram (Ent) then | |
4722 | Extras := Extra_Formals (Ent); | |
4723 | ||
4724 | if Present (Extras) then | |
4725 | if not Specs_Present then | |
4726 | Write_Str_With_Col_Check (" ("); | |
4727 | Output := True; | |
4728 | end if; | |
4729 | ||
4730 | Formal := Extras; | |
4731 | while Present (Formal) loop | |
4732 | if Specs_Present or else Formal /= Extras then | |
4733 | Write_Str ("; "); | |
4734 | end if; | |
4735 | ||
4736 | Write_Name_With_Col_Check (Chars (Formal)); | |
4737 | Write_Str (" : "); | |
4738 | Write_Name_With_Col_Check (Chars (Etype (Formal))); | |
4739 | Formal := Extra_Formal (Formal); | |
4740 | end loop; | |
4741 | end if; | |
4742 | end if; | |
4743 | end if; | |
996ae0b0 | 4744 | |
58009744 | 4745 | if Output then |
996ae0b0 RK |
4746 | Write_Char (')'); |
4747 | end if; | |
4748 | end Write_Param_Specs; | |
4749 | ||
39485a7b | 4750 | ----------------------- |
996ae0b0 | 4751 | -- Write_Rewrite_Str -- |
39485a7b | 4752 | ----------------------- |
996ae0b0 RK |
4753 | |
4754 | procedure Write_Rewrite_Str (S : String) is | |
4755 | begin | |
4756 | if not Dump_Generated_Only then | |
4757 | if S'Length = 3 and then S = ">>>" then | |
4758 | Write_Str (">>>"); | |
4759 | else | |
4760 | Write_Str_With_Col_Check (S); | |
4761 | end if; | |
4762 | end if; | |
4763 | end Write_Rewrite_Str; | |
4764 | ||
39485a7b ES |
4765 | ----------------------- |
4766 | -- Write_Source_Line -- | |
4767 | ----------------------- | |
4768 | ||
4769 | procedure Write_Source_Line (L : Physical_Line_Number) is | |
4770 | Loc : Source_Ptr; | |
4771 | Src : Source_Buffer_Ptr; | |
4772 | Scn : Source_Ptr; | |
4773 | ||
4774 | begin | |
4775 | if Dump_Source_Text then | |
4776 | Src := Source_Text (Current_Source_File); | |
4777 | Loc := Line_Start (L, Current_Source_File); | |
4778 | Write_Eol; | |
4779 | ||
4780 | -- See if line is a comment line, if not, and if not line one, | |
4781 | -- precede with blank line. | |
4782 | ||
4783 | Scn := Loc; | |
4784 | while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop | |
4785 | Scn := Scn + 1; | |
4786 | end loop; | |
4787 | ||
4788 | if (Src (Scn) in Line_Terminator | |
4789 | or else Src (Scn .. Scn + 1) /= "--") | |
4790 | and then L /= 1 | |
4791 | then | |
4792 | Write_Eol; | |
4793 | end if; | |
4794 | ||
4795 | -- Now write the source text of the line | |
4796 | ||
4797 | Write_Str ("-- "); | |
4798 | Write_Int (Int (L)); | |
4799 | Write_Str (": "); | |
4800 | ||
4801 | while Src (Loc) not in Line_Terminator loop | |
4802 | Write_Char (Src (Loc)); | |
4803 | Loc := Loc + 1; | |
4804 | end loop; | |
4805 | end if; | |
4806 | end Write_Source_Line; | |
4807 | ||
4808 | ------------------------ | |
4809 | -- Write_Source_Lines -- | |
4810 | ------------------------ | |
4811 | ||
4812 | procedure Write_Source_Lines (L : Physical_Line_Number) is | |
4813 | begin | |
4814 | while Last_Line_Printed < L loop | |
4815 | Last_Line_Printed := Last_Line_Printed + 1; | |
4816 | Write_Source_Line (Last_Line_Printed); | |
4817 | end loop; | |
4818 | end Write_Source_Lines; | |
4819 | ||
996ae0b0 RK |
4820 | -------------------- |
4821 | -- Write_Str_Sloc -- | |
4822 | -------------------- | |
4823 | ||
4824 | procedure Write_Str_Sloc (S : String) is | |
4825 | begin | |
4826 | for J in S'Range loop | |
4827 | Write_Char_Sloc (S (J)); | |
4828 | end loop; | |
4829 | end Write_Str_Sloc; | |
4830 | ||
4831 | ------------------------------ | |
4832 | -- Write_Str_With_Col_Check -- | |
4833 | ------------------------------ | |
4834 | ||
4835 | procedure Write_Str_With_Col_Check (S : String) is | |
4836 | begin | |
dcd8728b | 4837 | if Int (S'Last) + Column > Sprint_Line_Limit then |
996ae0b0 RK |
4838 | Write_Indent_Str (" "); |
4839 | ||
39485a7b ES |
4840 | if S (S'First) = ' ' then |
4841 | Write_Str (S (S'First + 1 .. S'Last)); | |
996ae0b0 RK |
4842 | else |
4843 | Write_Str (S); | |
4844 | end if; | |
4845 | ||
4846 | else | |
4847 | Write_Str (S); | |
4848 | end if; | |
4849 | end Write_Str_With_Col_Check; | |
4850 | ||
4851 | ----------------------------------- | |
4852 | -- Write_Str_With_Col_Check_Sloc -- | |
4853 | ----------------------------------- | |
4854 | ||
4855 | procedure Write_Str_With_Col_Check_Sloc (S : String) is | |
4856 | begin | |
dcd8728b | 4857 | if Int (S'Last) + Column > Sprint_Line_Limit then |
996ae0b0 RK |
4858 | Write_Indent_Str (" "); |
4859 | ||
39485a7b ES |
4860 | if S (S'First) = ' ' then |
4861 | Write_Str_Sloc (S (S'First + 1 .. S'Last)); | |
996ae0b0 RK |
4862 | else |
4863 | Write_Str_Sloc (S); | |
4864 | end if; | |
4865 | ||
4866 | else | |
4867 | Write_Str_Sloc (S); | |
4868 | end if; | |
4869 | end Write_Str_With_Col_Check_Sloc; | |
4870 | ||
ff7139c3 AC |
4871 | --------------------------- |
4872 | -- Write_Subprogram_Name -- | |
4873 | --------------------------- | |
4874 | ||
4875 | procedure Write_Subprogram_Name (N : Node_Id) is | |
4876 | begin | |
4877 | if not Comes_From_Source (N) | |
4878 | and then Is_Entity_Name (N) | |
4879 | then | |
4880 | declare | |
4881 | Ent : constant Entity_Id := Entity (N); | |
4882 | begin | |
4883 | if not In_Extended_Main_Source_Unit (Ent) | |
8ab31c0c | 4884 | and then In_Predefined_Unit (Ent) |
ff7139c3 AC |
4885 | then |
4886 | -- Run-time routine name, output name with a preceding dollar | |
4887 | -- making sure that we do not get a line split between them. | |
4888 | ||
4889 | Col_Check (Length_Of_Name (Chars (Ent)) + 1); | |
4890 | Write_Char ('$'); | |
4891 | Write_Name (Chars (Ent)); | |
4892 | return; | |
4893 | end if; | |
4894 | end; | |
4895 | end if; | |
4896 | ||
4897 | -- Normal case, not a run-time routine name | |
4898 | ||
4899 | Sprint_Node (N); | |
4900 | end Write_Subprogram_Name; | |
4901 | ||
653da906 RD |
4902 | ------------------------------- |
4903 | -- Write_Uint_With_Col_Check -- | |
4904 | ------------------------------- | |
4905 | ||
4906 | procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is | |
4907 | begin | |
4908 | Col_Check (UI_Decimal_Digits_Hi (U)); | |
4909 | UI_Write (U, Format); | |
4910 | end Write_Uint_With_Col_Check; | |
4911 | ||
996ae0b0 RK |
4912 | ------------------------------------ |
4913 | -- Write_Uint_With_Col_Check_Sloc -- | |
4914 | ------------------------------------ | |
4915 | ||
4916 | procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is | |
4917 | begin | |
4918 | Col_Check (UI_Decimal_Digits_Hi (U)); | |
4919 | Set_Debug_Sloc; | |
4920 | UI_Write (U, Format); | |
4921 | end Write_Uint_With_Col_Check_Sloc; | |
4922 | ||
4923 | ------------------------------------- | |
4924 | -- Write_Ureal_With_Col_Check_Sloc -- | |
4925 | ------------------------------------- | |
4926 | ||
4927 | procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is | |
4928 | D : constant Uint := Denominator (U); | |
4929 | N : constant Uint := Numerator (U); | |
996ae0b0 | 4930 | begin |
0d57c6f4 | 4931 | Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); |
996ae0b0 | 4932 | Set_Debug_Sloc; |
0d57c6f4 | 4933 | UR_Write (U, Brackets => True); |
996ae0b0 RK |
4934 | end Write_Ureal_With_Col_Check_Sloc; |
4935 | ||
4936 | end Sprint; |