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