]>
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 | -- -- | |
caf07df9 | 9 | -- Copyright (C) 1992-2015, 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 | ||
caf07df9 AC |
734 | if Field_Present (Field36 (Ent)) then |
735 | Print_Str (Prefix); | |
736 | Write_Field36_Name (Ent); | |
737 | Write_Str (" = "); | |
738 | Print_Field (Field36 (Ent)); | |
739 | Print_Eol; | |
740 | end if; | |
741 | ||
742 | if Field_Present (Field37 (Ent)) then | |
743 | Print_Str (Prefix); | |
744 | Write_Field37_Name (Ent); | |
745 | Write_Str (" = "); | |
746 | Print_Field (Field37 (Ent)); | |
747 | Print_Eol; | |
748 | end if; | |
749 | ||
750 | if Field_Present (Field38 (Ent)) then | |
751 | Print_Str (Prefix); | |
752 | Write_Field38_Name (Ent); | |
753 | Write_Str (" = "); | |
754 | Print_Field (Field38 (Ent)); | |
755 | Print_Eol; | |
756 | end if; | |
757 | ||
758 | if Field_Present (Field39 (Ent)) then | |
759 | Print_Str (Prefix); | |
760 | Write_Field39_Name (Ent); | |
761 | Write_Str (" = "); | |
762 | Print_Field (Field39 (Ent)); | |
763 | Print_Eol; | |
764 | end if; | |
765 | ||
766 | if Field_Present (Field40 (Ent)) then | |
767 | Print_Str (Prefix); | |
768 | Write_Field40_Name (Ent); | |
769 | Write_Str (" = "); | |
770 | Print_Field (Field40 (Ent)); | |
771 | Print_Eol; | |
772 | end if; | |
773 | ||
774 | if Field_Present (Field41 (Ent)) then | |
775 | Print_Str (Prefix); | |
776 | Write_Field41_Name (Ent); | |
777 | Write_Str (" = "); | |
778 | Print_Field (Field41 (Ent)); | |
779 | Print_Eol; | |
780 | end if; | |
781 | ||
165eab5f | 782 | Write_Entity_Flags (Ent, Prefix); |
415dddc8 RK |
783 | end Print_Entity_Info; |
784 | ||
785 | --------------- | |
786 | -- Print_Eol -- | |
787 | --------------- | |
788 | ||
789 | procedure Print_Eol is | |
790 | begin | |
791 | if Phase = Printing then | |
792 | Write_Eol; | |
793 | end if; | |
794 | end Print_Eol; | |
795 | ||
796 | ----------------- | |
797 | -- Print_Field -- | |
798 | ----------------- | |
799 | ||
800 | procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is | |
801 | begin | |
802 | if Phase /= Printing then | |
803 | return; | |
804 | end if; | |
805 | ||
806 | if Val in Node_Range then | |
807 | Print_Node_Ref (Node_Id (Val)); | |
808 | ||
809 | elsif Val in List_Range then | |
810 | Print_List_Ref (List_Id (Val)); | |
811 | ||
812 | elsif Val in Elist_Range then | |
813 | Print_Elist_Ref (Elist_Id (Val)); | |
814 | ||
815 | elsif Val in Names_Range then | |
816 | Print_Name (Name_Id (Val)); | |
817 | Write_Str (" (Name_Id="); | |
818 | Write_Int (Int (Val)); | |
819 | Write_Char (')'); | |
820 | ||
821 | elsif Val in Strings_Range then | |
822 | Write_String_Table_Entry (String_Id (Val)); | |
823 | Write_Str (" (String_Id="); | |
824 | Write_Int (Int (Val)); | |
825 | Write_Char (')'); | |
826 | ||
827 | elsif Val in Uint_Range then | |
828 | UI_Write (From_Union (Val), Format); | |
829 | Write_Str (" (Uint = "); | |
830 | Write_Int (Int (Val)); | |
831 | Write_Char (')'); | |
832 | ||
833 | elsif Val in Ureal_Range then | |
834 | UR_Write (From_Union (Val)); | |
835 | Write_Str (" (Ureal = "); | |
836 | Write_Int (Int (Val)); | |
837 | Write_Char (')'); | |
838 | ||
415dddc8 RK |
839 | else |
840 | Print_Str ("****** Incorrect value = "); | |
841 | Print_Int (Int (Val)); | |
842 | end if; | |
843 | end Print_Field; | |
844 | ||
845 | ---------------- | |
846 | -- Print_Flag -- | |
847 | ---------------- | |
848 | ||
849 | procedure Print_Flag (F : Boolean) is | |
850 | begin | |
851 | if F then | |
852 | Print_Str ("True"); | |
853 | else | |
854 | Print_Str ("False"); | |
855 | end if; | |
856 | end Print_Flag; | |
857 | ||
858 | ---------------- | |
859 | -- Print_Init -- | |
860 | ---------------- | |
861 | ||
862 | procedure Print_Init is | |
863 | begin | |
864 | Printing_Descendants := True; | |
865 | Write_Eol; | |
866 | ||
867 | -- Allocate and clear serial number hash table. The size is 150% of | |
868 | -- the maximum possible number of entries, so that the hash table | |
869 | -- cannot get significantly overloaded. | |
870 | ||
871 | Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100; | |
872 | Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1); | |
873 | ||
874 | for J in Hash_Table'Range loop | |
875 | Hash_Table (J).Serial := 0; | |
876 | end loop; | |
877 | ||
878 | end Print_Init; | |
879 | ||
880 | --------------- | |
881 | -- Print_Int -- | |
882 | --------------- | |
883 | ||
884 | procedure Print_Int (I : Int) is | |
885 | begin | |
886 | if Phase = Printing then | |
887 | Write_Int (I); | |
888 | end if; | |
889 | end Print_Int; | |
890 | ||
891 | -------------------- | |
892 | -- Print_List_Ref -- | |
893 | -------------------- | |
894 | ||
895 | procedure Print_List_Ref (L : List_Id) is | |
896 | begin | |
897 | if Phase /= Printing then | |
898 | return; | |
899 | end if; | |
900 | ||
901 | if No (L) then | |
902 | Write_Str ("<no list>"); | |
903 | ||
904 | elsif Is_Empty_List (L) then | |
905 | Write_Str ("<empty list> (List_Id="); | |
906 | Write_Int (Int (L)); | |
907 | Write_Char (')'); | |
908 | ||
909 | else | |
910 | Write_Str ("List"); | |
911 | ||
912 | if Printing_Descendants then | |
913 | Write_Str (" #"); | |
914 | Write_Int (Serial_Number (Int (L))); | |
915 | end if; | |
916 | ||
917 | Write_Str (" (List_Id="); | |
918 | Write_Int (Int (L)); | |
919 | Write_Char (')'); | |
920 | end if; | |
921 | end Print_List_Ref; | |
922 | ||
923 | ------------------------ | |
924 | -- Print_List_Subtree -- | |
925 | ------------------------ | |
926 | ||
927 | procedure Print_List_Subtree (L : List_Id) is | |
928 | begin | |
929 | Print_Init; | |
930 | ||
931 | Next_Serial_Number := 1; | |
932 | Phase := Marking; | |
933 | Visit_List (L, ""); | |
934 | ||
935 | Next_Serial_Number := 1; | |
936 | Phase := Printing; | |
937 | Visit_List (L, ""); | |
938 | ||
939 | Print_Term; | |
940 | end Print_List_Subtree; | |
941 | ||
942 | ---------------- | |
943 | -- Print_Name -- | |
944 | ---------------- | |
945 | ||
946 | procedure Print_Name (N : Name_Id) is | |
947 | begin | |
948 | if Phase = Printing then | |
949 | if N = No_Name then | |
950 | Print_Str ("<No_Name>"); | |
951 | ||
952 | elsif N = Error_Name then | |
953 | Print_Str ("<Error_Name>"); | |
954 | ||
87ace727 | 955 | elsif Is_Valid_Name (N) then |
415dddc8 RK |
956 | Get_Name_String (N); |
957 | Print_Char ('"'); | |
958 | Write_Name (N); | |
959 | Print_Char ('"'); | |
87ace727 RD |
960 | |
961 | else | |
962 | Print_Str ("<invalid name ???>"); | |
415dddc8 RK |
963 | end if; |
964 | end if; | |
965 | end Print_Name; | |
966 | ||
967 | ---------------- | |
968 | -- Print_Node -- | |
969 | ---------------- | |
970 | ||
971 | procedure Print_Node | |
972 | (N : Node_Id; | |
973 | Prefix_Str : String; | |
974 | Prefix_Char : Character) | |
975 | is | |
976 | F : Fchar; | |
977 | P : Natural := Pchar_Pos (Nkind (N)); | |
978 | ||
979 | Field_To_Be_Printed : Boolean; | |
980 | Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1); | |
981 | ||
e3b3266c | 982 | Sfile : Source_File_Index; |
415dddc8 RK |
983 | Fmt : UI_Format; |
984 | ||
985 | begin | |
986 | if Phase /= Printing then | |
987 | return; | |
988 | end if; | |
989 | ||
990 | if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then | |
991 | Fmt := Hex; | |
992 | else | |
993 | Fmt := Auto; | |
994 | end if; | |
995 | ||
996 | Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str; | |
997 | Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char; | |
998 | ||
999 | -- Print header line | |
1000 | ||
1001 | Print_Str (Prefix_Str); | |
ee1a7572 | 1002 | Print_Node_Header (N); |
415dddc8 RK |
1003 | |
1004 | if Is_Rewrite_Substitution (N) then | |
1005 | Print_Str (Prefix_Str); | |
1006 | Print_Str (" Rewritten: original node = "); | |
1007 | Print_Node_Ref (Original_Node (N)); | |
1008 | Print_Eol; | |
1009 | end if; | |
1010 | ||
1011 | if N = Empty then | |
1012 | return; | |
1013 | end if; | |
1014 | ||
1015 | if not Is_List_Member (N) then | |
1016 | Print_Str (Prefix_Str); | |
1017 | Print_Str (" Parent = "); | |
1018 | Print_Node_Ref (Parent (N)); | |
1019 | Print_Eol; | |
1020 | end if; | |
1021 | ||
1022 | -- Print Sloc field if it is set | |
1023 | ||
1024 | if Sloc (N) /= No_Location then | |
1025 | Print_Str (Prefix_Str_Char); | |
1026 | Print_Str ("Sloc = "); | |
1027 | ||
e3b3266c AC |
1028 | if Sloc (N) = Standard_Location then |
1029 | Print_Str ("Standard_Location"); | |
1030 | ||
1031 | elsif Sloc (N) = Standard_ASCII_Location then | |
1032 | Print_Str ("Standard_ASCII_Location"); | |
1033 | ||
1034 | else | |
1035 | Sfile := Get_Source_File_Index (Sloc (N)); | |
1036 | Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First)); | |
1037 | Write_Str (" "); | |
1038 | Write_Location (Sloc (N)); | |
1039 | end if; | |
1040 | ||
1041 | Print_Eol; | |
415dddc8 RK |
1042 | end if; |
1043 | ||
1044 | -- Print Chars field if present | |
1045 | ||
1046 | if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then | |
1047 | Print_Str (Prefix_Str_Char); | |
1048 | Print_Str ("Chars = "); | |
1049 | Print_Name (Chars (N)); | |
1050 | Write_Str (" (Name_Id="); | |
1051 | Write_Int (Int (Chars (N))); | |
1052 | Write_Char (')'); | |
1053 | Print_Eol; | |
1054 | end if; | |
1055 | ||
1056 | -- Special field print operations for non-entity nodes | |
1057 | ||
1058 | if Nkind (N) not in N_Entity then | |
1059 | ||
1060 | -- Deal with Left_Opnd and Right_Opnd fields | |
1061 | ||
1062 | if Nkind (N) in N_Op | |
514d0fc5 | 1063 | or else Nkind (N) in N_Short_Circuit |
c064e066 | 1064 | or else Nkind (N) in N_Membership_Test |
415dddc8 RK |
1065 | then |
1066 | -- Print Left_Opnd if present | |
1067 | ||
1068 | if Nkind (N) not in N_Unary_Op then | |
1069 | Print_Str (Prefix_Str_Char); | |
1070 | Print_Str ("Left_Opnd = "); | |
1071 | Print_Node_Ref (Left_Opnd (N)); | |
1072 | Print_Eol; | |
1073 | end if; | |
1074 | ||
1075 | -- Print Right_Opnd | |
1076 | ||
1077 | Print_Str (Prefix_Str_Char); | |
1078 | Print_Str ("Right_Opnd = "); | |
1079 | Print_Node_Ref (Right_Opnd (N)); | |
1080 | Print_Eol; | |
1081 | end if; | |
1082 | ||
1083 | -- Print Entity field if operator (other cases of Entity | |
1084 | -- are in the table, so are handled in the normal circuit) | |
1085 | ||
1086 | if Nkind (N) in N_Op and then Present (Entity (N)) then | |
1087 | Print_Str (Prefix_Str_Char); | |
1088 | Print_Str ("Entity = "); | |
1089 | Print_Node_Ref (Entity (N)); | |
1090 | Print_Eol; | |
1091 | end if; | |
1092 | ||
1093 | -- Print special fields if we have a subexpression | |
1094 | ||
1095 | if Nkind (N) in N_Subexpr then | |
1096 | ||
1097 | if Assignment_OK (N) then | |
1098 | Print_Str (Prefix_Str_Char); | |
1099 | Print_Str ("Assignment_OK = True"); | |
1100 | Print_Eol; | |
1101 | end if; | |
1102 | ||
1103 | if Do_Range_Check (N) then | |
1104 | Print_Str (Prefix_Str_Char); | |
1105 | Print_Str ("Do_Range_Check = True"); | |
1106 | Print_Eol; | |
1107 | end if; | |
1108 | ||
1109 | if Has_Dynamic_Length_Check (N) then | |
1110 | Print_Str (Prefix_Str_Char); | |
1111 | Print_Str ("Has_Dynamic_Length_Check = True"); | |
1112 | Print_Eol; | |
1113 | end if; | |
1114 | ||
c159409f AC |
1115 | if Has_Aspects (N) then |
1116 | Print_Str (Prefix_Str_Char); | |
1117 | Print_Str ("Has_Aspects = True"); | |
1118 | Print_Eol; | |
1119 | end if; | |
1120 | ||
415dddc8 RK |
1121 | if Has_Dynamic_Range_Check (N) then |
1122 | Print_Str (Prefix_Str_Char); | |
1123 | Print_Str ("Has_Dynamic_Range_Check = True"); | |
1124 | Print_Eol; | |
1125 | end if; | |
1126 | ||
1127 | if Is_Controlling_Actual (N) then | |
1128 | Print_Str (Prefix_Str_Char); | |
1129 | Print_Str ("Is_Controlling_Actual = True"); | |
1130 | Print_Eol; | |
1131 | end if; | |
1132 | ||
1133 | if Is_Overloaded (N) then | |
1134 | Print_Str (Prefix_Str_Char); | |
1135 | Print_Str ("Is_Overloaded = True"); | |
1136 | Print_Eol; | |
1137 | end if; | |
1138 | ||
1139 | if Is_Static_Expression (N) then | |
1140 | Print_Str (Prefix_Str_Char); | |
1141 | Print_Str ("Is_Static_Expression = True"); | |
1142 | Print_Eol; | |
1143 | end if; | |
1144 | ||
1145 | if Must_Not_Freeze (N) then | |
1146 | Print_Str (Prefix_Str_Char); | |
1147 | Print_Str ("Must_Not_Freeze = True"); | |
1148 | Print_Eol; | |
1149 | end if; | |
1150 | ||
1151 | if Paren_Count (N) /= 0 then | |
1152 | Print_Str (Prefix_Str_Char); | |
1153 | Print_Str ("Paren_Count = "); | |
1154 | Print_Int (Int (Paren_Count (N))); | |
1155 | Print_Eol; | |
1156 | end if; | |
1157 | ||
1158 | if Raises_Constraint_Error (N) then | |
1159 | Print_Str (Prefix_Str_Char); | |
1160 | Print_Str ("Raise_Constraint_Error = True"); | |
1161 | Print_Eol; | |
1162 | end if; | |
1163 | ||
1164 | end if; | |
1165 | ||
1166 | -- Print Do_Overflow_Check field if present | |
1167 | ||
1168 | if Nkind (N) in N_Op and then Do_Overflow_Check (N) then | |
1169 | Print_Str (Prefix_Str_Char); | |
1170 | Print_Str ("Do_Overflow_Check = True"); | |
1171 | Print_Eol; | |
1172 | end if; | |
1173 | ||
1174 | -- Print Etype field if present (printing of this field for entities | |
1175 | -- is handled by the Print_Entity_Info procedure). | |
1176 | ||
a99ada67 | 1177 | if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then |
415dddc8 RK |
1178 | Print_Str (Prefix_Str_Char); |
1179 | Print_Str ("Etype = "); | |
1180 | Print_Node_Ref (Etype (N)); | |
1181 | Print_Eol; | |
1182 | end if; | |
1183 | end if; | |
1184 | ||
1185 | -- Loop to print fields included in Pchars array | |
1186 | ||
1187 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop | |
1188 | F := Pchars (P); | |
1189 | P := P + 1; | |
1190 | ||
1191 | -- Check for case of False flag, which we never print, or | |
1192 | -- an Empty field, which is also never printed | |
1193 | ||
1194 | case F is | |
1195 | when F_Field1 => | |
1196 | Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty); | |
1197 | ||
1198 | when F_Field2 => | |
1199 | Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty); | |
1200 | ||
1201 | when F_Field3 => | |
1202 | Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty); | |
1203 | ||
1204 | when F_Field4 => | |
1205 | Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty); | |
1206 | ||
1207 | when F_Field5 => | |
1208 | Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); | |
1209 | ||
8d81fb4e AC |
1210 | when F_Flag1 => Field_To_Be_Printed := Flag1 (N); |
1211 | when F_Flag2 => Field_To_Be_Printed := Flag2 (N); | |
1212 | when F_Flag3 => Field_To_Be_Printed := Flag3 (N); | |
415dddc8 RK |
1213 | when F_Flag4 => Field_To_Be_Printed := Flag4 (N); |
1214 | when F_Flag5 => Field_To_Be_Printed := Flag5 (N); | |
1215 | when F_Flag6 => Field_To_Be_Printed := Flag6 (N); | |
1216 | when F_Flag7 => Field_To_Be_Printed := Flag7 (N); | |
1217 | when F_Flag8 => Field_To_Be_Printed := Flag8 (N); | |
1218 | when F_Flag9 => Field_To_Be_Printed := Flag9 (N); | |
1219 | when F_Flag10 => Field_To_Be_Printed := Flag10 (N); | |
1220 | when F_Flag11 => Field_To_Be_Printed := Flag11 (N); | |
1221 | when F_Flag12 => Field_To_Be_Printed := Flag12 (N); | |
1222 | when F_Flag13 => Field_To_Be_Printed := Flag13 (N); | |
1223 | when F_Flag14 => Field_To_Be_Printed := Flag14 (N); | |
1224 | when F_Flag15 => Field_To_Be_Printed := Flag15 (N); | |
1225 | when F_Flag16 => Field_To_Be_Printed := Flag16 (N); | |
1226 | when F_Flag17 => Field_To_Be_Printed := Flag17 (N); | |
1227 | when F_Flag18 => Field_To_Be_Printed := Flag18 (N); | |
415dddc8 RK |
1228 | end case; |
1229 | ||
1230 | -- Print field if it is to be printed | |
1231 | ||
1232 | if Field_To_Be_Printed then | |
1233 | Print_Str (Prefix_Str_Char); | |
1234 | ||
1235 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) | |
1236 | and then Pchars (P) not in Fchar | |
1237 | loop | |
1238 | Print_Char (Pchars (P)); | |
1239 | P := P + 1; | |
1240 | end loop; | |
1241 | ||
1242 | Print_Str (" = "); | |
1243 | ||
1244 | case F is | |
1245 | when F_Field1 => Print_Field (Field1 (N), Fmt); | |
1246 | when F_Field2 => Print_Field (Field2 (N), Fmt); | |
1247 | when F_Field3 => Print_Field (Field3 (N), Fmt); | |
1248 | when F_Field4 => Print_Field (Field4 (N), Fmt); | |
1249 | ||
1250 | -- Special case End_Span = Uint5 | |
1251 | ||
1252 | when F_Field5 => | |
8d81fb4e | 1253 | if Nkind_In (N, N_Case_Statement, N_If_Statement) then |
415dddc8 RK |
1254 | Print_End_Span (N); |
1255 | else | |
1256 | Print_Field (Field5 (N), Fmt); | |
1257 | end if; | |
1258 | ||
8d81fb4e AC |
1259 | when F_Flag1 => Print_Flag (Flag1 (N)); |
1260 | when F_Flag2 => Print_Flag (Flag2 (N)); | |
1261 | when F_Flag3 => Print_Flag (Flag3 (N)); | |
415dddc8 RK |
1262 | when F_Flag4 => Print_Flag (Flag4 (N)); |
1263 | when F_Flag5 => Print_Flag (Flag5 (N)); | |
1264 | when F_Flag6 => Print_Flag (Flag6 (N)); | |
1265 | when F_Flag7 => Print_Flag (Flag7 (N)); | |
1266 | when F_Flag8 => Print_Flag (Flag8 (N)); | |
1267 | when F_Flag9 => Print_Flag (Flag9 (N)); | |
1268 | when F_Flag10 => Print_Flag (Flag10 (N)); | |
1269 | when F_Flag11 => Print_Flag (Flag11 (N)); | |
1270 | when F_Flag12 => Print_Flag (Flag12 (N)); | |
1271 | when F_Flag13 => Print_Flag (Flag13 (N)); | |
1272 | when F_Flag14 => Print_Flag (Flag14 (N)); | |
1273 | when F_Flag15 => Print_Flag (Flag15 (N)); | |
1274 | when F_Flag16 => Print_Flag (Flag16 (N)); | |
1275 | when F_Flag17 => Print_Flag (Flag17 (N)); | |
1276 | when F_Flag18 => Print_Flag (Flag18 (N)); | |
415dddc8 RK |
1277 | end case; |
1278 | ||
1279 | Print_Eol; | |
1280 | ||
1281 | -- Field is not to be printed (False flag field) | |
1282 | ||
1283 | else | |
1284 | while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) | |
1285 | and then Pchars (P) not in Fchar | |
1286 | loop | |
1287 | P := P + 1; | |
1288 | end loop; | |
1289 | end if; | |
415dddc8 RK |
1290 | end loop; |
1291 | ||
c159409f AC |
1292 | -- Print aspects if present |
1293 | ||
1294 | if Has_Aspects (N) then | |
1295 | Print_Str (Prefix_Str_Char); | |
1296 | Print_Str ("Aspect_Specifications = "); | |
1297 | Print_Field (Union_Id (Aspect_Specifications (N))); | |
1298 | Print_Eol; | |
1299 | end if; | |
1300 | ||
415dddc8 RK |
1301 | -- Print entity information for entities |
1302 | ||
1303 | if Nkind (N) in N_Entity then | |
1304 | Print_Entity_Info (N, Prefix_Str_Char); | |
1305 | end if; | |
1306 | ||
7665e4bd AC |
1307 | -- Print the SCIL node (if available) |
1308 | ||
1309 | if Present (Get_SCIL_Node (N)) then | |
1310 | Print_Str (Prefix_Str_Char); | |
1311 | Print_Str ("SCIL_Node = "); | |
1312 | Print_Node_Ref (Get_SCIL_Node (N)); | |
1313 | Print_Eol; | |
1314 | end if; | |
415dddc8 RK |
1315 | end Print_Node; |
1316 | ||
ee1a7572 AC |
1317 | ------------------------ |
1318 | -- Print_Node_Briefly -- | |
1319 | ------------------------ | |
1320 | ||
1321 | procedure Print_Node_Briefly (N : Node_Id) is | |
1322 | begin | |
1323 | Printing_Descendants := False; | |
1324 | Phase := Printing; | |
1325 | Print_Node_Header (N); | |
1326 | end Print_Node_Briefly; | |
1327 | ||
1328 | ----------------------- | |
1329 | -- Print_Node_Header -- | |
1330 | ----------------------- | |
1331 | ||
1332 | procedure Print_Node_Header (N : Node_Id) is | |
8636f52f HK |
1333 | Enumerate : Boolean := False; |
1334 | -- Flag set when enumerating multiple header flags | |
1335 | ||
1336 | procedure Print_Header_Flag (Flag : String); | |
1337 | -- Output one of the flags that appears in a node header. The routine | |
1338 | -- automatically handles enumeration of multiple flags. | |
1339 | ||
1340 | ----------------------- | |
1341 | -- Print_Header_Flag -- | |
1342 | ----------------------- | |
1343 | ||
1344 | procedure Print_Header_Flag (Flag : String) is | |
1345 | begin | |
1346 | if Enumerate then | |
1347 | Print_Char (','); | |
1348 | else | |
1349 | Enumerate := True; | |
1350 | Print_Char ('('); | |
1351 | end if; | |
1352 | ||
1353 | Print_Str (Flag); | |
1354 | end Print_Header_Flag; | |
1355 | ||
1356 | -- Start of processing for Print_Node_Header | |
ee1a7572 AC |
1357 | |
1358 | begin | |
1359 | Print_Node_Ref (N); | |
1360 | ||
1361 | if N > Atree_Private_Part.Nodes.Last then | |
1362 | Print_Str (" (no such node)"); | |
1363 | Print_Eol; | |
1364 | return; | |
1365 | end if; | |
1366 | ||
8636f52f HK |
1367 | Print_Char (' '); |
1368 | ||
ee1a7572 | 1369 | if Comes_From_Source (N) then |
8636f52f | 1370 | Print_Header_Flag ("source"); |
ee1a7572 AC |
1371 | end if; |
1372 | ||
1373 | if Analyzed (N) then | |
8636f52f | 1374 | Print_Header_Flag ("analyzed"); |
ee1a7572 AC |
1375 | end if; |
1376 | ||
1377 | if Error_Posted (N) then | |
8636f52f HK |
1378 | Print_Header_Flag ("posted"); |
1379 | end if; | |
ee1a7572 | 1380 | |
8636f52f HK |
1381 | if Is_Ignored_Ghost_Node (N) then |
1382 | Print_Header_Flag ("ignored ghost"); | |
ee1a7572 AC |
1383 | end if; |
1384 | ||
b502ba3c RD |
1385 | if Check_Actuals (N) then |
1386 | Print_Header_Flag ("check actuals"); | |
fd957434 AC |
1387 | end if; |
1388 | ||
8636f52f | 1389 | if Enumerate then |
ee1a7572 AC |
1390 | Print_Char (')'); |
1391 | end if; | |
1392 | ||
1393 | Print_Eol; | |
1394 | end Print_Node_Header; | |
1395 | ||
415dddc8 RK |
1396 | --------------------- |
1397 | -- Print_Node_Kind -- | |
1398 | --------------------- | |
1399 | ||
1400 | procedure Print_Node_Kind (N : Node_Id) is | |
1401 | Ucase : Boolean; | |
1402 | S : constant String := Node_Kind'Image (Nkind (N)); | |
1403 | ||
1404 | begin | |
1405 | if Phase = Printing then | |
1406 | Ucase := True; | |
1407 | ||
1408 | -- Note: the call to Fold_Upper in this loop is to get past the GNAT | |
1409 | -- bug of 'Image returning lower case instead of upper case. | |
1410 | ||
1411 | for J in S'Range loop | |
1412 | if Ucase then | |
1413 | Write_Char (Fold_Upper (S (J))); | |
1414 | else | |
1415 | Write_Char (Fold_Lower (S (J))); | |
1416 | end if; | |
1417 | ||
1418 | Ucase := (S (J) = '_'); | |
1419 | end loop; | |
1420 | end if; | |
1421 | end Print_Node_Kind; | |
1422 | ||
1423 | -------------------- | |
1424 | -- Print_Node_Ref -- | |
1425 | -------------------- | |
1426 | ||
1427 | procedure Print_Node_Ref (N : Node_Id) is | |
1428 | S : Nat; | |
1429 | ||
1430 | begin | |
1431 | if Phase /= Printing then | |
1432 | return; | |
1433 | end if; | |
1434 | ||
1435 | if N = Empty then | |
1436 | Write_Str ("<empty>"); | |
1437 | ||
1438 | elsif N = Error then | |
1439 | Write_Str ("<error>"); | |
1440 | ||
1441 | else | |
1442 | if Printing_Descendants then | |
1443 | S := Serial_Number (Int (N)); | |
1444 | ||
1445 | if S /= 0 then | |
1446 | Write_Str ("Node"); | |
1447 | Write_Str (" #"); | |
1448 | Write_Int (S); | |
1449 | Write_Char (' '); | |
1450 | end if; | |
1451 | end if; | |
1452 | ||
1453 | Print_Node_Kind (N); | |
1454 | ||
1455 | if Nkind (N) in N_Has_Chars then | |
1456 | Write_Char (' '); | |
1457 | Print_Name (Chars (N)); | |
1458 | end if; | |
1459 | ||
1460 | if Nkind (N) in N_Entity then | |
1461 | Write_Str (" (Entity_Id="); | |
1462 | else | |
1463 | Write_Str (" (Node_Id="); | |
1464 | end if; | |
1465 | ||
1466 | Write_Int (Int (N)); | |
1467 | ||
1468 | if Sloc (N) <= Standard_Location then | |
1469 | Write_Char ('s'); | |
1470 | end if; | |
1471 | ||
1472 | Write_Char (')'); | |
1473 | ||
1474 | end if; | |
1475 | end Print_Node_Ref; | |
1476 | ||
1477 | ------------------------ | |
1478 | -- Print_Node_Subtree -- | |
1479 | ------------------------ | |
1480 | ||
1481 | procedure Print_Node_Subtree (N : Node_Id) is | |
1482 | begin | |
1483 | Print_Init; | |
1484 | ||
1485 | Next_Serial_Number := 1; | |
1486 | Phase := Marking; | |
1487 | Visit_Node (N, "", ' '); | |
1488 | ||
1489 | Next_Serial_Number := 1; | |
1490 | Phase := Printing; | |
1491 | Visit_Node (N, "", ' '); | |
1492 | ||
1493 | Print_Term; | |
1494 | end Print_Node_Subtree; | |
1495 | ||
1496 | --------------- | |
1497 | -- Print_Str -- | |
1498 | --------------- | |
1499 | ||
1500 | procedure Print_Str (S : String) is | |
1501 | begin | |
1502 | if Phase = Printing then | |
1503 | Write_Str (S); | |
1504 | end if; | |
1505 | end Print_Str; | |
1506 | ||
1507 | -------------------------- | |
1508 | -- Print_Str_Mixed_Case -- | |
1509 | -------------------------- | |
1510 | ||
1511 | procedure Print_Str_Mixed_Case (S : String) is | |
1512 | Ucase : Boolean; | |
1513 | ||
1514 | begin | |
1515 | if Phase = Printing then | |
1516 | Ucase := True; | |
1517 | ||
1518 | for J in S'Range loop | |
1519 | if Ucase then | |
1520 | Write_Char (S (J)); | |
1521 | else | |
1522 | Write_Char (Fold_Lower (S (J))); | |
1523 | end if; | |
1524 | ||
1525 | Ucase := (S (J) = '_'); | |
1526 | end loop; | |
1527 | end if; | |
1528 | end Print_Str_Mixed_Case; | |
1529 | ||
1530 | ---------------- | |
1531 | -- Print_Term -- | |
1532 | ---------------- | |
1533 | ||
1534 | procedure Print_Term is | |
1535 | procedure Free is new Unchecked_Deallocation | |
1536 | (Hash_Table_Type, Access_Hash_Table_Type); | |
1537 | ||
1538 | begin | |
1539 | Free (Hash_Table); | |
1540 | end Print_Term; | |
1541 | ||
1542 | --------------------- | |
1543 | -- Print_Tree_Elist -- | |
1544 | --------------------- | |
1545 | ||
1546 | procedure Print_Tree_Elist (E : Elist_Id) is | |
1547 | M : Elmt_Id; | |
1548 | ||
1549 | begin | |
1550 | Printing_Descendants := False; | |
1551 | Phase := Printing; | |
1552 | ||
1553 | Print_Elist_Ref (E); | |
1554 | Print_Eol; | |
1555 | ||
1556 | M := First_Elmt (E); | |
1557 | ||
1558 | if No (M) then | |
1559 | Print_Str ("<empty element list>"); | |
1560 | Print_Eol; | |
1561 | ||
1562 | else | |
1563 | loop | |
1564 | Print_Char ('|'); | |
1565 | Print_Eol; | |
1566 | exit when No (Next_Elmt (M)); | |
1567 | Print_Node (Node (M), "", '|'); | |
1568 | Next_Elmt (M); | |
1569 | end loop; | |
1570 | ||
1571 | Print_Node (Node (M), "", ' '); | |
1572 | Print_Eol; | |
1573 | end if; | |
1574 | end Print_Tree_Elist; | |
1575 | ||
1576 | --------------------- | |
1577 | -- Print_Tree_List -- | |
1578 | --------------------- | |
1579 | ||
1580 | procedure Print_Tree_List (L : List_Id) is | |
1581 | N : Node_Id; | |
1582 | ||
1583 | begin | |
1584 | Printing_Descendants := False; | |
1585 | Phase := Printing; | |
1586 | ||
1587 | Print_List_Ref (L); | |
1588 | Print_Str (" List_Id="); | |
1589 | Print_Int (Int (L)); | |
1590 | Print_Eol; | |
1591 | ||
1592 | N := First (L); | |
1593 | ||
1594 | if N = Empty then | |
1595 | Print_Str ("<empty node list>"); | |
1596 | Print_Eol; | |
1597 | ||
1598 | else | |
1599 | loop | |
1600 | Print_Char ('|'); | |
1601 | Print_Eol; | |
1602 | exit when Next (N) = Empty; | |
1603 | Print_Node (N, "", '|'); | |
1604 | Next (N); | |
1605 | end loop; | |
1606 | ||
1607 | Print_Node (N, "", ' '); | |
1608 | Print_Eol; | |
1609 | end if; | |
1610 | end Print_Tree_List; | |
1611 | ||
1612 | --------------------- | |
1613 | -- Print_Tree_Node -- | |
1614 | --------------------- | |
1615 | ||
1616 | procedure Print_Tree_Node (N : Node_Id; Label : String := "") is | |
1617 | begin | |
1618 | Printing_Descendants := False; | |
1619 | Phase := Printing; | |
1620 | Print_Node (N, Label, ' '); | |
1621 | end Print_Tree_Node; | |
1622 | ||
1623 | -------- | |
07fc65c4 | 1624 | -- pt -- |
415dddc8 RK |
1625 | -------- |
1626 | ||
6be44a9a | 1627 | procedure pt (N : Union_Id) is |
415dddc8 | 1628 | begin |
6be44a9a BD |
1629 | case N is |
1630 | when List_Low_Bound .. List_High_Bound - 1 => | |
1631 | Print_List_Subtree (List_Id (N)); | |
1632 | when Node_Range => | |
1633 | Print_Node_Subtree (Node_Id (N)); | |
1634 | when Elist_Range => | |
1635 | Print_Elist_Subtree (Elist_Id (N)); | |
1636 | when others => | |
1637 | pp (N); | |
1638 | end case; | |
07fc65c4 | 1639 | end pt; |
415dddc8 RK |
1640 | |
1641 | ------------------- | |
1642 | -- Serial_Number -- | |
1643 | ------------------- | |
1644 | ||
1645 | -- The hashing algorithm is to use the remainder of the ID value divided | |
1646 | -- by the hash table length as the starting point in the table, and then | |
1647 | -- handle collisions by serial searching wrapping at the end of the table. | |
1648 | ||
1649 | Hash_Slot : Nat; | |
1650 | -- Set by an unsuccessful call to Serial_Number (one which returns zero) | |
1651 | -- to save the slot that should be used if Set_Serial_Number is called. | |
1652 | ||
1653 | function Serial_Number (Id : Int) return Nat is | |
1654 | H : Int := Id mod Hash_Table_Len; | |
1655 | ||
1656 | begin | |
1657 | while Hash_Table (H).Serial /= 0 loop | |
1658 | ||
1659 | if Id = Hash_Table (H).Id then | |
1660 | return Hash_Table (H).Serial; | |
1661 | end if; | |
1662 | ||
1663 | H := H + 1; | |
1664 | ||
1665 | if H > Hash_Table'Last then | |
1666 | H := 0; | |
1667 | end if; | |
1668 | end loop; | |
1669 | ||
1670 | -- Entry was not found, save slot number for possible subsequent call | |
1671 | -- to Set_Serial_Number, and unconditionally save the Id in this slot | |
1672 | -- in case of such a call (the Id field is never read if the serial | |
1673 | -- number of the slot is zero, so this is harmless in the case where | |
1674 | -- Set_Serial_Number is not subsequently called). | |
1675 | ||
1676 | Hash_Slot := H; | |
1677 | Hash_Table (H).Id := Id; | |
1678 | return 0; | |
1679 | ||
1680 | end Serial_Number; | |
1681 | ||
1682 | ----------------------- | |
1683 | -- Set_Serial_Number -- | |
1684 | ----------------------- | |
1685 | ||
1686 | procedure Set_Serial_Number is | |
1687 | begin | |
1688 | Hash_Table (Hash_Slot).Serial := Next_Serial_Number; | |
1689 | Next_Serial_Number := Next_Serial_Number + 1; | |
1690 | end Set_Serial_Number; | |
1691 | ||
1692 | --------------- | |
1693 | -- Tree_Dump -- | |
1694 | --------------- | |
1695 | ||
1696 | procedure Tree_Dump is | |
1697 | procedure Underline; | |
1698 | -- Put underline under string we just printed | |
1699 | ||
1700 | procedure Underline is | |
1701 | Col : constant Int := Column; | |
1702 | ||
1703 | begin | |
1704 | Write_Eol; | |
1705 | ||
1706 | while Col > Column loop | |
1707 | Write_Char ('-'); | |
1708 | end loop; | |
1709 | ||
1710 | Write_Eol; | |
1711 | end Underline; | |
1712 | ||
1713 | -- Start of processing for Tree_Dump. Note that we turn off the tree dump | |
1714 | -- flags immediately, before starting the dump. This avoids generating two | |
1715 | -- copies of the dump if an abort occurs after printing the dump, and more | |
1716 | -- importantly, avoids an infinite loop if an abort occurs during the dump. | |
1717 | ||
1718 | -- Note: unlike in the source print case (in Sprint), we do not output | |
1719 | -- separate trees for each unit. Instead the -df debug switch causes the | |
1720 | -- tree that is output from the main unit to trace references into other | |
1721 | -- units (normally such references are not traced). Since all other units | |
1722 | -- are linked to the main unit by at least one reference, this causes all | |
1723 | -- tree nodes to be included in the output tree. | |
1724 | ||
1725 | begin | |
1726 | if Debug_Flag_Y then | |
1727 | Debug_Flag_Y := False; | |
1728 | Write_Eol; | |
1729 | Write_Str ("Tree created for Standard (spec) "); | |
1730 | Underline; | |
1731 | Print_Node_Subtree (Standard_Package_Node); | |
1732 | Write_Eol; | |
1733 | end if; | |
1734 | ||
1735 | if Debug_Flag_T then | |
1736 | Debug_Flag_T := False; | |
1737 | ||
1738 | Write_Eol; | |
1739 | Write_Str ("Tree created for "); | |
1740 | Write_Unit_Name (Unit_Name (Main_Unit)); | |
1741 | Underline; | |
1742 | Print_Node_Subtree (Cunit (Main_Unit)); | |
1743 | Write_Eol; | |
1744 | end if; | |
415dddc8 RK |
1745 | end Tree_Dump; |
1746 | ||
1747 | ----------------- | |
1748 | -- Visit_Elist -- | |
1749 | ----------------- | |
1750 | ||
1751 | procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is | |
1752 | M : Elmt_Id; | |
1753 | N : Node_Id; | |
1754 | S : constant Nat := Serial_Number (Int (E)); | |
1755 | ||
1756 | begin | |
1757 | -- In marking phase, return if already marked, otherwise set next | |
1758 | -- serial number in hash table for later reference. | |
1759 | ||
1760 | if Phase = Marking then | |
1761 | if S /= 0 then | |
1762 | return; -- already visited | |
1763 | else | |
1764 | Set_Serial_Number; | |
1765 | end if; | |
1766 | ||
1767 | -- In printing phase, if already printed, then return, otherwise we | |
1768 | -- are printing the next item, so increment the serial number. | |
1769 | ||
1770 | else | |
1771 | if S < Next_Serial_Number then | |
1772 | return; -- already printed | |
1773 | else | |
1774 | Next_Serial_Number := Next_Serial_Number + 1; | |
1775 | end if; | |
1776 | end if; | |
1777 | ||
1778 | -- Now process the list (Print calls have no effect in marking phase) | |
1779 | ||
1780 | Print_Str (Prefix_Str); | |
1781 | Print_Elist_Ref (E); | |
1782 | Print_Eol; | |
1783 | ||
1784 | if Is_Empty_Elmt_List (E) then | |
1785 | Print_Str (Prefix_Str); | |
1786 | Print_Str ("(Empty element list)"); | |
1787 | Print_Eol; | |
1788 | Print_Eol; | |
1789 | ||
1790 | else | |
1791 | if Phase = Printing then | |
1792 | M := First_Elmt (E); | |
1793 | while Present (M) loop | |
1794 | N := Node (M); | |
1795 | Print_Str (Prefix_Str); | |
1796 | Print_Str (" "); | |
1797 | Print_Node_Ref (N); | |
1798 | Print_Eol; | |
1799 | Next_Elmt (M); | |
1800 | end loop; | |
1801 | ||
1802 | Print_Str (Prefix_Str); | |
1803 | Print_Eol; | |
1804 | end if; | |
1805 | ||
1806 | M := First_Elmt (E); | |
1807 | while Present (M) loop | |
1808 | Visit_Node (Node (M), Prefix_Str, ' '); | |
1809 | Next_Elmt (M); | |
1810 | end loop; | |
1811 | end if; | |
1812 | end Visit_Elist; | |
1813 | ||
1814 | ---------------- | |
1815 | -- Visit_List -- | |
1816 | ---------------- | |
1817 | ||
1818 | procedure Visit_List (L : List_Id; Prefix_Str : String) is | |
1819 | N : Node_Id; | |
1820 | S : constant Nat := Serial_Number (Int (L)); | |
1821 | ||
1822 | begin | |
1823 | -- In marking phase, return if already marked, otherwise set next | |
1824 | -- serial number in hash table for later reference. | |
1825 | ||
1826 | if Phase = Marking then | |
1827 | if S /= 0 then | |
1828 | return; | |
1829 | else | |
1830 | Set_Serial_Number; | |
1831 | end if; | |
1832 | ||
1833 | -- In printing phase, if already printed, then return, otherwise we | |
1834 | -- are printing the next item, so increment the serial number. | |
1835 | ||
1836 | else | |
1837 | if S < Next_Serial_Number then | |
1838 | return; -- already printed | |
1839 | else | |
1840 | Next_Serial_Number := Next_Serial_Number + 1; | |
1841 | end if; | |
1842 | end if; | |
1843 | ||
1844 | -- Now process the list (Print calls have no effect in marking phase) | |
1845 | ||
1846 | Print_Str (Prefix_Str); | |
1847 | Print_List_Ref (L); | |
1848 | Print_Eol; | |
1849 | ||
1850 | Print_Str (Prefix_Str); | |
1851 | Print_Str ("|Parent = "); | |
1852 | Print_Node_Ref (Parent (L)); | |
1853 | Print_Eol; | |
1854 | ||
1855 | N := First (L); | |
1856 | ||
1857 | if N = Empty then | |
1858 | Print_Str (Prefix_Str); | |
1859 | Print_Str ("(Empty list)"); | |
1860 | Print_Eol; | |
1861 | Print_Eol; | |
1862 | ||
1863 | else | |
1864 | Print_Str (Prefix_Str); | |
1865 | Print_Char ('|'); | |
1866 | Print_Eol; | |
1867 | ||
1868 | while Next (N) /= Empty loop | |
1869 | Visit_Node (N, Prefix_Str, '|'); | |
1870 | Next (N); | |
1871 | end loop; | |
1872 | end if; | |
1873 | ||
1874 | Visit_Node (N, Prefix_Str, ' '); | |
1875 | end Visit_List; | |
1876 | ||
1877 | ---------------- | |
1878 | -- Visit_Node -- | |
1879 | ---------------- | |
1880 | ||
1881 | procedure Visit_Node | |
1882 | (N : Node_Id; | |
1883 | Prefix_Str : String; | |
1884 | Prefix_Char : Character) | |
1885 | is | |
1886 | New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2); | |
1887 | -- Prefix string for printing referenced fields | |
1888 | ||
1889 | procedure Visit_Descendent | |
1890 | (D : Union_Id; | |
1891 | No_Indent : Boolean := False); | |
1892 | -- This procedure tests the given value of one of the Fields referenced | |
1893 | -- by the current node to determine whether to visit it recursively. | |
3354f96d | 1894 | -- Normally No_Indent is false, which means that the visited node will |
415dddc8 RK |
1895 | -- be indented using New_Prefix. If No_Indent is set to True, then |
1896 | -- this indentation is skipped, and Prefix_Str is used for the call | |
1897 | -- to print the descendent. No_Indent is effective only if the | |
1898 | -- referenced descendent is a node. | |
1899 | ||
1900 | ---------------------- | |
1901 | -- Visit_Descendent -- | |
1902 | ---------------------- | |
1903 | ||
1904 | procedure Visit_Descendent | |
1905 | (D : Union_Id; | |
1906 | No_Indent : Boolean := False) | |
1907 | is | |
1908 | begin | |
1909 | -- Case of descendent is a node | |
1910 | ||
1911 | if D in Node_Range then | |
1912 | ||
1913 | -- Don't bother about Empty or Error descendents | |
1914 | ||
1915 | if D <= Union_Id (Empty_Or_Error) then | |
1916 | return; | |
1917 | end if; | |
1918 | ||
1919 | declare | |
1920 | Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D); | |
1921 | ||
1922 | begin | |
1923 | -- Descendents in one of the standardly compiled internal | |
1924 | -- packages are normally ignored, unless the parent is also | |
1925 | -- in such a package (happens when Standard itself is output) | |
1926 | -- or if the -df switch is set which causes all links to be | |
1927 | -- followed, even into package standard. | |
1928 | ||
1929 | if Sloc (Nod) <= Standard_Location then | |
1930 | if Sloc (N) > Standard_Location | |
1931 | and then not Debug_Flag_F | |
1932 | then | |
1933 | return; | |
1934 | end if; | |
1935 | ||
1936 | -- Don't bother about a descendent in a different unit than | |
1937 | -- the node we came from unless the -df switch is set. Note | |
1938 | -- that we know at this point that Sloc (D) > Standard_Location | |
1939 | ||
1940 | -- Note: the tests for No_Location here just make sure that we | |
1941 | -- don't blow up on a node which is missing an Sloc value. This | |
1942 | -- should not normally happen. | |
1943 | ||
1944 | else | |
1945 | if (Sloc (N) <= Standard_Location | |
1946 | or else Sloc (N) = No_Location | |
1947 | or else Sloc (Nod) = No_Location | |
1948 | or else not In_Same_Source_Unit (Nod, N)) | |
1949 | and then not Debug_Flag_F | |
1950 | then | |
1951 | return; | |
1952 | end if; | |
1953 | end if; | |
1954 | ||
1955 | -- Don't bother visiting a source node that has a parent which | |
1956 | -- is not the node we came from. We prefer to trace such nodes | |
1957 | -- from their real parents. This causes the tree to be printed | |
1958 | -- in a more coherent order, e.g. a defining identifier listed | |
1959 | -- next to its corresponding declaration, instead of next to | |
1960 | -- some semantic reference. | |
1961 | ||
1962 | -- This test is skipped for nodes in standard packages unless | |
1963 | -- the -dy option is set (which outputs the tree for standard) | |
1964 | ||
1965 | -- Also, always follow pointers to Is_Itype entities, | |
1966 | -- since we want to list these when they are first referenced. | |
1967 | ||
1968 | if Parent (Nod) /= Empty | |
1969 | and then Comes_From_Source (Nod) | |
1970 | and then Parent (Nod) /= N | |
1971 | and then (Sloc (N) > Standard_Location or else Debug_Flag_Y) | |
1972 | then | |
1973 | return; | |
1974 | end if; | |
1975 | ||
1976 | -- If we successfully fall through all the above tests (which | |
1977 | -- execute a return if the node is not to be visited), we can | |
a90bd866 | 1978 | -- go ahead and visit the node. |
415dddc8 RK |
1979 | |
1980 | if No_Indent then | |
1981 | Visit_Node (Nod, Prefix_Str, Prefix_Char); | |
1982 | else | |
1983 | Visit_Node (Nod, New_Prefix, ' '); | |
1984 | end if; | |
1985 | end; | |
1986 | ||
1987 | -- Case of descendent is a list | |
1988 | ||
1989 | elsif D in List_Range then | |
1990 | ||
1991 | -- Don't bother with a missing list, empty list or error list | |
1992 | ||
1993 | if D = Union_Id (No_List) | |
1994 | or else D = Union_Id (Error_List) | |
1995 | or else Is_Empty_List (List_Id (D)) | |
1996 | then | |
1997 | return; | |
1998 | ||
4c51ff88 AC |
1999 | -- Otherwise we can visit the list. Note that we don't bother to |
2000 | -- do the parent test that we did for the node case, because it | |
2001 | -- just does not happen that lists are referenced more than one | |
2002 | -- place in the tree. We aren't counting on this being the case | |
2003 | -- to generate valid output, it is just that we don't need in | |
2004 | -- practice to worry about listing the list at a place that is | |
2005 | -- inconvenient. | |
415dddc8 RK |
2006 | |
2007 | else | |
2008 | Visit_List (List_Id (D), New_Prefix); | |
2009 | end if; | |
2010 | ||
2011 | -- Case of descendent is an element list | |
2012 | ||
2013 | elsif D in Elist_Range then | |
2014 | ||
2015 | -- Don't bother with a missing list, or an empty list | |
2016 | ||
2017 | if D = Union_Id (No_Elist) | |
2018 | or else Is_Empty_Elmt_List (Elist_Id (D)) | |
2019 | then | |
2020 | return; | |
2021 | ||
2022 | -- Otherwise, visit the referenced element list | |
2023 | ||
2024 | else | |
2025 | Visit_Elist (Elist_Id (D), New_Prefix); | |
2026 | end if; | |
2027 | ||
2028 | -- For all other kinds of descendents (strings, names, uints etc), | |
2029 | -- there is nothing to visit (the contents of the field will be | |
2030 | -- printed when we print the containing node, but what concerns | |
2031 | -- us now is looking for descendents in the tree. | |
2032 | ||
2033 | else | |
2034 | null; | |
2035 | end if; | |
2036 | end Visit_Descendent; | |
2037 | ||
2038 | -- Start of processing for Visit_Node | |
2039 | ||
2040 | begin | |
2041 | if N = Empty then | |
2042 | return; | |
2043 | end if; | |
2044 | ||
2045 | -- Set fatal error node in case we get a blow up during the trace | |
2046 | ||
2047 | Current_Error_Node := N; | |
2048 | ||
2049 | New_Prefix (Prefix_Str'Range) := Prefix_Str; | |
2050 | New_Prefix (Prefix_Str'Last + 1) := Prefix_Char; | |
2051 | New_Prefix (Prefix_Str'Last + 2) := ' '; | |
2052 | ||
2053 | -- In the marking phase, all we do is to set the serial number | |
2054 | ||
2055 | if Phase = Marking then | |
2056 | if Serial_Number (Int (N)) /= 0 then | |
2057 | return; -- already visited | |
2058 | else | |
2059 | Set_Serial_Number; | |
2060 | end if; | |
2061 | ||
2062 | -- In the printing phase, we print the node | |
2063 | ||
2064 | else | |
2065 | if Serial_Number (Int (N)) < Next_Serial_Number then | |
2066 | ||
4c51ff88 AC |
2067 | -- Here we have already visited the node, but if it is in a list, |
2068 | -- we still want to print the reference, so that it is clear that | |
2069 | -- it belongs to the list. | |
415dddc8 RK |
2070 | |
2071 | if Is_List_Member (N) then | |
2072 | Print_Str (Prefix_Str); | |
2073 | Print_Node_Ref (N); | |
2074 | Print_Eol; | |
2075 | Print_Str (Prefix_Str); | |
2076 | Print_Char (Prefix_Char); | |
2077 | Print_Str ("(already output)"); | |
2078 | Print_Eol; | |
2079 | Print_Str (Prefix_Str); | |
2080 | Print_Char (Prefix_Char); | |
2081 | Print_Eol; | |
2082 | end if; | |
2083 | ||
2084 | return; | |
2085 | ||
2086 | else | |
2087 | Print_Node (N, Prefix_Str, Prefix_Char); | |
2088 | Print_Str (Prefix_Str); | |
2089 | Print_Char (Prefix_Char); | |
2090 | Print_Eol; | |
2091 | Next_Serial_Number := Next_Serial_Number + 1; | |
2092 | end if; | |
2093 | end if; | |
2094 | ||
2095 | -- Visit all descendents of this node | |
2096 | ||
2097 | if Nkind (N) not in N_Entity then | |
2098 | Visit_Descendent (Field1 (N)); | |
2099 | Visit_Descendent (Field2 (N)); | |
2100 | Visit_Descendent (Field3 (N)); | |
2101 | Visit_Descendent (Field4 (N)); | |
2102 | Visit_Descendent (Field5 (N)); | |
2103 | ||
c159409f AC |
2104 | if Has_Aspects (N) then |
2105 | Visit_Descendent (Union_Id (Aspect_Specifications (N))); | |
2106 | end if; | |
2107 | ||
415dddc8 RK |
2108 | -- Entity case |
2109 | ||
2110 | else | |
2111 | Visit_Descendent (Field1 (N)); | |
2112 | Visit_Descendent (Field3 (N)); | |
2113 | Visit_Descendent (Field4 (N)); | |
2114 | Visit_Descendent (Field5 (N)); | |
2115 | Visit_Descendent (Field6 (N)); | |
2116 | Visit_Descendent (Field7 (N)); | |
2117 | Visit_Descendent (Field8 (N)); | |
2118 | Visit_Descendent (Field9 (N)); | |
2119 | Visit_Descendent (Field10 (N)); | |
2120 | Visit_Descendent (Field11 (N)); | |
2121 | Visit_Descendent (Field12 (N)); | |
2122 | Visit_Descendent (Field13 (N)); | |
2123 | Visit_Descendent (Field14 (N)); | |
2124 | Visit_Descendent (Field15 (N)); | |
2125 | Visit_Descendent (Field16 (N)); | |
2126 | Visit_Descendent (Field17 (N)); | |
2127 | Visit_Descendent (Field18 (N)); | |
2128 | Visit_Descendent (Field19 (N)); | |
2129 | Visit_Descendent (Field20 (N)); | |
2130 | Visit_Descendent (Field21 (N)); | |
2131 | Visit_Descendent (Field22 (N)); | |
2132 | Visit_Descendent (Field23 (N)); | |
2133 | ||
e80f0cb0 RD |
2134 | -- Now an interesting special case. Normally parents are always |
2135 | -- printed since we traverse the tree in a downwards direction. | |
2136 | -- However, there is an exception to this rule, which is the | |
2137 | -- case where a parent is constructed by the compiler and is not | |
2138 | -- referenced elsewhere in the tree. The following catches this case. | |
fbf5a39b AC |
2139 | |
2140 | if not Comes_From_Source (N) then | |
2141 | Visit_Descendent (Union_Id (Parent (N))); | |
2142 | end if; | |
2143 | ||
415dddc8 RK |
2144 | -- You may be wondering why we omitted Field2 above. The answer |
2145 | -- is that this is the Next_Entity field, and we want to treat | |
2146 | -- it rather specially. Why? Because a Next_Entity link does not | |
2147 | -- correspond to a level deeper in the tree, and we do not want | |
2148 | -- the tree to march off to the right of the page due to bogus | |
2149 | -- indentations coming from this effect. | |
2150 | ||
2151 | -- To prevent this, what we do is to control references via | |
4c51ff88 AC |
2152 | -- Next_Entity only from the first entity on a given scope chain, |
2153 | -- and we keep them all at the same level. Of course if an entity | |
2154 | -- has already been referenced it is not printed. | |
415dddc8 RK |
2155 | |
2156 | if Present (Next_Entity (N)) | |
2157 | and then Present (Scope (N)) | |
2158 | and then First_Entity (Scope (N)) = N | |
2159 | then | |
2160 | declare | |
2161 | Nod : Node_Id; | |
2162 | ||
2163 | begin | |
2164 | Nod := N; | |
2165 | while Present (Nod) loop | |
2166 | Visit_Descendent (Union_Id (Next_Entity (Nod))); | |
2167 | Nod := Next_Entity (Nod); | |
2168 | end loop; | |
2169 | end; | |
2170 | end if; | |
2171 | end if; | |
2172 | end Visit_Node; | |
2173 | ||
2174 | end Treepr; |