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