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