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