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