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