]>
Commit | Line | Data |
---|---|---|
415dddc8 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- T R E E P R -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
88ff8916 | 9 | -- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- |
415dddc8 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- -- |
415dddc8 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. -- | |
415dddc8 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. -- |
415dddc8 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
c159409f | 26 | with Aspects; use Aspects; |
415dddc8 RK |
27 | with Atree; use Atree; |
28 | with Csets; use Csets; | |
29 | with Debug; use Debug; | |
30 | with Einfo; use Einfo; | |
31 | with Elists; use Elists; | |
32 | with Lib; use Lib; | |
33 | with Namet; use Namet; | |
34 | with Nlists; use Nlists; | |
35 | with Output; use Output; | |
36 | with Sem_Mech; use Sem_Mech; | |
37 | with Sinfo; use Sinfo; | |
38 | with Snames; use Snames; | |
39 | with Sinput; use Sinput; | |
40 | with Stand; use Stand; | |
41 | with Stringt; use Stringt; | |
7665e4bd | 42 | with SCIL_LL; use SCIL_LL; |
415dddc8 RK |
43 | with Treeprs; use Treeprs; |
44 | with Uintp; use Uintp; | |
45 | with Urealp; use Urealp; | |
46 | with Uname; use Uname; | |
47 | with Unchecked_Deallocation; | |
48 | ||
49 | package body Treepr is | |
50 | ||
51 | use Atree.Unchecked_Access; | |
52 | -- This module uses the unchecked access functions in package Atree | |
53 | -- since it does an untyped traversal of the tree (we do not want to | |
a90bd866 | 54 | -- count on the structure of the tree being correct in this routine). |
415dddc8 RK |
55 | |
56 | ---------------------------------- | |
57 | -- Approach Used for Tree Print -- | |
58 | ---------------------------------- | |
59 | ||
60 | -- When a complete subtree is being printed, a trace phase first marks | |
61 | -- the nodes and lists to be printed. This trace phase allocates logical | |
62 | -- numbers corresponding to the order in which the nodes and lists will | |
63 | -- be printed. The Node_Id, List_Id and Elist_Id values are mapped to | |
64 | -- logical node numbers using a hash table. Output is done using a set | |
65 | -- of Print_xxx routines, which are similar to the Write_xxx routines | |
66 | -- with the same name, except that they do not generate any output in | |
67 | -- the marking phase. This allows identical logic to be used in the | |
68 | -- two phases. | |
69 | ||
70 | -- Note that the hash table not only holds the serial numbers, but also | |
71 | -- acts as a record of which nodes have already been visited. In the | |
72 | -- marking phase, a node has been visited if it is already in the hash | |
73 | -- table, and in the printing phase, we can tell whether a node has | |
74 | -- already been printed by looking at the value of the serial number. | |
75 | ||
76 | ---------------------- | |
77 | -- Global Variables -- | |
78 | ---------------------- | |
79 | ||
80 | type Hash_Record is record | |
81 | Serial : Nat; | |
82 | -- Serial number for hash table entry. A value of zero means that | |
83 | -- the entry is currently unused. | |
84 | ||
85 | Id : Int; | |
86 | -- If serial number field is non-zero, contains corresponding Id value | |
87 | end record; | |
88 | ||
89 | type Hash_Table_Type is array (Nat range <>) of Hash_Record; | |
90 | type Access_Hash_Table_Type is access Hash_Table_Type; | |
91 | Hash_Table : Access_Hash_Table_Type; | |
92 | -- The hash table itself, see Serial_Number function for details of use | |
93 | ||
94 | Hash_Table_Len : Nat; | |
95 | -- Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing | |
96 | -- by Hash_Table_Len gives a remainder that is in Hash_Table'Range. | |
97 | ||
98 | Next_Serial_Number : Nat; | |
99 | -- Number of last visited node or list. Used during the marking phase to | |
100 | -- set proper node numbers in the hash table, and during the printing | |
101 | -- phase to make sure that a given node is not printed more than once. | |
102 | -- (nodes are printed in order during the printing phase, that's the | |
a90bd866 | 103 | -- point of numbering them in the first place). |
415dddc8 RK |
104 | |
105 | Printing_Descendants : Boolean; | |
106 | -- True if descendants are being printed, False if not. In the false case, | |
107 | -- only node Id's are printed. In the true case, node numbers as well as | |
108 | -- node Id's are printed, as described above. | |
109 | ||
110 | type Phase_Type is (Marking, Printing); | |
111 | -- Type for Phase variable | |
112 | ||
113 | Phase : Phase_Type; | |
114 | -- When an entire tree is being printed, the traversal operates in two | |
115 | -- phases. The first phase marks the nodes in use by installing node | |
116 | -- numbers in the node number table. The second phase prints the nodes. | |
117 | -- This variable indicates the current phase. | |
118 | ||
119 | ---------------------- | |
120 | -- Local Procedures -- | |
121 | ---------------------- | |
122 | ||
123 | procedure Print_End_Span (N : Node_Id); | |
124 | -- Special routine to print contents of End_Span field of node N. | |
125 | -- The format includes the implicit source location as well as the | |
126 | -- value of the field. | |
127 | ||
128 | procedure Print_Init; | |
129 | -- Initialize for printing of tree with descendents | |
130 | ||
131 | procedure Print_Term; | |
132 | -- Clean up after printing of tree with descendents | |
133 | ||
134 | procedure Print_Char (C : Character); | |
135 | -- Print character C if currently in print phase, noop if in marking phase | |
136 | ||
137 | procedure Print_Name (N : Name_Id); | |
138 | -- Print name from names table if currently in print phase, noop if in | |
139 | -- marking phase. Note that the name is output in mixed case mode. | |
140 | ||
ee1a7572 AC |
141 | procedure Print_Node_Header (N : Node_Id); |
142 | -- Print header line used by Print_Node and Print_Node_Briefly | |
143 | ||
415dddc8 RK |
144 | procedure Print_Node_Kind (N : Node_Id); |
145 | -- Print node kind name in mixed case if in print phase, noop if in | |
146 | -- marking phase. | |
147 | ||
148 | procedure Print_Str (S : String); | |
149 | -- Print string S if currently in print phase, noop if in marking phase | |
150 | ||
151 | procedure Print_Str_Mixed_Case (S : String); | |
152 | -- Like Print_Str, except that the string is printed in mixed case mode | |
153 | ||
154 | procedure Print_Int (I : Int); | |
155 | -- Print integer I if currently in print phase, noop if in marking phase | |
156 | ||
157 | procedure Print_Eol; | |
158 | -- Print end of line if currently in print phase, noop if in marking phase | |
159 | ||
160 | procedure Print_Node_Ref (N : Node_Id); | |
161 | -- Print "<empty>", "<error>" or "Node #nnn" with additional information | |
162 | -- in the latter case, including the Id and the Nkind of the node. | |
163 | ||
164 | procedure Print_List_Ref (L : List_Id); | |
165 | -- Print "<no list>", or "<empty node list>" or "Node list #nnn" | |
166 | ||
167 | procedure Print_Elist_Ref (E : Elist_Id); | |
168 | -- Print "<no elist>", or "<empty element list>" or "Element list #nnn" | |
169 | ||
170 | procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String); | |
171 | -- Called if the node being printed is an entity. Prints fields from the | |
172 | -- extension, using routines in Einfo to get the field names and flags. | |
173 | ||
174 | procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto); | |
175 | -- Print representation of Field value (name, tree, string, uint, charcode) | |
176 | -- The format parameter controls the format of printing in the case of an | |
177 | -- integer value (see UI_Write for details). | |
178 | ||
179 | procedure Print_Flag (F : Boolean); | |
180 | -- Print True or False | |
181 | ||
182 | procedure Print_Node | |
183 | (N : Node_Id; | |
184 | Prefix_Str : String; | |
185 | Prefix_Char : Character); | |
186 | -- This is the internal routine used to print a single node. Each line of | |
187 | -- output is preceded by Prefix_Str (which is used to set the indentation | |
188 | -- level and the bars used to link list elements). In addition, for lines | |
189 | -- other than the first, an additional character Prefix_Char is output. | |
190 | ||
191 | function Serial_Number (Id : Int) return Nat; | |
192 | -- Given a Node_Id, List_Id or Elist_Id, returns the previously assigned | |
193 | -- serial number, or zero if no serial number has yet been assigned. | |
194 | ||
195 | procedure Set_Serial_Number; | |
196 | -- Can be called only immediately following a call to Serial_Number that | |
197 | -- returned a value of zero. Causes the value of Next_Serial_Number to be | |
198 | -- placed in the hash table (corresponding to the Id argument used in the | |
199 | -- Serial_Number call), and increments Next_Serial_Number. | |
200 | ||
201 | procedure Visit_Node | |
202 | (N : Node_Id; | |
203 | Prefix_Str : String; | |
204 | Prefix_Char : Character); | |
205 | -- Called to process a single node in the case where descendents are to | |
206 | -- be printed before every line, and Prefix_Char added to all lines | |
207 | -- except the header line for the node. | |
208 | ||
209 | procedure Visit_List (L : List_Id; Prefix_Str : String); | |
210 | -- Visit_List is called to process a list in the case where descendents | |
211 | -- are to be printed. Prefix_Str is to be added to all printed lines. | |
212 | ||
213 | procedure Visit_Elist (E : Elist_Id; Prefix_Str : String); | |
214 | -- Visit_Elist is called to process an element list in the case where | |
215 | -- descendents are to be printed. Prefix_Str is to be added to all | |
216 | -- printed lines. | |
217 | ||
88ff8916 AC |
218 | ------- |
219 | -- p -- | |
220 | ------- | |
221 | ||
222 | function p (N : Union_Id) return Node_Or_Entity_Id is | |
223 | begin | |
224 | case N is | |
225 | when List_Low_Bound .. List_High_Bound - 1 => | |
226 | return Nlists.Parent (List_Id (N)); | |
227 | ||
228 | when Node_Range => | |
229 | return Atree.Parent (Node_Or_Entity_Id (N)); | |
230 | ||
231 | when others => | |
232 | Write_Int (Int (N)); | |
233 | Write_Str (" is not a Node_Id or List_Id value"); | |
234 | Write_Eol; | |
235 | return Empty; | |
236 | end case; | |
237 | end p; | |
238 | ||
415dddc8 | 239 | -------- |
07fc65c4 | 240 | -- pe -- |
415dddc8 RK |
241 | -------- |
242 | ||
07fc65c4 | 243 | procedure pe (E : Elist_Id) is |
415dddc8 RK |
244 | begin |
245 | Print_Tree_Elist (E); | |
07fc65c4 | 246 | end pe; |
415dddc8 RK |
247 | |
248 | -------- | |
07fc65c4 | 249 | -- pl -- |
415dddc8 RK |
250 | -------- |
251 | ||
9b998381 RD |
252 | procedure pl (L : Int) is |
253 | Lid : Int; | |
254 | ||
415dddc8 | 255 | begin |
9b998381 RD |
256 | if L < 0 then |
257 | Lid := L; | |
258 | ||
259 | -- This is the case where we transform e.g. +36 to -99999936 | |
260 | ||
261 | else | |
262 | if L <= 9 then | |
263 | Lid := -(99999990 + L); | |
264 | elsif L <= 99 then | |
265 | Lid := -(99999900 + L); | |
266 | elsif L <= 999 then | |
267 | Lid := -(99999000 + L); | |
268 | elsif L <= 9999 then | |
269 | Lid := -(99990000 + L); | |
270 | elsif L <= 99999 then | |
271 | Lid := -(99900000 + L); | |
272 | elsif L <= 999999 then | |
273 | Lid := -(99000000 + L); | |
274 | elsif L <= 9999999 then | |
275 | Lid := -(90000000 + L); | |
276 | else | |
277 | Lid := -L; | |
278 | end if; | |
279 | end if; | |
280 | ||
281 | -- Now output the list | |
282 | ||
283 | Print_Tree_List (List_Id (Lid)); | |
07fc65c4 | 284 | end pl; |
415dddc8 RK |
285 | |
286 | -------- | |
07fc65c4 | 287 | -- pn -- |
415dddc8 RK |
288 | -------- |
289 | ||
57a8057a | 290 | procedure pn (N : Union_Id) is |
415dddc8 | 291 | begin |
57a8057a AC |
292 | case N is |
293 | when List_Low_Bound .. List_High_Bound - 1 => | |
294 | pl (Int (N)); | |
295 | when Node_Range => | |
296 | Print_Tree_Node (Node_Id (N)); | |
297 | when Elist_Range => | |
298 | Print_Tree_Elist (Elist_Id (N)); | |
299 | when Elmt_Range => | |
76264f60 AC |
300 | declare |
301 | Id : constant Elmt_Id := Elmt_Id (N); | |
302 | begin | |
303 | if No (Id) then | |
304 | Write_Str ("No_Elmt"); | |
305 | Write_Eol; | |
306 | else | |
307 | Write_Str ("Elmt_Id --> "); | |
308 | Print_Tree_Node (Node (Id)); | |
309 | end if; | |
310 | end; | |
57a8057a AC |
311 | when Names_Range => |
312 | Namet.wn (Name_Id (N)); | |
313 | when Strings_Range => | |
314 | Write_String_Table_Entry (String_Id (N)); | |
315 | when Uint_Range => | |
316 | Uintp.pid (From_Union (N)); | |
317 | when Ureal_Range => | |
318 | Urealp.pr (From_Union (N)); | |
319 | when others => | |
320 | Write_Str ("Invalid Union_Id: "); | |
321 | Write_Int (Int (N)); | |
76264f60 | 322 | Write_Eol; |
57a8057a | 323 | end case; |
07fc65c4 | 324 | end pn; |
415dddc8 | 325 | |
57a8057a AC |
326 | -------- |
327 | -- pp -- | |
328 | -------- | |
329 | ||
330 | procedure pp (N : Union_Id) is | |
331 | begin | |
332 | pn (N); | |
333 | end pp; | |
334 | ||
415dddc8 RK |
335 | ---------------- |
336 | -- Print_Char -- | |
337 | ---------------- | |
338 | ||
339 | procedure Print_Char (C : Character) is | |
340 | begin | |
341 | if Phase = Printing then | |
342 | Write_Char (C); | |
343 | end if; | |
344 | end Print_Char; | |
345 | ||
346 | --------------------- | |
347 | -- Print_Elist_Ref -- | |
348 | --------------------- | |
349 | ||
350 | procedure Print_Elist_Ref (E : Elist_Id) is | |
351 | begin | |
352 | if Phase /= Printing then | |
353 | return; | |
354 | end if; | |
355 | ||
356 | if E = No_Elist then | |
357 | Write_Str ("<no elist>"); | |
358 | ||
359 | elsif Is_Empty_Elmt_List (E) then | |
360 | Write_Str ("Empty elist, (Elist_Id="); | |
361 | Write_Int (Int (E)); | |
362 | Write_Char (')'); | |
363 | ||
364 | else | |
365 | Write_Str ("(Elist_Id="); | |
366 | Write_Int (Int (E)); | |
367 | Write_Char (')'); | |
368 | ||
369 | if Printing_Descendants then | |
370 | Write_Str (" #"); | |
371 | Write_Int (Serial_Number (Int (E))); | |
372 | end if; | |
373 | end if; | |
374 | end Print_Elist_Ref; | |
375 | ||
376 | ------------------------- | |
377 | -- Print_Elist_Subtree -- | |
378 | ------------------------- | |
379 | ||
380 | procedure Print_Elist_Subtree (E : Elist_Id) is | |
381 | begin | |
382 | Print_Init; | |
383 | ||
384 | Next_Serial_Number := 1; | |
385 | Phase := Marking; | |
386 | Visit_Elist (E, ""); | |
387 | ||
388 | Next_Serial_Number := 1; | |
389 | Phase := Printing; | |
390 | Visit_Elist (E, ""); | |
391 | ||
392 | Print_Term; | |
393 | end Print_Elist_Subtree; | |
394 | ||
395 | -------------------- | |
396 | -- Print_End_Span -- | |
397 | -------------------- | |
398 | ||
399 | procedure Print_End_Span (N : Node_Id) is | |
400 | Val : constant Uint := End_Span (N); | |
401 | ||
402 | begin | |
403 | UI_Write (Val); | |
404 | Write_Str (" (Uint = "); | |
405 | Write_Int (Int (Field5 (N))); | |
406 | Write_Str (") "); | |
407 | ||
408 | if Val /= No_Uint then | |
409 | Write_Location (End_Location (N)); | |
410 | end if; | |
411 | end Print_End_Span; | |
412 | ||
413 | ----------------------- | |
414 | -- Print_Entity_Info -- | |
415 | ----------------------- | |
416 | ||
417 | procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is | |
418 | function Field_Present (U : Union_Id) return Boolean; | |
419 | -- Returns False unless the value U represents a missing value | |
420 | -- (Empty, No_Uint, No_Ureal or No_String) | |
421 | ||
422 | function Field_Present (U : Union_Id) return Boolean is | |
423 | begin | |
424 | return | |
425 | U /= Union_Id (Empty) and then | |
426 | U /= To_Union (No_Uint) and then | |
427 | U /= To_Union (No_Ureal) and then | |
428 | U /= Union_Id (No_String); | |
429 | end Field_Present; | |
430 | ||
431 | -- Start of processing for Print_Entity_Info | |
432 | ||
433 | begin | |
434 | Print_Str (Prefix); | |
435 | Print_Str ("Ekind = "); | |
436 | Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent))); | |
437 | Print_Eol; | |
438 | ||
439 | Print_Str (Prefix); | |
440 | Print_Str ("Etype = "); | |
441 | Print_Node_Ref (Etype (Ent)); | |
442 | Print_Eol; | |
443 | ||
444 | if Convention (Ent) /= Convention_Ada then | |
445 | Print_Str (Prefix); | |
446 | Print_Str ("Convention = "); | |
447 | ||
448 | -- Print convention name skipping the Convention_ at the start | |
449 | ||
450 | declare | |
451 | S : constant String := Convention_Id'Image (Convention (Ent)); | |
452 | ||
453 | begin | |
454 | Print_Str_Mixed_Case (S (12 .. S'Last)); | |
455 | Print_Eol; | |
456 | end; | |
457 | end if; | |
458 | ||
459 | if Field_Present (Field6 (Ent)) then | |
460 | Print_Str (Prefix); | |
461 | Write_Field6_Name (Ent); | |
462 | Write_Str (" = "); | |
463 | Print_Field (Field6 (Ent)); | |
464 | Print_Eol; | |
465 | end if; | |
466 | ||
467 | if Field_Present (Field7 (Ent)) then | |
468 | Print_Str (Prefix); | |
469 | Write_Field7_Name (Ent); | |
470 | Write_Str (" = "); | |
471 | Print_Field (Field7 (Ent)); | |
472 | Print_Eol; | |
473 | end if; | |
474 | ||
475 | if Field_Present (Field8 (Ent)) then | |
476 | Print_Str (Prefix); | |
477 | Write_Field8_Name (Ent); | |
478 | Write_Str (" = "); | |
479 | Print_Field (Field8 (Ent)); | |
480 | Print_Eol; | |
481 | end if; | |
482 | ||
483 | if Field_Present (Field9 (Ent)) then | |
484 | Print_Str (Prefix); | |
485 | Write_Field9_Name (Ent); | |
486 | Write_Str (" = "); | |
487 | Print_Field (Field9 (Ent)); | |
488 | Print_Eol; | |
489 | end if; | |
490 | ||
491 | if Field_Present (Field10 (Ent)) then | |
492 | Print_Str (Prefix); | |
493 | Write_Field10_Name (Ent); | |
494 | Write_Str (" = "); | |
495 | Print_Field (Field10 (Ent)); | |
496 | Print_Eol; | |
497 | end if; | |
498 | ||
499 | if Field_Present (Field11 (Ent)) then | |
500 | Print_Str (Prefix); | |
501 | Write_Field11_Name (Ent); | |
502 | Write_Str (" = "); | |
503 | Print_Field (Field11 (Ent)); | |
504 | Print_Eol; | |
505 | end if; | |
506 | ||
507 | if Field_Present (Field12 (Ent)) then | |
508 | Print_Str (Prefix); | |
509 | Write_Field12_Name (Ent); | |
510 | Write_Str (" = "); | |
511 | Print_Field (Field12 (Ent)); | |
512 | Print_Eol; | |
513 | end if; | |
514 | ||
515 | if Field_Present (Field13 (Ent)) then | |
516 | Print_Str (Prefix); | |
517 | Write_Field13_Name (Ent); | |
518 | Write_Str (" = "); | |
519 | Print_Field (Field13 (Ent)); | |
520 | Print_Eol; | |
521 | end if; | |
522 | ||
523 | if Field_Present (Field14 (Ent)) then | |
524 | Print_Str (Prefix); | |
525 | Write_Field14_Name (Ent); | |
526 | Write_Str (" = "); | |
527 | Print_Field (Field14 (Ent)); | |
528 | Print_Eol; | |
529 | end if; | |
530 | ||
531 | if Field_Present (Field15 (Ent)) then | |
532 | Print_Str (Prefix); | |
533 | Write_Field15_Name (Ent); | |
534 | Write_Str (" = "); | |
535 | Print_Field (Field15 (Ent)); | |
536 | Print_Eol; | |
537 | end if; | |
538 | ||
539 | if Field_Present (Field16 (Ent)) then | |
540 | Print_Str (Prefix); | |
541 | Write_Field16_Name (Ent); | |
542 | Write_Str (" = "); | |
543 | Print_Field (Field16 (Ent)); | |
544 | Print_Eol; | |
545 | end if; | |
546 | ||
547 | if Field_Present (Field17 (Ent)) then | |
548 | Print_Str (Prefix); | |
549 | Write_Field17_Name (Ent); | |
550 | Write_Str (" = "); | |
551 | Print_Field (Field17 (Ent)); | |
552 | Print_Eol; | |
553 | end if; | |
554 | ||
555 | if Field_Present (Field18 (Ent)) then | |
556 | Print_Str (Prefix); | |
557 | Write_Field18_Name (Ent); | |
558 | Write_Str (" = "); | |
559 | Print_Field (Field18 (Ent)); | |
560 | Print_Eol; | |
561 | end if; | |
562 | ||
563 | if Field_Present (Field19 (Ent)) then | |
564 | Print_Str (Prefix); | |
565 | Write_Field19_Name (Ent); | |
566 | Write_Str (" = "); | |
567 | Print_Field (Field19 (Ent)); | |
568 | Print_Eol; | |
569 | end if; | |
570 | ||
571 | if Field_Present (Field20 (Ent)) then | |
572 | Print_Str (Prefix); | |
573 | Write_Field20_Name (Ent); | |
574 | Write_Str (" = "); | |
575 | Print_Field (Field20 (Ent)); | |
576 | Print_Eol; | |
577 | end if; | |
578 | ||
579 | if Field_Present (Field21 (Ent)) then | |
580 | Print_Str (Prefix); | |
581 | Write_Field21_Name (Ent); | |
582 | Write_Str (" = "); | |
583 | Print_Field (Field21 (Ent)); | |
584 | Print_Eol; | |
585 | end if; | |
586 | ||
587 | if Field_Present (Field22 (Ent)) then | |
588 | Print_Str (Prefix); | |
589 | Write_Field22_Name (Ent); | |
590 | Write_Str (" = "); | |
591 | ||
592 | -- Mechanism case has to be handled specially | |
593 | ||
594 | if Ekind (Ent) = E_Function or else Is_Formal (Ent) then | |
595 | declare | |
596 | M : constant Mechanism_Type := Mechanism (Ent); | |
597 | ||
598 | begin | |
599 | case M is | |
d628c015 DR |
600 | when Default_Mechanism |
601 | => Write_Str ("Default"); | |
602 | when By_Copy | |
603 | => Write_Str ("By_Copy"); | |
604 | when By_Reference | |
605 | => Write_Str ("By_Reference"); | |
606 | when By_Descriptor | |
607 | => Write_Str ("By_Descriptor"); | |
608 | when By_Descriptor_UBS | |
609 | => Write_Str ("By_Descriptor_UBS"); | |
610 | when By_Descriptor_UBSB | |
611 | => Write_Str ("By_Descriptor_UBSB"); | |
612 | when By_Descriptor_UBA | |
613 | => Write_Str ("By_Descriptor_UBA"); | |
614 | when By_Descriptor_S | |
615 | => Write_Str ("By_Descriptor_S"); | |
616 | when By_Descriptor_SB | |
617 | => Write_Str ("By_Descriptor_SB"); | |
618 | when By_Descriptor_A | |
619 | => Write_Str ("By_Descriptor_A"); | |
620 | when By_Descriptor_NCA | |
621 | => Write_Str ("By_Descriptor_NCA"); | |
622 | when By_Short_Descriptor | |
623 | => Write_Str ("By_Short_Descriptor"); | |
624 | when By_Short_Descriptor_UBS | |
625 | => Write_Str ("By_Short_Descriptor_UBS"); | |
626 | when By_Short_Descriptor_UBSB | |
627 | => Write_Str ("By_Short_Descriptor_UBSB"); | |
628 | when By_Short_Descriptor_UBA | |
629 | => Write_Str ("By_Short_Descriptor_UBA"); | |
630 | when By_Short_Descriptor_S | |
631 | => Write_Str ("By_Short_Descriptor_S"); | |
632 | when By_Short_Descriptor_SB | |
633 | => Write_Str ("By_Short_Descriptor_SB"); | |
634 | when By_Short_Descriptor_A | |
635 | => Write_Str ("By_Short_Descriptor_A"); | |
636 | when By_Short_Descriptor_NCA | |
637 | => Write_Str ("By_Short_Descriptor_NCA"); | |
415dddc8 RK |
638 | |
639 | when 1 .. Mechanism_Type'Last => | |
640 | Write_Str ("By_Copy if size <= "); | |
641 | Write_Int (Int (M)); | |
642 | ||
643 | end case; | |
644 | end; | |
645 | ||
646 | -- Normal case (not Mechanism) | |
647 | ||
648 | else | |
649 | Print_Field (Field22 (Ent)); | |
650 | end if; | |
651 | ||
652 | Print_Eol; | |
653 | end if; | |
654 | ||
655 | if Field_Present (Field23 (Ent)) then | |
656 | Print_Str (Prefix); | |
657 | Write_Field23_Name (Ent); | |
658 | Write_Str (" = "); | |
659 | Print_Field (Field23 (Ent)); | |
660 | Print_Eol; | |
661 | end if; | |
662 | ||
165eab5f AC |
663 | if Field_Present (Field24 (Ent)) then |
664 | Print_Str (Prefix); | |
665 | Write_Field24_Name (Ent); | |
666 | Write_Str (" = "); | |
667 | Print_Field (Field24 (Ent)); | |
668 | Print_Eol; | |
669 | end if; | |
415dddc8 | 670 | |
165eab5f AC |
671 | if Field_Present (Field25 (Ent)) then |
672 | Print_Str (Prefix); | |
673 | Write_Field25_Name (Ent); | |
674 | Write_Str (" = "); | |
675 | Print_Field (Field25 (Ent)); | |
676 | Print_Eol; | |
677 | end if; | |
678 | ||
679 | if Field_Present (Field26 (Ent)) then | |
680 | Print_Str (Prefix); | |
681 | Write_Field26_Name (Ent); | |
682 | Write_Str (" = "); | |
683 | Print_Field (Field26 (Ent)); | |
684 | Print_Eol; | |
685 | end if; | |
686 | ||
687 | if Field_Present (Field27 (Ent)) then | |
688 | Print_Str (Prefix); | |
689 | Write_Field27_Name (Ent); | |
690 | Write_Str (" = "); | |
691 | Print_Field (Field27 (Ent)); | |
692 | Print_Eol; | |
693 | end if; | |
694 | ||
e2cc5258 AC |
695 | if Field_Present (Field28 (Ent)) then |
696 | Print_Str (Prefix); | |
697 | Write_Field28_Name (Ent); | |
698 | Write_Str (" = "); | |
699 | Print_Field (Field28 (Ent)); | |
700 | Print_Eol; | |
701 | end if; | |
702 | ||
e606088a AC |
703 | if Field_Present (Field29 (Ent)) then |
704 | Print_Str (Prefix); | |
705 | Write_Field29_Name (Ent); | |
706 | Write_Str (" = "); | |
707 | Print_Field (Field29 (Ent)); | |
708 | Print_Eol; | |
709 | end if; | |
710 | ||
477cfc5b AC |
711 | if Field_Present (Field30 (Ent)) then |
712 | Print_Str (Prefix); | |
713 | Write_Field30_Name (Ent); | |
714 | Write_Str (" = "); | |
715 | Print_Field (Field30 (Ent)); | |
716 | Print_Eol; | |
717 | end if; | |
718 | ||
719 | if Field_Present (Field31 (Ent)) then | |
720 | Print_Str (Prefix); | |
721 | Write_Field31_Name (Ent); | |
722 | Write_Str (" = "); | |
723 | Print_Field (Field31 (Ent)); | |
724 | Print_Eol; | |
725 | end if; | |
726 | ||
727 | if Field_Present (Field32 (Ent)) then | |
728 | Print_Str (Prefix); | |
729 | Write_Field32_Name (Ent); | |
730 | Write_Str (" = "); | |
731 | Print_Field (Field32 (Ent)); | |
732 | Print_Eol; | |
733 | end if; | |
734 | ||
735 | if Field_Present (Field33 (Ent)) then | |
736 | Print_Str (Prefix); | |
737 | Write_Field33_Name (Ent); | |
738 | Write_Str (" = "); | |
739 | Print_Field (Field33 (Ent)); | |
740 | Print_Eol; | |
741 | end if; | |
742 | ||
743 | if Field_Present (Field34 (Ent)) then | |
744 | Print_Str (Prefix); | |
745 | Write_Field34_Name (Ent); | |
746 | Write_Str (" = "); | |
747 | Print_Field (Field34 (Ent)); | |
748 | Print_Eol; | |
749 | end if; | |
750 | ||
751 | if Field_Present (Field35 (Ent)) then | |
752 | Print_Str (Prefix); | |
753 | Write_Field35_Name (Ent); | |
754 | Write_Str (" = "); | |
755 | Print_Field (Field35 (Ent)); | |
756 | Print_Eol; | |
757 | end if; | |
758 | ||
165eab5f | 759 | Write_Entity_Flags (Ent, Prefix); |
415dddc8 RK |
760 | end Print_Entity_Info; |
761 | ||
762 | --------------- | |
763 | -- Print_Eol -- | |
764 | --------------- | |
765 | ||
766 | procedure Print_Eol is | |
767 | begin | |
768 | if Phase = Printing then | |
769 | Write_Eol; | |
770 | end if; | |
771 | end Print_Eol; | |
772 | ||
773 | ----------------- | |
774 | -- Print_Field -- | |
775 | ----------------- | |
776 | ||
777 | procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is | |
778 | begin | |
779 | if Phase /= Printing then | |
780 | return; | |
781 | end if; | |
782 | ||
783 | if Val in Node_Range then | |
784 | Print_Node_Ref (Node_Id (Val)); | |
785 | ||
786 | elsif Val in List_Range then | |
787 | Print_List_Ref (List_Id (Val)); | |
788 | ||
789 | elsif Val in Elist_Range then | |
790 | Print_Elist_Ref (Elist_Id (Val)); | |
791 | ||
792 | elsif Val in Names_Range then | |
793 | Print_Name (Name_Id (Val)); | |
794 | Write_Str (" (Name_Id="); | |
795 | Write_Int (Int (Val)); | |
796 | Write_Char (')'); | |
797 | ||
798 | elsif Val in Strings_Range then | |
799 | Write_String_Table_Entry (String_Id (Val)); | |
800 | Write_Str (" (String_Id="); | |
801 | Write_Int (Int (Val)); | |
802 | Write_Char (')'); | |
803 | ||
804 | elsif Val in Uint_Range then | |
805 | UI_Write (From_Union (Val), Format); | |
806 | Write_Str (" (Uint = "); | |
807 | Write_Int (Int (Val)); | |
808 | Write_Char (')'); | |
809 | ||
810 | elsif Val in Ureal_Range then | |
811 | UR_Write (From_Union (Val)); | |
812 | Write_Str (" (Ureal = "); | |
813 | Write_Int (Int (Val)); | |
814 | Write_Char (')'); | |
815 | ||
415dddc8 RK |
816 | else |
817 | Print_Str ("****** Incorrect value = "); | |
818 | Print_Int (Int (Val)); | |
819 | end if; | |
820 | end Print_Field; | |
821 | ||
822 | ---------------- | |
823 | -- Print_Flag -- | |
824 | ---------------- | |
825 | ||
826 | procedure Print_Flag (F : Boolean) is | |
827 | begin | |
828 | if F then | |
829 | Print_Str ("True"); | |
830 | else | |
831 | Print_Str ("False"); | |
832 | end if; | |
833 | end Print_Flag; | |
834 | ||
835 | ---------------- | |
836 | -- Print_Init -- | |
837 | ---------------- | |
838 | ||
839 | procedure Print_Init is | |
840 | begin | |
841 | Printing_Descendants := True; | |
842 | Write_Eol; | |
843 | ||
844 | -- Allocate and clear serial number hash table. The size is 150% of | |
845 | -- the maximum possible number of entries, so that the hash table | |
846 | -- cannot get significantly overloaded. | |
847 | ||
848 | Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100; | |
849 | Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1); | |
850 | ||
851 | for J in Hash_Table'Range loop | |
852 | Hash_Table (J).Serial := 0; | |
853 | end loop; | |
854 | ||
855 | end Print_Init; | |
856 | ||
857 | --------------- | |
858 | -- Print_Int -- | |
859 | --------------- | |
860 | ||
861 | procedure Print_Int (I : Int) is | |
862 | begin | |
863 | if Phase = Printing then | |
864 | Write_Int (I); | |
865 | end if; | |
866 | end Print_Int; | |
867 | ||
868 | -------------------- | |
869 | -- Print_List_Ref -- | |
870 | -------------------- | |
871 | ||
872 | procedure Print_List_Ref (L : List_Id) is | |
873 | begin | |
874 | if Phase /= Printing then | |
875 | return; | |
876 | end if; | |
877 | ||
878 | if No (L) then | |
879 | Write_Str ("<no list>"); | |
880 | ||
881 | elsif Is_Empty_List (L) then | |
882 | Write_Str ("<empty list> (List_Id="); | |
883 | Write_Int (Int (L)); | |
884 | Write_Char (')'); | |
885 | ||
886 | else | |
887 | Write_Str ("List"); | |
888 | ||
889 | if Printing_Descendants then | |
890 | Write_Str (" #"); | |
891 | Write_Int (Serial_Number (Int (L))); | |
892 | end if; | |
893 | ||
894 | Write_Str (" (List_Id="); | |
895 | Write_Int (Int (L)); | |
896 | Write_Char (')'); | |
897 | end if; | |
898 | end Print_List_Ref; | |
899 | ||
900 | ------------------------ | |
901 | -- Print_List_Subtree -- | |
902 | ------------------------ | |
903 | ||
904 | procedure Print_List_Subtree (L : List_Id) is | |
905 | begin | |
906 | Print_Init; | |
907 | ||
908 | Next_Serial_Number := 1; | |
909 | Phase := Marking; | |
910 | Visit_List (L, ""); | |
911 | ||
912 | Next_Serial_Number := 1; | |
913 | Phase := Printing; | |
914 | Visit_List (L, ""); | |
915 | ||
916 | Print_Term; | |
917 | end Print_List_Subtree; | |
918 | ||
919 | ---------------- | |
920 | -- Print_Name -- | |
921 | ---------------- | |
922 | ||
923 | procedure Print_Name (N : Name_Id) is | |
924 | begin | |
925 | if Phase = Printing then | |
926 | if N = No_Name then | |
927 | Print_Str ("<No_Name>"); | |
928 | ||
929 | elsif N = Error_Name then | |
930 | Print_Str ("<Error_Name>"); | |
931 | ||
87ace727 | 932 | elsif Is_Valid_Name (N) then |
415dddc8 RK |
933 | Get_Name_String (N); |
934 | Print_Char ('"'); | |
935 | Write_Name (N); | |
936 | Print_Char ('"'); | |
87ace727 RD |
937 | |
938 | else | |
939 | Print_Str ("<invalid name ???>"); | |
415dddc8 RK |
940 | end if; |
941 | end if; | |
942 | end Print_Name; | |
943 | ||
944 | ---------------- | |
945 | -- Print_Node -- | |
946 | ---------------- | |
947 | ||
948 | procedure Print_Node | |
949 | (N : Node_Id; | |
950 | Prefix_Str : String; | |
951 | Prefix_Char : Character) | |
952 | is | |
953 | F : Fchar; | |
954 | P : Natural := Pchar_Pos (Nkind (N)); | |
955 | ||
956 | Field_To_Be_Printed : Boolean; | |
957 | Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1); | |
958 | ||
e3b3266c | 959 | Sfile : Source_File_Index; |
415dddc8 RK |
960 | Fmt : UI_Format; |
961 | ||
962 | begin | |
963 | if Phase /= Printing then | |
964 | return; | |
965 | end if; | |
966 | ||
967 | if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then | |
968 | Fmt := Hex; | |
969 | else | |
970 | Fmt := Auto; | |
971 | end if; | |
972 | ||
973 | Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str; | |
974 | Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char; | |
975 | ||
976 | -- Print header line | |
977 | ||
978 | Print_Str (Prefix_Str); | |
ee1a7572 | 979 | Print_Node_Header (N); |
415dddc8 RK |
980 | |
981 | if Is_Rewrite_Substitution (N) then | |
982 | Print_Str (Prefix_Str); | |
983 | Print_Str (" Rewritten: original node = "); | |
984 | Print_Node_Ref (Original_Node (N)); | |
985 | Print_Eol; | |
986 | end if; | |
987 | ||
988 | if N = Empty then | |
989 | return; | |
990 | end if; | |
991 | ||
992 | if not Is_List_Member (N) then | |
993 | Print_Str (Prefix_Str); | |
994 | Print_Str (" Parent = "); | |
995 | Print_Node_Ref (Parent (N)); | |
996 | Print_Eol; | |
997 | end if; | |
998 | ||
999 | -- Print Sloc field if it is set | |
1000 | ||
1001 | if Sloc (N) /= No_Location then | |
1002 | Print_Str (Prefix_Str_Char); | |
1003 | Print_Str ("Sloc = "); | |
1004 | ||
e3b3266c AC |
1005 | if Sloc (N) = Standard_Location then |
1006 | Print_Str ("Standard_Location"); | |
1007 | ||
1008 | elsif Sloc (N) = Standard_ASCII_Location then | |
1009 | Print_Str ("Standard_ASCII_Location"); | |
1010 | ||
1011 | else | |
1012 | Sfile := Get_Source_File_Index (Sloc (N)); | |
1013 | Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First)); | |
1014 | Write_Str (" "); | |
1015 | Write_Location (Sloc (N)); | |
1016 | end if; | |
1017 | ||
1018 | Print_Eol; | |
415dddc8 RK |
1019 | end if; |
1020 | ||
1021 | -- Print Chars field if present | |
1022 | ||
1023 | if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then | |
1024 | Print_Str (Prefix_Str_Char); | |
1025 | Print_Str ("Chars = "); | |
1026 | Print_Name (Chars (N)); | |
1027 | Write_Str (" (Name_Id="); | |
1028 | Write_Int (Int (Chars (N))); | |
1029 | Write_Char (')'); | |
1030 | Print_Eol; | |
1031 | end if; | |
1032 | ||
1033 | -- Special field print operations for non-entity nodes | |
1034 | ||
1035 | if Nkind (N) not in N_Entity then | |
1036 | ||
1037 | -- Deal with Left_Opnd and Right_Opnd fields | |
1038 | ||
1039 | if Nkind (N) in N_Op | |
514d0fc5 | 1040 | or else Nkind (N) in N_Short_Circuit |
c064e066 | 1041 | or else Nkind (N) in N_Membership_Test |
415dddc8 RK |
1042 | then |
1043 | -- Print Left_Opnd if present | |
1044 | ||
1045 | if Nkind (N) not in N_Unary_Op then | |
1046 | Print_Str (Prefix_Str_Char); | |
1047 | Print_Str ("Left_Opnd = "); | |
1048 | Print_Node_Ref (Left_Opnd (N)); | |
1049 | Print_Eol; | |
1050 | end if; | |
1051 | ||
1052 | -- Print Right_Opnd | |
1053 | ||
1054 | Print_Str (Prefix_Str_Char); | |
1055 | Print_Str ("Right_Opnd = "); | |
1056 | Print_Node_Ref (Right_Opnd (N)); | |
1057 | Print_Eol; | |
1058 | end if; | |
1059 | ||
1060 | -- Print Entity field if operator (other cases of Entity | |
1061 | -- are in the table, so are handled in the normal circuit) | |
1062 | ||
1063 | if Nkind (N) in N_Op and then Present (Entity (N)) then | |
1064 | Print_Str (Prefix_Str_Char); | |
1065 | Print_Str ("Entity = "); | |
1066 | Print_Node_Ref (Entity (N)); | |
1067 | Print_Eol; | |
1068 | end if; | |
1069 | ||
1070 | -- Print special fields if we have a subexpression | |
1071 | ||
1072 | if Nkind (N) in N_Subexpr then | |
1073 | ||
1074 | if Assignment_OK (N) then | |
1075 | Print_Str (Prefix_Str_Char); | |
1076 | Print_Str ("Assignment_OK = True"); | |
1077 | Print_Eol; | |
1078 | end if; | |
1079 | ||
1080 | if Do_Range_Check (N) then | |
1081 | Print_Str (Prefix_Str_Char); | |
1082 | Print_Str ("Do_Range_Check = True"); | |
1083 | Print_Eol; | |
1084 | end if; | |
1085 | ||
1086 | if Has_Dynamic_Length_Check (N) then | |
1087 | Print_Str (Prefix_Str_Char); | |
1088 | Print_Str ("Has_Dynamic_Length_Check = True"); | |
1089 | Print_Eol; | |
1090 | end if; | |
1091 | ||
c159409f AC |
1092 | if Has_Aspects (N) then |
1093 | Print_Str (Prefix_Str_Char); | |
1094 | Print_Str ("Has_Aspects = True"); | |
1095 | Print_Eol; | |
1096 | end if; | |
1097 | ||
415dddc8 RK |
1098 | if Has_Dynamic_Range_Check (N) then |
1099 | Print_Str (Prefix_Str_Char); | |
1100 | Print_Str ("Has_Dynamic_Range_Check = True"); | |
1101 | Print_Eol; | |
1102 | end if; | |
1103 | ||
1104 | if Is_Controlling_Actual (N) then | |
1105 | Print_Str (Prefix_Str_Char); | |
1106 | Print_Str ("Is_Controlling_Actual = True"); | |
1107 | Print_Eol; | |
1108 | end if; | |
1109 | ||
1110 | if Is_Overloaded (N) then | |
1111 | Print_Str (Prefix_Str_Char); | |
1112 | Print_Str ("Is_Overloaded = True"); | |
1113 | Print_Eol; | |
1114 | end if; | |
1115 | ||
1116 | if Is_Static_Expression (N) then | |
1117 | Print_Str (Prefix_Str_Char); | |
1118 | Print_Str ("Is_Static_Expression = True"); | |
1119 | Print_Eol; | |
1120 | end if; | |
1121 | ||
1122 | if Must_Not_Freeze (N) then | |
1123 | Print_Str (Prefix_Str_Char); | |
1124 | Print_Str ("Must_Not_Freeze = True"); | |
1125 | Print_Eol; | |
1126 | end if; | |
1127 | ||
1128 | if Paren_Count (N) /= 0 then | |
1129 | Print_Str (Prefix_Str_Char); | |
1130 | Print_Str ("Paren_Count = "); | |
1131 | Print_Int (Int (Paren_Count (N))); | |
1132 | Print_Eol; | |
1133 | end if; | |
1134 | ||
1135 | if Raises_Constraint_Error (N) then | |
1136 | Print_Str (Prefix_Str_Char); | |
1137 | Print_Str ("Raise_Constraint_Error = True"); | |
1138 | Print_Eol; | |
1139 | end if; | |
1140 | ||
1141 | end if; | |
1142 | ||
1143 | -- Print Do_Overflow_Check field if present | |
1144 | ||
1145 | if Nkind (N) in N_Op and then Do_Overflow_Check (N) then | |
1146 | Print_Str (Prefix_Str_Char); | |
1147 | Print_Str ("Do_Overflow_Check = True"); | |
1148 | Print_Eol; | |
1149 | end if; | |
1150 | ||
1151 | -- Print Etype field if present (printing of this field for entities | |
1152 | -- is handled by the Print_Entity_Info procedure). | |
1153 | ||
a99ada67 | 1154 | if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then |
415dddc8 RK |
1155 | Print_Str (Prefix_Str_Char); |
1156 | Print_Str ("Etype = "); | |
1157 | Print_Node_Ref (Etype (N)); | |
1158 | Print_Eol; | |
1159 | end if; | |
1160 | end if; | |
1161 | ||
1162 | -- Loop to print fields included in Pchars array | |
1163 | ||
1164 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop | |
1165 | F := Pchars (P); | |
1166 | P := P + 1; | |
1167 | ||
1168 | -- Check for case of False flag, which we never print, or | |
1169 | -- an Empty field, which is also never printed | |
1170 | ||
1171 | case F is | |
1172 | when F_Field1 => | |
1173 | Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty); | |
1174 | ||
1175 | when F_Field2 => | |
1176 | Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty); | |
1177 | ||
1178 | when F_Field3 => | |
1179 | Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty); | |
1180 | ||
1181 | when F_Field4 => | |
1182 | Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty); | |
1183 | ||
1184 | when F_Field5 => | |
1185 | Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); | |
1186 | ||
8d81fb4e AC |
1187 | when F_Flag1 => Field_To_Be_Printed := Flag1 (N); |
1188 | when F_Flag2 => Field_To_Be_Printed := Flag2 (N); | |
1189 | when F_Flag3 => Field_To_Be_Printed := Flag3 (N); | |
415dddc8 RK |
1190 | when F_Flag4 => Field_To_Be_Printed := Flag4 (N); |
1191 | when F_Flag5 => Field_To_Be_Printed := Flag5 (N); | |
1192 | when F_Flag6 => Field_To_Be_Printed := Flag6 (N); | |
1193 | when F_Flag7 => Field_To_Be_Printed := Flag7 (N); | |
1194 | when F_Flag8 => Field_To_Be_Printed := Flag8 (N); | |
1195 | when F_Flag9 => Field_To_Be_Printed := Flag9 (N); | |
1196 | when F_Flag10 => Field_To_Be_Printed := Flag10 (N); | |
1197 | when F_Flag11 => Field_To_Be_Printed := Flag11 (N); | |
1198 | when F_Flag12 => Field_To_Be_Printed := Flag12 (N); | |
1199 | when F_Flag13 => Field_To_Be_Printed := Flag13 (N); | |
1200 | when F_Flag14 => Field_To_Be_Printed := Flag14 (N); | |
1201 | when F_Flag15 => Field_To_Be_Printed := Flag15 (N); | |
1202 | when F_Flag16 => Field_To_Be_Printed := Flag16 (N); | |
1203 | when F_Flag17 => Field_To_Be_Printed := Flag17 (N); | |
1204 | when F_Flag18 => Field_To_Be_Printed := Flag18 (N); | |
415dddc8 RK |
1205 | end case; |
1206 | ||
1207 | -- Print field if it is to be printed | |
1208 | ||
1209 | if Field_To_Be_Printed then | |
1210 | Print_Str (Prefix_Str_Char); | |
1211 | ||
1212 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) | |
1213 | and then Pchars (P) not in Fchar | |
1214 | loop | |
1215 | Print_Char (Pchars (P)); | |
1216 | P := P + 1; | |
1217 | end loop; | |
1218 | ||
1219 | Print_Str (" = "); | |
1220 | ||
1221 | case F is | |
1222 | when F_Field1 => Print_Field (Field1 (N), Fmt); | |
1223 | when F_Field2 => Print_Field (Field2 (N), Fmt); | |
1224 | when F_Field3 => Print_Field (Field3 (N), Fmt); | |
1225 | when F_Field4 => Print_Field (Field4 (N), Fmt); | |
1226 | ||
1227 | -- Special case End_Span = Uint5 | |
1228 | ||
1229 | when F_Field5 => | |
8d81fb4e | 1230 | if Nkind_In (N, N_Case_Statement, N_If_Statement) then |
415dddc8 RK |
1231 | Print_End_Span (N); |
1232 | else | |
1233 | Print_Field (Field5 (N), Fmt); | |
1234 | end if; | |
1235 | ||
8d81fb4e AC |
1236 | when F_Flag1 => Print_Flag (Flag1 (N)); |
1237 | when F_Flag2 => Print_Flag (Flag2 (N)); | |
1238 | when F_Flag3 => Print_Flag (Flag3 (N)); | |
415dddc8 RK |
1239 | when F_Flag4 => Print_Flag (Flag4 (N)); |
1240 | when F_Flag5 => Print_Flag (Flag5 (N)); | |
1241 | when F_Flag6 => Print_Flag (Flag6 (N)); | |
1242 | when F_Flag7 => Print_Flag (Flag7 (N)); | |
1243 | when F_Flag8 => Print_Flag (Flag8 (N)); | |
1244 | when F_Flag9 => Print_Flag (Flag9 (N)); | |
1245 | when F_Flag10 => Print_Flag (Flag10 (N)); | |
1246 | when F_Flag11 => Print_Flag (Flag11 (N)); | |
1247 | when F_Flag12 => Print_Flag (Flag12 (N)); | |
1248 | when F_Flag13 => Print_Flag (Flag13 (N)); | |
1249 | when F_Flag14 => Print_Flag (Flag14 (N)); | |
1250 | when F_Flag15 => Print_Flag (Flag15 (N)); | |
1251 | when F_Flag16 => Print_Flag (Flag16 (N)); | |
1252 | when F_Flag17 => Print_Flag (Flag17 (N)); | |
1253 | when F_Flag18 => Print_Flag (Flag18 (N)); | |
415dddc8 RK |
1254 | end case; |
1255 | ||
1256 | Print_Eol; | |
1257 | ||
1258 | -- Field is not to be printed (False flag field) | |
1259 | ||
1260 | else | |
1261 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) | |
1262 | and then Pchars (P) not in Fchar | |
1263 | loop | |
1264 | P := P + 1; | |
1265 | end loop; | |
1266 | end if; | |
415dddc8 RK |
1267 | end loop; |
1268 | ||
c159409f AC |
1269 | -- Print aspects if present |
1270 | ||
1271 | if Has_Aspects (N) then | |
1272 | Print_Str (Prefix_Str_Char); | |
1273 | Print_Str ("Aspect_Specifications = "); | |
1274 | Print_Field (Union_Id (Aspect_Specifications (N))); | |
1275 | Print_Eol; | |
1276 | end if; | |
1277 | ||
415dddc8 RK |
1278 | -- Print entity information for entities |
1279 | ||
1280 | if Nkind (N) in N_Entity then | |
1281 | Print_Entity_Info (N, Prefix_Str_Char); | |
1282 | end if; | |
1283 | ||
7665e4bd AC |
1284 | -- Print the SCIL node (if available) |
1285 | ||
1286 | if Present (Get_SCIL_Node (N)) then | |
1287 | Print_Str (Prefix_Str_Char); | |
1288 | Print_Str ("SCIL_Node = "); | |
1289 | Print_Node_Ref (Get_SCIL_Node (N)); | |
1290 | Print_Eol; | |
1291 | end if; | |
415dddc8 RK |
1292 | end Print_Node; |
1293 | ||
ee1a7572 AC |
1294 | ------------------------ |
1295 | -- Print_Node_Briefly -- | |
1296 | ------------------------ | |
1297 | ||
1298 | procedure Print_Node_Briefly (N : Node_Id) is | |
1299 | begin | |
1300 | Printing_Descendants := False; | |
1301 | Phase := Printing; | |
1302 | Print_Node_Header (N); | |
1303 | end Print_Node_Briefly; | |
1304 | ||
1305 | ----------------------- | |
1306 | -- Print_Node_Header -- | |
1307 | ----------------------- | |
1308 | ||
1309 | procedure Print_Node_Header (N : Node_Id) is | |
1310 | Notes : Boolean := False; | |
1311 | ||
1312 | begin | |
1313 | Print_Node_Ref (N); | |
1314 | ||
1315 | if N > Atree_Private_Part.Nodes.Last then | |
1316 | Print_Str (" (no such node)"); | |
1317 | Print_Eol; | |
1318 | return; | |
1319 | end if; | |
1320 | ||
1321 | if Comes_From_Source (N) then | |
1322 | Notes := True; | |
1323 | Print_Str (" (source"); | |
1324 | end if; | |
1325 | ||
1326 | if Analyzed (N) then | |
1327 | if not Notes then | |
1328 | Notes := True; | |
1329 | Print_Str (" ("); | |
1330 | else | |
1331 | Print_Str (","); | |
1332 | end if; | |
1333 | ||
1334 | Print_Str ("analyzed"); | |
1335 | end if; | |
1336 | ||
1337 | if Error_Posted (N) then | |
1338 | if not Notes then | |
1339 | Notes := True; | |
1340 | Print_Str (" ("); | |
1341 | else | |
1342 | Print_Str (","); | |
1343 | end if; | |
1344 | ||
1345 | Print_Str ("posted"); | |
1346 | end if; | |
1347 | ||
1348 | if Notes then | |
1349 | Print_Char (')'); | |
1350 | end if; | |
1351 | ||
1352 | Print_Eol; | |
1353 | end Print_Node_Header; | |
1354 | ||
415dddc8 RK |
1355 | --------------------- |
1356 | -- Print_Node_Kind -- | |
1357 | --------------------- | |
1358 | ||
1359 | procedure Print_Node_Kind (N : Node_Id) is | |
1360 | Ucase : Boolean; | |
1361 | S : constant String := Node_Kind'Image (Nkind (N)); | |
1362 | ||
1363 | begin | |
1364 | if Phase = Printing then | |
1365 | Ucase := True; | |
1366 | ||
1367 | -- Note: the call to Fold_Upper in this loop is to get past the GNAT | |
1368 | -- bug of 'Image returning lower case instead of upper case. | |
1369 | ||
1370 | for J in S'Range loop | |
1371 | if Ucase then | |
1372 | Write_Char (Fold_Upper (S (J))); | |
1373 | else | |
1374 | Write_Char (Fold_Lower (S (J))); | |
1375 | end if; | |
1376 | ||
1377 | Ucase := (S (J) = '_'); | |
1378 | end loop; | |
1379 | end if; | |
1380 | end Print_Node_Kind; | |
1381 | ||
1382 | -------------------- | |
1383 | -- Print_Node_Ref -- | |
1384 | -------------------- | |
1385 | ||
1386 | procedure Print_Node_Ref (N : Node_Id) is | |
1387 | S : Nat; | |
1388 | ||
1389 | begin | |
1390 | if Phase /= Printing then | |
1391 | return; | |
1392 | end if; | |
1393 | ||
1394 | if N = Empty then | |
1395 | Write_Str ("<empty>"); | |
1396 | ||
1397 | elsif N = Error then | |
1398 | Write_Str ("<error>"); | |
1399 | ||
1400 | else | |
1401 | if Printing_Descendants then | |
1402 | S := Serial_Number (Int (N)); | |
1403 | ||
1404 | if S /= 0 then | |
1405 | Write_Str ("Node"); | |
1406 | Write_Str (" #"); | |
1407 | Write_Int (S); | |
1408 | Write_Char (' '); | |
1409 | end if; | |
1410 | end if; | |
1411 | ||
1412 | Print_Node_Kind (N); | |
1413 | ||
1414 | if Nkind (N) in N_Has_Chars then | |
1415 | Write_Char (' '); | |
1416 | Print_Name (Chars (N)); | |
1417 | end if; | |
1418 | ||
1419 | if Nkind (N) in N_Entity then | |
1420 | Write_Str (" (Entity_Id="); | |
1421 | else | |
1422 | Write_Str (" (Node_Id="); | |
1423 | end if; | |
1424 | ||
1425 | Write_Int (Int (N)); | |
1426 | ||
1427 | if Sloc (N) <= Standard_Location then | |
1428 | Write_Char ('s'); | |
1429 | end if; | |
1430 | ||
1431 | Write_Char (')'); | |
1432 | ||
1433 | end if; | |
1434 | end Print_Node_Ref; | |
1435 | ||
1436 | ------------------------ | |
1437 | -- Print_Node_Subtree -- | |
1438 | ------------------------ | |
1439 | ||
1440 | procedure Print_Node_Subtree (N : Node_Id) is | |
1441 | begin | |
1442 | Print_Init; | |
1443 | ||
1444 | Next_Serial_Number := 1; | |
1445 | Phase := Marking; | |
1446 | Visit_Node (N, "", ' '); | |
1447 | ||
1448 | Next_Serial_Number := 1; | |
1449 | Phase := Printing; | |
1450 | Visit_Node (N, "", ' '); | |
1451 | ||
1452 | Print_Term; | |
1453 | end Print_Node_Subtree; | |
1454 | ||
1455 | --------------- | |
1456 | -- Print_Str -- | |
1457 | --------------- | |
1458 | ||
1459 | procedure Print_Str (S : String) is | |
1460 | begin | |
1461 | if Phase = Printing then | |
1462 | Write_Str (S); | |
1463 | end if; | |
1464 | end Print_Str; | |
1465 | ||
1466 | -------------------------- | |
1467 | -- Print_Str_Mixed_Case -- | |
1468 | -------------------------- | |
1469 | ||
1470 | procedure Print_Str_Mixed_Case (S : String) is | |
1471 | Ucase : Boolean; | |
1472 | ||
1473 | begin | |
1474 | if Phase = Printing then | |
1475 | Ucase := True; | |
1476 | ||
1477 | for J in S'Range loop | |
1478 | if Ucase then | |
1479 | Write_Char (S (J)); | |
1480 | else | |
1481 | Write_Char (Fold_Lower (S (J))); | |
1482 | end if; | |
1483 | ||
1484 | Ucase := (S (J) = '_'); | |
1485 | end loop; | |
1486 | end if; | |
1487 | end Print_Str_Mixed_Case; | |
1488 | ||
1489 | ---------------- | |
1490 | -- Print_Term -- | |
1491 | ---------------- | |
1492 | ||
1493 | procedure Print_Term is | |
1494 | procedure Free is new Unchecked_Deallocation | |
1495 | (Hash_Table_Type, Access_Hash_Table_Type); | |
1496 | ||
1497 | begin | |
1498 | Free (Hash_Table); | |
1499 | end Print_Term; | |
1500 | ||
1501 | --------------------- | |
1502 | -- Print_Tree_Elist -- | |
1503 | --------------------- | |
1504 | ||
1505 | procedure Print_Tree_Elist (E : Elist_Id) is | |
1506 | M : Elmt_Id; | |
1507 | ||
1508 | begin | |
1509 | Printing_Descendants := False; | |
1510 | Phase := Printing; | |
1511 | ||
1512 | Print_Elist_Ref (E); | |
1513 | Print_Eol; | |
1514 | ||
1515 | M := First_Elmt (E); | |
1516 | ||
1517 | if No (M) then | |
1518 | Print_Str ("<empty element list>"); | |
1519 | Print_Eol; | |
1520 | ||
1521 | else | |
1522 | loop | |
1523 | Print_Char ('|'); | |
1524 | Print_Eol; | |
1525 | exit when No (Next_Elmt (M)); | |
1526 | Print_Node (Node (M), "", '|'); | |
1527 | Next_Elmt (M); | |
1528 | end loop; | |
1529 | ||
1530 | Print_Node (Node (M), "", ' '); | |
1531 | Print_Eol; | |
1532 | end if; | |
1533 | end Print_Tree_Elist; | |
1534 | ||
1535 | --------------------- | |
1536 | -- Print_Tree_List -- | |
1537 | --------------------- | |
1538 | ||
1539 | procedure Print_Tree_List (L : List_Id) is | |
1540 | N : Node_Id; | |
1541 | ||
1542 | begin | |
1543 | Printing_Descendants := False; | |
1544 | Phase := Printing; | |
1545 | ||
1546 | Print_List_Ref (L); | |
1547 | Print_Str (" List_Id="); | |
1548 | Print_Int (Int (L)); | |
1549 | Print_Eol; | |
1550 | ||
1551 | N := First (L); | |
1552 | ||
1553 | if N = Empty then | |
1554 | Print_Str ("<empty node list>"); | |
1555 | Print_Eol; | |
1556 | ||
1557 | else | |
1558 | loop | |
1559 | Print_Char ('|'); | |
1560 | Print_Eol; | |
1561 | exit when Next (N) = Empty; | |
1562 | Print_Node (N, "", '|'); | |
1563 | Next (N); | |
1564 | end loop; | |
1565 | ||
1566 | Print_Node (N, "", ' '); | |
1567 | Print_Eol; | |
1568 | end if; | |
1569 | end Print_Tree_List; | |
1570 | ||
1571 | --------------------- | |
1572 | -- Print_Tree_Node -- | |
1573 | --------------------- | |
1574 | ||
1575 | procedure Print_Tree_Node (N : Node_Id; Label : String := "") is | |
1576 | begin | |
1577 | Printing_Descendants := False; | |
1578 | Phase := Printing; | |
1579 | Print_Node (N, Label, ' '); | |
1580 | end Print_Tree_Node; | |
1581 | ||
1582 | -------- | |
07fc65c4 | 1583 | -- pt -- |
415dddc8 RK |
1584 | -------- |
1585 | ||
07fc65c4 | 1586 | procedure pt (N : Node_Id) is |
415dddc8 RK |
1587 | begin |
1588 | Print_Node_Subtree (N); | |
07fc65c4 | 1589 | end pt; |
415dddc8 | 1590 | |
57a8057a AC |
1591 | --------- |
1592 | -- ppp -- | |
1593 | --------- | |
1594 | ||
1595 | procedure ppp (N : Node_Id) is | |
1596 | begin | |
1597 | pt (N); | |
1598 | end ppp; | |
1599 | ||
415dddc8 RK |
1600 | ------------------- |
1601 | -- Serial_Number -- | |
1602 | ------------------- | |
1603 | ||
1604 | -- The hashing algorithm is to use the remainder of the ID value divided | |
1605 | -- by the hash table length as the starting point in the table, and then | |
1606 | -- handle collisions by serial searching wrapping at the end of the table. | |
1607 | ||
1608 | Hash_Slot : Nat; | |
1609 | -- Set by an unsuccessful call to Serial_Number (one which returns zero) | |
1610 | -- to save the slot that should be used if Set_Serial_Number is called. | |
1611 | ||
1612 | function Serial_Number (Id : Int) return Nat is | |
1613 | H : Int := Id mod Hash_Table_Len; | |
1614 | ||
1615 | begin | |
1616 | while Hash_Table (H).Serial /= 0 loop | |
1617 | ||
1618 | if Id = Hash_Table (H).Id then | |
1619 | return Hash_Table (H).Serial; | |
1620 | end if; | |
1621 | ||
1622 | H := H + 1; | |
1623 | ||
1624 | if H > Hash_Table'Last then | |
1625 | H := 0; | |
1626 | end if; | |
1627 | end loop; | |
1628 | ||
1629 | -- Entry was not found, save slot number for possible subsequent call | |
1630 | -- to Set_Serial_Number, and unconditionally save the Id in this slot | |
1631 | -- in case of such a call (the Id field is never read if the serial | |
1632 | -- number of the slot is zero, so this is harmless in the case where | |
1633 | -- Set_Serial_Number is not subsequently called). | |
1634 | ||
1635 | Hash_Slot := H; | |
1636 | Hash_Table (H).Id := Id; | |
1637 | return 0; | |
1638 | ||
1639 | end Serial_Number; | |
1640 | ||
1641 | ----------------------- | |
1642 | -- Set_Serial_Number -- | |
1643 | ----------------------- | |
1644 | ||
1645 | procedure Set_Serial_Number is | |
1646 | begin | |
1647 | Hash_Table (Hash_Slot).Serial := Next_Serial_Number; | |
1648 | Next_Serial_Number := Next_Serial_Number + 1; | |
1649 | end Set_Serial_Number; | |
1650 | ||
1651 | --------------- | |
1652 | -- Tree_Dump -- | |
1653 | --------------- | |
1654 | ||
1655 | procedure Tree_Dump is | |
1656 | procedure Underline; | |
1657 | -- Put underline under string we just printed | |
1658 | ||
1659 | procedure Underline is | |
1660 | Col : constant Int := Column; | |
1661 | ||
1662 | begin | |
1663 | Write_Eol; | |
1664 | ||
1665 | while Col > Column loop | |
1666 | Write_Char ('-'); | |
1667 | end loop; | |
1668 | ||
1669 | Write_Eol; | |
1670 | end Underline; | |
1671 | ||
1672 | -- Start of processing for Tree_Dump. Note that we turn off the tree dump | |
1673 | -- flags immediately, before starting the dump. This avoids generating two | |
1674 | -- copies of the dump if an abort occurs after printing the dump, and more | |
1675 | -- importantly, avoids an infinite loop if an abort occurs during the dump. | |
1676 | ||
1677 | -- Note: unlike in the source print case (in Sprint), we do not output | |
1678 | -- separate trees for each unit. Instead the -df debug switch causes the | |
1679 | -- tree that is output from the main unit to trace references into other | |
1680 | -- units (normally such references are not traced). Since all other units | |
1681 | -- are linked to the main unit by at least one reference, this causes all | |
1682 | -- tree nodes to be included in the output tree. | |
1683 | ||
1684 | begin | |
1685 | if Debug_Flag_Y then | |
1686 | Debug_Flag_Y := False; | |
1687 | Write_Eol; | |
1688 | Write_Str ("Tree created for Standard (spec) "); | |
1689 | Underline; | |
1690 | Print_Node_Subtree (Standard_Package_Node); | |
1691 | Write_Eol; | |
1692 | end if; | |
1693 | ||
1694 | if Debug_Flag_T then | |
1695 | Debug_Flag_T := False; | |
1696 | ||
1697 | Write_Eol; | |
1698 | Write_Str ("Tree created for "); | |
1699 | Write_Unit_Name (Unit_Name (Main_Unit)); | |
1700 | Underline; | |
1701 | Print_Node_Subtree (Cunit (Main_Unit)); | |
1702 | Write_Eol; | |
1703 | end if; | |
415dddc8 RK |
1704 | end Tree_Dump; |
1705 | ||
1706 | ----------------- | |
1707 | -- Visit_Elist -- | |
1708 | ----------------- | |
1709 | ||
1710 | procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is | |
1711 | M : Elmt_Id; | |
1712 | N : Node_Id; | |
1713 | S : constant Nat := Serial_Number (Int (E)); | |
1714 | ||
1715 | begin | |
1716 | -- In marking phase, return if already marked, otherwise set next | |
1717 | -- serial number in hash table for later reference. | |
1718 | ||
1719 | if Phase = Marking then | |
1720 | if S /= 0 then | |
1721 | return; -- already visited | |
1722 | else | |
1723 | Set_Serial_Number; | |
1724 | end if; | |
1725 | ||
1726 | -- In printing phase, if already printed, then return, otherwise we | |
1727 | -- are printing the next item, so increment the serial number. | |
1728 | ||
1729 | else | |
1730 | if S < Next_Serial_Number then | |
1731 | return; -- already printed | |
1732 | else | |
1733 | Next_Serial_Number := Next_Serial_Number + 1; | |
1734 | end if; | |
1735 | end if; | |
1736 | ||
1737 | -- Now process the list (Print calls have no effect in marking phase) | |
1738 | ||
1739 | Print_Str (Prefix_Str); | |
1740 | Print_Elist_Ref (E); | |
1741 | Print_Eol; | |
1742 | ||
1743 | if Is_Empty_Elmt_List (E) then | |
1744 | Print_Str (Prefix_Str); | |
1745 | Print_Str ("(Empty element list)"); | |
1746 | Print_Eol; | |
1747 | Print_Eol; | |
1748 | ||
1749 | else | |
1750 | if Phase = Printing then | |
1751 | M := First_Elmt (E); | |
1752 | while Present (M) loop | |
1753 | N := Node (M); | |
1754 | Print_Str (Prefix_Str); | |
1755 | Print_Str (" "); | |
1756 | Print_Node_Ref (N); | |
1757 | Print_Eol; | |
1758 | Next_Elmt (M); | |
1759 | end loop; | |
1760 | ||
1761 | Print_Str (Prefix_Str); | |
1762 | Print_Eol; | |
1763 | end if; | |
1764 | ||
1765 | M := First_Elmt (E); | |
1766 | while Present (M) loop | |
1767 | Visit_Node (Node (M), Prefix_Str, ' '); | |
1768 | Next_Elmt (M); | |
1769 | end loop; | |
1770 | end if; | |
1771 | end Visit_Elist; | |
1772 | ||
1773 | ---------------- | |
1774 | -- Visit_List -- | |
1775 | ---------------- | |
1776 | ||
1777 | procedure Visit_List (L : List_Id; Prefix_Str : String) is | |
1778 | N : Node_Id; | |
1779 | S : constant Nat := Serial_Number (Int (L)); | |
1780 | ||
1781 | begin | |
1782 | -- In marking phase, return if already marked, otherwise set next | |
1783 | -- serial number in hash table for later reference. | |
1784 | ||
1785 | if Phase = Marking then | |
1786 | if S /= 0 then | |
1787 | return; | |
1788 | else | |
1789 | Set_Serial_Number; | |
1790 | end if; | |
1791 | ||
1792 | -- In printing phase, if already printed, then return, otherwise we | |
1793 | -- are printing the next item, so increment the serial number. | |
1794 | ||
1795 | else | |
1796 | if S < Next_Serial_Number then | |
1797 | return; -- already printed | |
1798 | else | |
1799 | Next_Serial_Number := Next_Serial_Number + 1; | |
1800 | end if; | |
1801 | end if; | |
1802 | ||
1803 | -- Now process the list (Print calls have no effect in marking phase) | |
1804 | ||
1805 | Print_Str (Prefix_Str); | |
1806 | Print_List_Ref (L); | |
1807 | Print_Eol; | |
1808 | ||
1809 | Print_Str (Prefix_Str); | |
1810 | Print_Str ("|Parent = "); | |
1811 | Print_Node_Ref (Parent (L)); | |
1812 | Print_Eol; | |
1813 | ||
1814 | N := First (L); | |
1815 | ||
1816 | if N = Empty then | |
1817 | Print_Str (Prefix_Str); | |
1818 | Print_Str ("(Empty list)"); | |
1819 | Print_Eol; | |
1820 | Print_Eol; | |
1821 | ||
1822 | else | |
1823 | Print_Str (Prefix_Str); | |
1824 | Print_Char ('|'); | |
1825 | Print_Eol; | |
1826 | ||
1827 | while Next (N) /= Empty loop | |
1828 | Visit_Node (N, Prefix_Str, '|'); | |
1829 | Next (N); | |
1830 | end loop; | |
1831 | end if; | |
1832 | ||
1833 | Visit_Node (N, Prefix_Str, ' '); | |
1834 | end Visit_List; | |
1835 | ||
1836 | ---------------- | |
1837 | -- Visit_Node -- | |
1838 | ---------------- | |
1839 | ||
1840 | procedure Visit_Node | |
1841 | (N : Node_Id; | |
1842 | Prefix_Str : String; | |
1843 | Prefix_Char : Character) | |
1844 | is | |
1845 | New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2); | |
1846 | -- Prefix string for printing referenced fields | |
1847 | ||
1848 | procedure Visit_Descendent | |
1849 | (D : Union_Id; | |
1850 | No_Indent : Boolean := False); | |
1851 | -- This procedure tests the given value of one of the Fields referenced | |
1852 | -- by the current node to determine whether to visit it recursively. | |
3354f96d | 1853 | -- Normally No_Indent is false, which means that the visited node will |
415dddc8 RK |
1854 | -- be indented using New_Prefix. If No_Indent is set to True, then |
1855 | -- this indentation is skipped, and Prefix_Str is used for the call | |
1856 | -- to print the descendent. No_Indent is effective only if the | |
1857 | -- referenced descendent is a node. | |
1858 | ||
1859 | ---------------------- | |
1860 | -- Visit_Descendent -- | |
1861 | ---------------------- | |
1862 | ||
1863 | procedure Visit_Descendent | |
1864 | (D : Union_Id; | |
1865 | No_Indent : Boolean := False) | |
1866 | is | |
1867 | begin | |
1868 | -- Case of descendent is a node | |
1869 | ||
1870 | if D in Node_Range then | |
1871 | ||
1872 | -- Don't bother about Empty or Error descendents | |
1873 | ||
1874 | if D <= Union_Id (Empty_Or_Error) then | |
1875 | return; | |
1876 | end if; | |
1877 | ||
1878 | declare | |
1879 | Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D); | |
1880 | ||
1881 | begin | |
1882 | -- Descendents in one of the standardly compiled internal | |
1883 | -- packages are normally ignored, unless the parent is also | |
1884 | -- in such a package (happens when Standard itself is output) | |
1885 | -- or if the -df switch is set which causes all links to be | |
1886 | -- followed, even into package standard. | |
1887 | ||
1888 | if Sloc (Nod) <= Standard_Location then | |
1889 | if Sloc (N) > Standard_Location | |
1890 | and then not Debug_Flag_F | |
1891 | then | |
1892 | return; | |
1893 | end if; | |
1894 | ||
1895 | -- Don't bother about a descendent in a different unit than | |
1896 | -- the node we came from unless the -df switch is set. Note | |
1897 | -- that we know at this point that Sloc (D) > Standard_Location | |
1898 | ||
1899 | -- Note: the tests for No_Location here just make sure that we | |
1900 | -- don't blow up on a node which is missing an Sloc value. This | |
1901 | -- should not normally happen. | |
1902 | ||
1903 | else | |
1904 | if (Sloc (N) <= Standard_Location | |
1905 | or else Sloc (N) = No_Location | |
1906 | or else Sloc (Nod) = No_Location | |
1907 | or else not In_Same_Source_Unit (Nod, N)) | |
1908 | and then not Debug_Flag_F | |
1909 | then | |
1910 | return; | |
1911 | end if; | |
1912 | end if; | |
1913 | ||
1914 | -- Don't bother visiting a source node that has a parent which | |
1915 | -- is not the node we came from. We prefer to trace such nodes | |
1916 | -- from their real parents. This causes the tree to be printed | |
1917 | -- in a more coherent order, e.g. a defining identifier listed | |
1918 | -- next to its corresponding declaration, instead of next to | |
1919 | -- some semantic reference. | |
1920 | ||
1921 | -- This test is skipped for nodes in standard packages unless | |
1922 | -- the -dy option is set (which outputs the tree for standard) | |
1923 | ||
1924 | -- Also, always follow pointers to Is_Itype entities, | |
1925 | -- since we want to list these when they are first referenced. | |
1926 | ||
1927 | if Parent (Nod) /= Empty | |
1928 | and then Comes_From_Source (Nod) | |
1929 | and then Parent (Nod) /= N | |
1930 | and then (Sloc (N) > Standard_Location or else Debug_Flag_Y) | |
1931 | then | |
1932 | return; | |
1933 | end if; | |
1934 | ||
1935 | -- If we successfully fall through all the above tests (which | |
1936 | -- execute a return if the node is not to be visited), we can | |
a90bd866 | 1937 | -- go ahead and visit the node. |
415dddc8 RK |
1938 | |
1939 | if No_Indent then | |
1940 | Visit_Node (Nod, Prefix_Str, Prefix_Char); | |
1941 | else | |
1942 | Visit_Node (Nod, New_Prefix, ' '); | |
1943 | end if; | |
1944 | end; | |
1945 | ||
1946 | -- Case of descendent is a list | |
1947 | ||
1948 | elsif D in List_Range then | |
1949 | ||
1950 | -- Don't bother with a missing list, empty list or error list | |
1951 | ||
1952 | if D = Union_Id (No_List) | |
1953 | or else D = Union_Id (Error_List) | |
1954 | or else Is_Empty_List (List_Id (D)) | |
1955 | then | |
1956 | return; | |
1957 | ||
4c51ff88 AC |
1958 | -- Otherwise we can visit the list. Note that we don't bother to |
1959 | -- do the parent test that we did for the node case, because it | |
1960 | -- just does not happen that lists are referenced more than one | |
1961 | -- place in the tree. We aren't counting on this being the case | |
1962 | -- to generate valid output, it is just that we don't need in | |
1963 | -- practice to worry about listing the list at a place that is | |
1964 | -- inconvenient. | |
415dddc8 RK |
1965 | |
1966 | else | |
1967 | Visit_List (List_Id (D), New_Prefix); | |
1968 | end if; | |
1969 | ||
1970 | -- Case of descendent is an element list | |
1971 | ||
1972 | elsif D in Elist_Range then | |
1973 | ||
1974 | -- Don't bother with a missing list, or an empty list | |
1975 | ||
1976 | if D = Union_Id (No_Elist) | |
1977 | or else Is_Empty_Elmt_List (Elist_Id (D)) | |
1978 | then | |
1979 | return; | |
1980 | ||
1981 | -- Otherwise, visit the referenced element list | |
1982 | ||
1983 | else | |
1984 | Visit_Elist (Elist_Id (D), New_Prefix); | |
1985 | end if; | |
1986 | ||
1987 | -- For all other kinds of descendents (strings, names, uints etc), | |
1988 | -- there is nothing to visit (the contents of the field will be | |
1989 | -- printed when we print the containing node, but what concerns | |
1990 | -- us now is looking for descendents in the tree. | |
1991 | ||
1992 | else | |
1993 | null; | |
1994 | end if; | |
1995 | end Visit_Descendent; | |
1996 | ||
1997 | -- Start of processing for Visit_Node | |
1998 | ||
1999 | begin | |
2000 | if N = Empty then | |
2001 | return; | |
2002 | end if; | |
2003 | ||
2004 | -- Set fatal error node in case we get a blow up during the trace | |
2005 | ||
2006 | Current_Error_Node := N; | |
2007 | ||
2008 | New_Prefix (Prefix_Str'Range) := Prefix_Str; | |
2009 | New_Prefix (Prefix_Str'Last + 1) := Prefix_Char; | |
2010 | New_Prefix (Prefix_Str'Last + 2) := ' '; | |
2011 | ||
2012 | -- In the marking phase, all we do is to set the serial number | |
2013 | ||
2014 | if Phase = Marking then | |
2015 | if Serial_Number (Int (N)) /= 0 then | |
2016 | return; -- already visited | |
2017 | else | |
2018 | Set_Serial_Number; | |
2019 | end if; | |
2020 | ||
2021 | -- In the printing phase, we print the node | |
2022 | ||
2023 | else | |
2024 | if Serial_Number (Int (N)) < Next_Serial_Number then | |
2025 | ||
4c51ff88 AC |
2026 | -- Here we have already visited the node, but if it is in a list, |
2027 | -- we still want to print the reference, so that it is clear that | |
2028 | -- it belongs to the list. | |
415dddc8 RK |
2029 | |
2030 | if Is_List_Member (N) then | |
2031 | Print_Str (Prefix_Str); | |
2032 | Print_Node_Ref (N); | |
2033 | Print_Eol; | |
2034 | Print_Str (Prefix_Str); | |
2035 | Print_Char (Prefix_Char); | |
2036 | Print_Str ("(already output)"); | |
2037 | Print_Eol; | |
2038 | Print_Str (Prefix_Str); | |
2039 | Print_Char (Prefix_Char); | |
2040 | Print_Eol; | |
2041 | end if; | |
2042 | ||
2043 | return; | |
2044 | ||
2045 | else | |
2046 | Print_Node (N, Prefix_Str, Prefix_Char); | |
2047 | Print_Str (Prefix_Str); | |
2048 | Print_Char (Prefix_Char); | |
2049 | Print_Eol; | |
2050 | Next_Serial_Number := Next_Serial_Number + 1; | |
2051 | end if; | |
2052 | end if; | |
2053 | ||
2054 | -- Visit all descendents of this node | |
2055 | ||
2056 | if Nkind (N) not in N_Entity then | |
2057 | Visit_Descendent (Field1 (N)); | |
2058 | Visit_Descendent (Field2 (N)); | |
2059 | Visit_Descendent (Field3 (N)); | |
2060 | Visit_Descendent (Field4 (N)); | |
2061 | Visit_Descendent (Field5 (N)); | |
2062 | ||
c159409f AC |
2063 | if Has_Aspects (N) then |
2064 | Visit_Descendent (Union_Id (Aspect_Specifications (N))); | |
2065 | end if; | |
2066 | ||
415dddc8 RK |
2067 | -- Entity case |
2068 | ||
2069 | else | |
2070 | Visit_Descendent (Field1 (N)); | |
2071 | Visit_Descendent (Field3 (N)); | |
2072 | Visit_Descendent (Field4 (N)); | |
2073 | Visit_Descendent (Field5 (N)); | |
2074 | Visit_Descendent (Field6 (N)); | |
2075 | Visit_Descendent (Field7 (N)); | |
2076 | Visit_Descendent (Field8 (N)); | |
2077 | Visit_Descendent (Field9 (N)); | |
2078 | Visit_Descendent (Field10 (N)); | |
2079 | Visit_Descendent (Field11 (N)); | |
2080 | Visit_Descendent (Field12 (N)); | |
2081 | Visit_Descendent (Field13 (N)); | |
2082 | Visit_Descendent (Field14 (N)); | |
2083 | Visit_Descendent (Field15 (N)); | |
2084 | Visit_Descendent (Field16 (N)); | |
2085 | Visit_Descendent (Field17 (N)); | |
2086 | Visit_Descendent (Field18 (N)); | |
2087 | Visit_Descendent (Field19 (N)); | |
2088 | Visit_Descendent (Field20 (N)); | |
2089 | Visit_Descendent (Field21 (N)); | |
2090 | Visit_Descendent (Field22 (N)); | |
2091 | Visit_Descendent (Field23 (N)); | |
2092 | ||
fbf5a39b AC |
2093 | -- Now an interesting kludge. Normally parents are always printed |
2094 | -- since we traverse the tree in a downwards direction. There is | |
2095 | -- however an exception to this rule, which is the case where a | |
2096 | -- parent is constructed by the compiler and is not referenced | |
2097 | -- elsewhere in the tree. The following catches this case | |
2098 | ||
2099 | if not Comes_From_Source (N) then | |
2100 | Visit_Descendent (Union_Id (Parent (N))); | |
2101 | end if; | |
2102 | ||
415dddc8 RK |
2103 | -- You may be wondering why we omitted Field2 above. The answer |
2104 | -- is that this is the Next_Entity field, and we want to treat | |
2105 | -- it rather specially. Why? Because a Next_Entity link does not | |
2106 | -- correspond to a level deeper in the tree, and we do not want | |
2107 | -- the tree to march off to the right of the page due to bogus | |
2108 | -- indentations coming from this effect. | |
2109 | ||
2110 | -- To prevent this, what we do is to control references via | |
4c51ff88 AC |
2111 | -- Next_Entity only from the first entity on a given scope chain, |
2112 | -- and we keep them all at the same level. Of course if an entity | |
2113 | -- has already been referenced it is not printed. | |
415dddc8 RK |
2114 | |
2115 | if Present (Next_Entity (N)) | |
2116 | and then Present (Scope (N)) | |
2117 | and then First_Entity (Scope (N)) = N | |
2118 | then | |
2119 | declare | |
2120 | Nod : Node_Id; | |
2121 | ||
2122 | begin | |
2123 | Nod := N; | |
2124 | while Present (Nod) loop | |
2125 | Visit_Descendent (Union_Id (Next_Entity (Nod))); | |
2126 | Nod := Next_Entity (Nod); | |
2127 | end loop; | |
2128 | end; | |
2129 | end if; | |
2130 | end if; | |
2131 | end Visit_Node; | |
2132 | ||
2133 | end Treepr; |