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