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