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