1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A T R E E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, 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 Debug; use Debug; 28with Namet; use Namet; 29with Nlists; use Nlists; 30with Opt; use Opt; 31with Output; use Output; 32with Sinfo.Utils; use Sinfo.Utils; 33with System.Storage_Elements; 34 35package body Atree is 36 37 --------------- 38 -- Debugging -- 39 --------------- 40 41 -- Suppose you find that node 12345 is messed up. You might want to find 42 -- the code that created that node. See sinfo-utils.adb for how to do that. 43 44 Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null; 45 -- This soft link captures the procedure invoked during the creation of an 46 -- ignored Ghost node or entity. 47 48 Locked : Boolean := False; 49 -- Compiling with assertions enabled, node contents modifications are 50 -- permitted only when this switch is set to False; compiling without 51 -- assertions this lock has no effect. 52 53 Reporting_Proc : Report_Proc := null; 54 -- Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only 55 -- once. 56 57 Rewriting_Proc : Rewrite_Proc := null; 58 -- This soft link captures the procedure invoked during a node rewrite 59 60 ----------------------------- 61 -- Local Objects and Types -- 62 ----------------------------- 63 64 Comes_From_Source_Default : Boolean := False; 65 66 use Atree_Private_Part; 67 -- We are also allowed to see our private data structures 68 69 -------------------------------------------------- 70 -- Implementation of Tree Substitution Routines -- 71 -------------------------------------------------- 72 73 -- A separate table keeps track of the mapping between rewritten nodes and 74 -- their corresponding original tree nodes. Rewrite makes an entry in this 75 -- table for use by Original_Node. By default the entry in this table 76 -- points to the original unwritten node. Note that if a node is rewritten 77 -- more than once, there is no easy way to get to the intermediate 78 -- rewrites; the node itself is the latest version, and the entry in this 79 -- table is the original. 80 81 -- Note: This could be a node field. 82 83 package Orig_Nodes is new Table.Table ( 84 Table_Component_Type => Node_Id, 85 Table_Index_Type => Node_Id'Base, 86 Table_Low_Bound => First_Node_Id, 87 Table_Initial => Alloc.Node_Offsets_Initial, 88 Table_Increment => Alloc.Node_Offsets_Increment, 89 Table_Name => "Orig_Nodes"); 90 91 -------------------------- 92 -- Paren_Count Handling -- 93 -------------------------- 94 95 -- The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is 96 -- in the range 0 .. 2, then it is stoed as Small_Paren_Count. Otherwise, 97 -- Small_Paren_Count = 3, and the actual Paren_Count is stored in the 98 -- Paren_Counts table. 99 -- 100 -- We use linear search on the Paren_Counts table, which is plenty 101 -- efficient because only pathological programs will use it. Nobody 102 -- writes (((X + Y))). 103 104 type Paren_Count_Entry is record 105 Nod : Node_Id; 106 -- The node to which this count applies 107 108 Count : Nat range 3 .. Nat'Last; 109 -- The count of parentheses, which will be in the indicated range 110 end record; 111 112 package Paren_Counts is new Table.Table ( 113 Table_Component_Type => Paren_Count_Entry, 114 Table_Index_Type => Int, 115 Table_Low_Bound => 0, 116 Table_Initial => 10, 117 Table_Increment => 200, 118 Table_Name => "Paren_Counts"); 119 120 procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id); 121 pragma Inline (Set_Paren_Count_Of_Copy); 122 -- Called when copying a node. Makes sure the Paren_Count of the copy is 123 -- correct. 124 125 ----------------------- 126 -- Local Subprograms -- 127 ----------------------- 128 129 function Allocate_New_Node (Kind : Node_Kind) return Node_Id; 130 pragma Inline (Allocate_New_Node); 131 -- Allocate a new node or first part of a node extension. Initialize the 132 -- Nodes.Table entry, Flags, Orig_Nodes, and List tables. 133 134 procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id); 135 -- Fix up parent pointers for the children of Fix_Node after a copy, 136 -- setting them to Fix_Node when they pointed to Ref_Node. 137 138 procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id); 139 -- Mark arbitrary node or entity N as Ghost when it is created within a 140 -- Ghost region. 141 142 procedure Report (Target, Source : Node_Id); 143 pragma Inline (Report); 144 -- Invoke the reporting procedure if available 145 146 function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count; 147 -- Number of slots belonging to N. This can be less than 148 -- Size_In_Slots_To_Alloc for entities. Includes both header 149 -- and dynamic slots. 150 151 function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count; 152 -- Just counts the number of dynamic slots 153 154 function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Slot_Count; 155 function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count; 156 -- Number of slots to allocate for a node or entity. For entities, we have 157 -- to allocate the max, because we don't know the Ekind when this is 158 -- called. 159 160 function Off_F (N : Node_Id) return Node_Offset with Inline; 161 -- Offset of the first dynamic slot of N in Slots.Table. 162 -- The actual offset of this slot from the start of the node 163 -- is not 0; this is logically the first slot after the header 164 -- slots. 165 166 function Off_0 (N : Node_Id) return Node_Offset'Base with Inline; 167 -- This is for zero-origin addressing of the dynamic slots. 168 -- It points to slot 0 of N in Slots.Table, which does not exist, 169 -- because the first few slots are stored in the header. 170 171 function Off_L (N : Node_Id) return Node_Offset with Inline; 172 -- Offset of the last slot of N in Slots.Table 173 174 procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) with Inline; 175 -- Set dynamic slots in the range First..Last to zero 176 177 procedure Zero_Header_Slots (N : Node_Or_Entity_Id) with Inline; 178 -- Zero the header slots belonging to N 179 180 procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline; 181 -- Zero the slots belonging to N (both header and dynamic) 182 183 procedure Copy_Dynamic_Slots 184 (From, To : Node_Offset; Num_Slots : Slot_Count) 185 with Inline; 186 -- Copy Num_Slots slots from From to To. Caller is responsible for ensuring 187 -- that the Num_Slots at To are a reasonable place to copy to. 188 189 procedure Copy_Slots (Source, Destination : Node_Id) with Inline; 190 -- Copies the slots (both header and dynamic) of Source to Destination; 191 -- uses the node kind to determine the Num_Slots. 192 193 function Get_Field_Value 194 (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit; 195 -- Get any field value as a Field_Size_32_Bit. If the field is smaller than 196 -- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in 197 -- the Nkind of N. 198 199 procedure Set_Field_Value 200 (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit); 201 -- Set any field value as a Field_Size_32_Bit. If the field is smaller than 202 -- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small 203 -- enough. The Field must be present in the Nkind of N. 204 205 procedure Check_Vanishing_Fields 206 (Old_N : Node_Id; New_Kind : Node_Kind); 207 -- Called whenever Nkind is modified. Raises an exception if not all 208 -- vanishing fields are in their initial zero state. 209 210 procedure Check_Vanishing_Fields 211 (Old_N : Entity_Id; New_Kind : Entity_Kind); 212 -- Above are the same as the ones for nodes, but for entities 213 214 procedure Init_Nkind (N : Node_Id; Val : Node_Kind); 215 -- Initialize the Nkind field, which must not have been set already. This 216 -- cannot be used to modify an already-initialized Nkind field. See also 217 -- Mutate_Nkind. 218 219 procedure Mutate_Nkind 220 (N : Node_Id; Val : Node_Kind; Old_Size : Slot_Count); 221 -- Called by the other Mutate_Nkind to do all the work. This is needed 222 -- because the call in Change_Node, which calls this one directly, happens 223 -- after zeroing N's slots, which destroys its Nkind, which prevents us 224 -- from properly computing Old_Size. 225 226 package Field_Checking is 227 -- Functions for checking field access, used only in assertions 228 229 function Field_Present 230 (Kind : Node_Kind; Field : Node_Field) return Boolean; 231 function Field_Present 232 (Kind : Entity_Kind; Field : Entity_Field) return Boolean; 233 -- True if a node/entity of the given Kind has the given Field. 234 -- Always True if assertions are disabled. 235 236 end Field_Checking; 237 238 package body Field_Checking is 239 240 -- Tables used by Field_Present 241 242 type Node_Field_Sets is array (Node_Kind) of Node_Field_Set; 243 type Node_Field_Sets_Ptr is access all Node_Field_Sets; 244 Node_Fields_Present : Node_Field_Sets_Ptr; 245 246 type Entity_Field_Sets is array (Entity_Kind) of Entity_Field_Set; 247 type Entity_Field_Sets_Ptr is access all Entity_Field_Sets; 248 Entity_Fields_Present : Entity_Field_Sets_Ptr; 249 250 procedure Init_Tables; 251 252 function Create_Node_Fields_Present 253 (Kind : Node_Kind) return Node_Field_Set; 254 function Create_Entity_Fields_Present 255 (Kind : Entity_Kind) return Entity_Field_Set; 256 -- Computes the set of fields present in each Node/Entity Kind. Used to 257 -- initialize the above tables. 258 259 -------------------------------- 260 -- Create_Node_Fields_Present -- 261 -------------------------------- 262 263 function Create_Node_Fields_Present 264 (Kind : Node_Kind) return Node_Field_Set 265 is 266 Result : Node_Field_Set := (others => False); 267 begin 268 for J in Node_Field_Table (Kind)'Range loop 269 Result (Node_Field_Table (Kind) (J)) := True; 270 end loop; 271 272 return Result; 273 end Create_Node_Fields_Present; 274 275 -------------------------------- 276 -- Create_Entity_Fields_Present -- 277 -------------------------------- 278 279 function Create_Entity_Fields_Present 280 (Kind : Entity_Kind) return Entity_Field_Set 281 is 282 Result : Entity_Field_Set := (others => False); 283 begin 284 for J in Entity_Field_Table (Kind)'Range loop 285 Result (Entity_Field_Table (Kind) (J)) := True; 286 end loop; 287 288 return Result; 289 end Create_Entity_Fields_Present; 290 291 ----------------- 292 -- Init_Tables -- 293 ----------------- 294 295 procedure Init_Tables is 296 begin 297 Node_Fields_Present := new Node_Field_Sets; 298 299 for Kind in Node_Kind loop 300 Node_Fields_Present (Kind) := Create_Node_Fields_Present (Kind); 301 end loop; 302 303 Entity_Fields_Present := new Entity_Field_Sets; 304 305 for Kind in Entity_Kind loop 306 Entity_Fields_Present (Kind) := 307 Create_Entity_Fields_Present (Kind); 308 end loop; 309 end Init_Tables; 310 311 -- In production mode, we leave Node_Fields_Present and 312 -- Entity_Fields_Present null. Field_Present is only for 313 -- use in assertions. 314 315 pragma Debug (Init_Tables); 316 317 function Field_Present 318 (Kind : Node_Kind; Field : Node_Field) return Boolean is 319 begin 320 if Node_Fields_Present = null then 321 return True; 322 end if; 323 324 return Node_Fields_Present (Kind) (Field); 325 end Field_Present; 326 327 function Field_Present 328 (Kind : Entity_Kind; Field : Entity_Field) return Boolean is 329 begin 330 if Entity_Fields_Present = null then 331 return True; 332 end if; 333 334 return Entity_Fields_Present (Kind) (Field); 335 end Field_Present; 336 337 end Field_Checking; 338 339 ------------------------ 340 -- Atree_Private_Part -- 341 ------------------------ 342 343 package body Atree_Private_Part is 344 345 -- The following validators are disabled in production builds, by being 346 -- called in pragma Debug. They are also disabled by default in debug 347 -- builds, by setting the flags below, because they make the compiler 348 -- very slow (10 to 20 times slower). Validate can be set True to debug 349 -- the low-level accessors. 350 -- 351 -- Even if Validate is True, validation is disabled during 352 -- Validate_... calls to prevent infinite recursion 353 -- (Validate_... procedures call field getters, which call 354 -- Validate_... procedures). That's what the Enable_Validate_... 355 -- flags are for; they are toggled so that when we're inside one 356 -- of them, and enter it again, the inner call doesn't do anything. 357 -- These flags are irrelevant when Validate is False. 358 359 Validate : constant Boolean := False; 360 361 Enable_Validate_Node, 362 Enable_Validate_Node_Write, 363 Enable_Validate_Node_And_Offset, 364 Enable_Validate_Node_And_Offset_Write : 365 Boolean := Validate; 366 367 procedure Validate_Node_And_Offset 368 (N : Node_Or_Entity_Id; Offset : Field_Offset); 369 procedure Validate_Node_And_Offset_Write 370 (N : Node_Or_Entity_Id; Offset : Field_Offset); 371 -- Asserts N is OK, and the Offset in slots is within N. Note that this 372 -- does not guarantee that the offset is valid, just that it's not past 373 -- the last slot. It could be pointing at unused bits within the node, 374 -- or unused padding at the end. The "_Write" version is used when we're 375 -- about to modify the node. 376 377 procedure Validate_Node_And_Offset 378 (N : Node_Or_Entity_Id; Offset : Field_Offset) is 379 begin 380 if Enable_Validate_Node_And_Offset then 381 Enable_Validate_Node_And_Offset := False; 382 383 pragma Debug (Validate_Node (N)); 384 pragma Assert (Offset'Valid); 385 pragma Assert (Offset < Size_In_Slots (N)); 386 387 Enable_Validate_Node_And_Offset := True; 388 end if; 389 end Validate_Node_And_Offset; 390 391 procedure Validate_Node_And_Offset_Write 392 (N : Node_Or_Entity_Id; Offset : Field_Offset) is 393 begin 394 if Enable_Validate_Node_And_Offset_Write then 395 Enable_Validate_Node_And_Offset_Write := False; 396 397 pragma Debug (Validate_Node_Write (N)); 398 pragma Assert (Offset'Valid); 399 pragma Assert (Offset < Size_In_Slots (N)); 400 401 Enable_Validate_Node_And_Offset_Write := True; 402 end if; 403 end Validate_Node_And_Offset_Write; 404 405 procedure Validate_Node (N : Node_Or_Entity_Id) is 406 begin 407 if Enable_Validate_Node then 408 Enable_Validate_Node := False; 409 410 pragma Assert (N'Valid); 411 pragma Assert (N <= Node_Offsets.Last); 412 pragma Assert (Off_L (N) >= Off_0 (N)); 413 pragma Assert (Off_L (N) >= Off_F (N) - 1); 414 pragma Assert (Off_L (N) <= Slots.Last); 415 pragma Assert (Nkind (N)'Valid); 416 pragma Assert (Nkind (N) /= N_Unused_At_End); 417 418 if Nkind (N) in N_Entity then 419 pragma Assert (Ekind (N)'Valid); 420 end if; 421 422 if Nkind (N) in 423 N_Aggregate 424 | N_Attribute_Definition_Clause 425 | N_Aspect_Specification 426 | N_Extension_Aggregate 427 | N_Freeze_Entity 428 | N_Freeze_Generic_Entity 429 | N_Has_Entity 430 | N_Selected_Component 431 | N_Use_Package_Clause 432 then 433 pragma Assert (Entity_Or_Associated_Node (N)'Valid); 434 end if; 435 436 Enable_Validate_Node := True; 437 end if; 438 end Validate_Node; 439 440 procedure Validate_Node_Write (N : Node_Or_Entity_Id) is 441 begin 442 if Enable_Validate_Node_Write then 443 Enable_Validate_Node_Write := False; 444 445 pragma Debug (Validate_Node (N)); 446 pragma Assert (not Locked); 447 448 Enable_Validate_Node_Write := True; 449 end if; 450 end Validate_Node_Write; 451 452 function Is_Valid_Node (U : Union_Id) return Boolean is 453 begin 454 return Node_Id'Base (U) <= Node_Offsets.Last; 455 end Is_Valid_Node; 456 457 function Alloc_Node_Id return Node_Id is 458 begin 459 Node_Offsets.Increment_Last; 460 return Node_Offsets.Last; 461 end Alloc_Node_Id; 462 463 function Alloc_Slots (Num_Slots : Slot_Count) return Node_Offset is 464 begin 465 return Result : constant Node_Offset := Slots.Last + 1 do 466 Slots.Set_Last (Slots.Last + Num_Slots); 467 end return; 468 end Alloc_Slots; 469 470 function Get_1_Bit_Field 471 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 472 is 473 pragma Assert (Field_Type'Size = 1); 474 475 function Cast is new 476 Unchecked_Conversion (Field_Size_1_Bit, Field_Type); 477 Val : constant Field_Size_1_Bit := Get_1_Bit_Val (N, Offset); 478 begin 479 return Cast (Val); 480 end Get_1_Bit_Field; 481 482 function Get_2_Bit_Field 483 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 484 is 485 pragma Assert (Field_Type'Size = 2); 486 487 function Cast is new 488 Unchecked_Conversion (Field_Size_2_Bit, Field_Type); 489 Val : constant Field_Size_2_Bit := Get_2_Bit_Val (N, Offset); 490 begin 491 return Cast (Val); 492 end Get_2_Bit_Field; 493 494 function Get_4_Bit_Field 495 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 496 is 497 pragma Assert (Field_Type'Size = 4); 498 499 function Cast is new 500 Unchecked_Conversion (Field_Size_4_Bit, Field_Type); 501 Val : constant Field_Size_4_Bit := Get_4_Bit_Val (N, Offset); 502 begin 503 return Cast (Val); 504 end Get_4_Bit_Field; 505 506 function Get_8_Bit_Field 507 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 508 is 509 pragma Assert (Field_Type'Size = 8); 510 511 function Cast is new 512 Unchecked_Conversion (Field_Size_8_Bit, Field_Type); 513 Val : constant Field_Size_8_Bit := Get_8_Bit_Val (N, Offset); 514 begin 515 return Cast (Val); 516 end Get_8_Bit_Field; 517 518 function Get_32_Bit_Field 519 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 520 is 521 pragma Assert (Field_Type'Size = 32); 522 523 function Cast is new 524 Unchecked_Conversion (Field_Size_32_Bit, Field_Type); 525 526 Val : constant Field_Size_32_Bit := Get_32_Bit_Val (N, Offset); 527 Result : constant Field_Type := Cast (Val); 528 -- Note: declaring Result here instead of directly returning 529 -- Cast (...) helps CodePeer understand that there are no issues 530 -- around uninitialized variables. 531 begin 532 return Result; 533 end Get_32_Bit_Field; 534 535 function Get_32_Bit_Field_With_Default 536 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 537 is 538 function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline; 539 Result : Field_Type; 540 begin 541 -- If the field has not yet been set, it will be equal to zero. 542 -- That is of the "wrong" type, so we fetch it as a 543 -- Field_Size_32_Bit. 544 545 if Get_32_Bit_Val (N, Offset) = 0 then 546 Result := Default_Val; 547 548 else 549 Result := Get_Field (N, Offset); 550 end if; 551 552 return Result; 553 end Get_32_Bit_Field_With_Default; 554 555 function Get_Valid_32_Bit_Field 556 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type 557 is 558 pragma Assert (Get_32_Bit_Val (N, Offset) /= 0); 559 -- If the field has not yet been set, it will be equal to zero. 560 -- This asserts that we don't call Get_ before Set_. Note that 561 -- the predicate on the Val parameter of Set_ checks for the No_... 562 -- value, so it can't possibly be (for example) No_Uint here. 563 564 function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline; 565 Result : constant Field_Type := Get_Field (N, Offset); 566 begin 567 return Result; 568 end Get_Valid_32_Bit_Field; 569 570 procedure Set_1_Bit_Field 571 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) 572 is 573 pragma Assert (Field_Type'Size = 1); 574 575 function Cast is new 576 Unchecked_Conversion (Field_Type, Field_Size_1_Bit); 577 begin 578 Set_1_Bit_Val (N, Offset, Cast (Val)); 579 end Set_1_Bit_Field; 580 581 procedure Set_2_Bit_Field 582 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) 583 is 584 pragma Assert (Field_Type'Size = 2); 585 586 function Cast is new 587 Unchecked_Conversion (Field_Type, Field_Size_2_Bit); 588 begin 589 Set_2_Bit_Val (N, Offset, Cast (Val)); 590 end Set_2_Bit_Field; 591 592 procedure Set_4_Bit_Field 593 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) 594 is 595 pragma Assert (Field_Type'Size = 4); 596 597 function Cast is new 598 Unchecked_Conversion (Field_Type, Field_Size_4_Bit); 599 begin 600 Set_4_Bit_Val (N, Offset, Cast (Val)); 601 end Set_4_Bit_Field; 602 603 procedure Set_8_Bit_Field 604 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) 605 is 606 pragma Assert (Field_Type'Size = 8); 607 608 function Cast is new 609 Unchecked_Conversion (Field_Type, Field_Size_8_Bit); 610 begin 611 Set_8_Bit_Val (N, Offset, Cast (Val)); 612 end Set_8_Bit_Field; 613 614 procedure Set_32_Bit_Field 615 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) 616 is 617 pragma Assert (Field_Type'Size = 32); 618 619 function Cast is new 620 Unchecked_Conversion (Field_Type, Field_Size_32_Bit); 621 begin 622 Set_32_Bit_Val (N, Offset, Cast (Val)); 623 end Set_32_Bit_Field; 624 625 pragma Style_Checks ("M90"); 626 627 ----------------------------------- 628 -- Low-level getters and setters -- 629 ----------------------------------- 630 631 -- In the getters and setters below, we use shifting and masking to 632 -- simulate packed arrays. F_Size is the field size in bits. Mask is 633 -- that number of 1 bits in the low-order bits. F_Per_Slot is the number 634 -- of fields per slot. Slot_Off is the offset of the slot of interest. 635 -- S is the slot at that offset. V is the amount to shift by. 636 637 function In_NH (Slot_Off : Field_Offset) return Boolean is 638 (Slot_Off < N_Head); 639 -- In_NH stands for "in Node_Header", not "in New Hampshire" 640 641 function Get_Slot 642 (N : Node_Or_Entity_Id; Slot_Off : Field_Offset) 643 return Slot is 644 (if In_NH (Slot_Off) then 645 Node_Offsets.Table (N).Slots (Slot_Off) 646 else Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off)); 647 -- Get the slot value, either directly from the node header, or 648 -- indirectly from the Slots table. 649 650 procedure Set_Slot 651 (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot); 652 -- Set the slot value, either directly from the node header, or 653 -- indirectly from the Slots table, to S. 654 655 function Get_1_Bit_Val 656 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit 657 is 658 F_Size : constant := 1; 659 Mask : constant := 2**F_Size - 1; 660 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 661 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 662 S : constant Slot := Get_Slot (N, Slot_Off); 663 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 664 pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); 665 Raw : constant Field_Size_1_Bit := 666 Field_Size_1_Bit (Shift_Right (S, V) and Mask); 667 begin 668 return Raw; 669 end Get_1_Bit_Val; 670 671 function Get_2_Bit_Val 672 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit 673 is 674 F_Size : constant := 2; 675 Mask : constant := 2**F_Size - 1; 676 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 677 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 678 S : constant Slot := Get_Slot (N, Slot_Off); 679 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 680 pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); 681 Raw : constant Field_Size_2_Bit := 682 Field_Size_2_Bit (Shift_Right (S, V) and Mask); 683 begin 684 return Raw; 685 end Get_2_Bit_Val; 686 687 function Get_4_Bit_Val 688 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit 689 is 690 F_Size : constant := 4; 691 Mask : constant := 2**F_Size - 1; 692 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 693 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 694 S : constant Slot := Get_Slot (N, Slot_Off); 695 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 696 pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); 697 Raw : constant Field_Size_4_Bit := 698 Field_Size_4_Bit (Shift_Right (S, V) and Mask); 699 begin 700 return Raw; 701 end Get_4_Bit_Val; 702 703 function Get_8_Bit_Val 704 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit 705 is 706 F_Size : constant := 8; 707 Mask : constant := 2**F_Size - 1; 708 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 709 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 710 S : constant Slot := Get_Slot (N, Slot_Off); 711 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 712 pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); 713 Raw : constant Field_Size_8_Bit := 714 Field_Size_8_Bit (Shift_Right (S, V) and Mask); 715 begin 716 return Raw; 717 end Get_8_Bit_Val; 718 719 function Get_32_Bit_Val 720 (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit 721 is 722 F_Size : constant := 32; 723 -- No Mask needed 724 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 725 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 726 S : constant Slot := Get_Slot (N, Slot_Off); 727 pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); 728 Raw : constant Field_Size_32_Bit := 729 Field_Size_32_Bit (S); 730 begin 731 return Raw; 732 end Get_32_Bit_Val; 733 734 procedure Set_Slot 735 (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot) is 736 begin 737 if In_NH (Slot_Off) then 738 Node_Offsets.Table (N).Slots (Slot_Off) := S; 739 else 740 Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off) := S; 741 end if; 742 end Set_Slot; 743 744 procedure Set_1_Bit_Val 745 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit) 746 is 747 F_Size : constant := 1; 748 Mask : constant := 2**F_Size - 1; 749 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 750 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 751 S : constant Slot := Get_Slot (N, Slot_Off); 752 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 753 pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); 754 begin 755 Set_Slot 756 (N, Slot_Off, 757 (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); 758 end Set_1_Bit_Val; 759 760 procedure Set_2_Bit_Val 761 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit) 762 is 763 F_Size : constant := 2; 764 Mask : constant := 2**F_Size - 1; 765 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 766 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 767 S : constant Slot := Get_Slot (N, Slot_Off); 768 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 769 pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); 770 begin 771 Set_Slot 772 (N, Slot_Off, 773 (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); 774 end Set_2_Bit_Val; 775 776 procedure Set_4_Bit_Val 777 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit) 778 is 779 F_Size : constant := 4; 780 Mask : constant := 2**F_Size - 1; 781 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 782 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 783 S : constant Slot := Get_Slot (N, Slot_Off); 784 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 785 pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); 786 begin 787 Set_Slot 788 (N, Slot_Off, 789 (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); 790 end Set_4_Bit_Val; 791 792 procedure Set_8_Bit_Val 793 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit) 794 is 795 F_Size : constant := 8; 796 Mask : constant := 2**F_Size - 1; 797 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 798 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 799 S : constant Slot := Get_Slot (N, Slot_Off); 800 V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); 801 pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); 802 begin 803 Set_Slot 804 (N, Slot_Off, 805 (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); 806 end Set_8_Bit_Val; 807 808 procedure Set_32_Bit_Val 809 (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit) 810 is 811 F_Size : constant := 32; 812 -- No Mask needed; this one doesn't do read-modify-write 813 F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; 814 Slot_Off : constant Field_Offset := Offset / F_Per_Slot; 815 pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); 816 begin 817 Set_Slot (N, Slot_Off, Slot (Val)); 818 end Set_32_Bit_Val; 819 820 ---------------------- 821 -- Print_Atree_Info -- 822 ---------------------- 823 824 procedure Print_Atree_Info (N : Node_Or_Entity_Id) is 825 function Cast is new Unchecked_Conversion (Slot, Int); 826 begin 827 Write_Int (Int (Size_In_Slots (N))); 828 Write_Str (" slots ("); 829 Write_Int (Int (Off_0 (N))); 830 Write_Str (" .. "); 831 Write_Int (Int (Off_L (N))); 832 Write_Str ("):"); 833 834 for Off in Off_0 (N) .. Off_L (N) loop 835 Write_Str (" "); 836 Write_Int (Cast (Get_Slot (N, Off))); 837 end loop; 838 839 Write_Eol; 840 end Print_Atree_Info; 841 842 end Atree_Private_Part; 843 844 --------------------- 845 -- Get_Field_Value -- 846 --------------------- 847 848 function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id) 849 with Inline; 850 -- Called when we don't know whether a field is a Node_Id or a List_Id, 851 -- etc. 852 853 function Get_Field_Value 854 (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit 855 is 856 Desc : Field_Descriptor renames Field_Descriptors (Field); 857 NN : constant Node_Or_Entity_Id := Node_To_Fetch_From (N, Field); 858 859 begin 860 case Field_Size (Desc.Kind) is 861 when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (NN, Desc.Offset)); 862 when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (NN, Desc.Offset)); 863 when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (NN, Desc.Offset)); 864 when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (NN, Desc.Offset)); 865 when others => return Get_32_Bit_Val (NN, Desc.Offset); -- 32 866 end case; 867 end Get_Field_Value; 868 869 --------------------- 870 -- Set_Field_Value -- 871 --------------------- 872 873 procedure Set_Field_Value 874 (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit) 875 is 876 Desc : Field_Descriptor renames Field_Descriptors (Field); 877 878 begin 879 case Field_Size (Desc.Kind) is 880 when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val)); 881 when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val)); 882 when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val)); 883 when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val)); 884 when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32 885 end case; 886 end Set_Field_Value; 887 888 procedure Reinit_Field_To_Zero 889 (N : Node_Id; Field : Node_Or_Entity_Field) 890 is 891 begin 892 Set_Field_Value (N, Field, 0); 893 end Reinit_Field_To_Zero; 894 895 function Field_Is_Initial_Zero 896 (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean is 897 begin 898 return Get_Field_Value (N, Field) = 0; 899 end Field_Is_Initial_Zero; 900 901 procedure Reinit_Field_To_Zero 902 (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind_Set) is 903 begin 904 pragma Assert (Old_Ekind (Ekind (N)), "Reinit: " & Ekind (N)'Img); 905 Reinit_Field_To_Zero (N, Field); 906 end Reinit_Field_To_Zero; 907 908 procedure Reinit_Field_To_Zero 909 (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind) is 910 Old_Ekind_Set : Entity_Kind_Set := (others => False); 911 begin 912 Old_Ekind_Set (Old_Ekind) := True; 913 Reinit_Field_To_Zero (N, Field, Old_Ekind => Old_Ekind_Set); 914 end Reinit_Field_To_Zero; 915 916 procedure Check_Vanishing_Fields 917 (Old_N : Node_Id; New_Kind : Node_Kind) 918 is 919 Old_Kind : constant Node_Kind := Nkind (Old_N); 920 921 -- If this fails, it means you need to call Reinit_Field_To_Zero before 922 -- calling Mutate_Nkind. 923 924 begin 925 for J in Node_Field_Table (Old_Kind)'Range loop 926 declare 927 F : constant Node_Field := Node_Field_Table (Old_Kind) (J); 928 begin 929 if not Field_Checking.Field_Present (New_Kind, F) then 930 if not Field_Is_Initial_Zero (Old_N, F) then 931 Write_Str (Old_Kind'Img); 932 Write_Str (" --> "); 933 Write_Str (New_Kind'Img); 934 Write_Str (" Nonzero field "); 935 Write_Str (F'Img); 936 Write_Str (" is vanishing for node "); 937 Write_Int (Nat (Old_N)); 938 Write_Eol; 939 940 raise Program_Error; 941 end if; 942 end if; 943 end; 944 end loop; 945 end Check_Vanishing_Fields; 946 947 procedure Check_Vanishing_Fields 948 (Old_N : Entity_Id; New_Kind : Entity_Kind) 949 is 950 Old_Kind : constant Entity_Kind := Ekind (Old_N); 951 952 -- If this fails, it means you need to call Reinit_Field_To_Zero before 953 -- calling Mutate_Ekind. But we have many cases where vanishing fields 954 -- are expected to reappear after converting to/from E_Void. Other cases 955 -- are more problematic; set a breakpoint on "(non-E_Void case)" below. 956 957 begin 958 for J in Entity_Field_Table (Old_Kind)'Range loop 959 declare 960 F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J); 961 begin 962 if not Field_Checking.Field_Present (New_Kind, F) then 963 if not Field_Is_Initial_Zero (Old_N, F) then 964 Write_Str (Old_Kind'Img); 965 Write_Str (" --> "); 966 Write_Str (New_Kind'Img); 967 Write_Str (" Nonzero field "); 968 Write_Str (F'Img); 969 Write_Str (" is vanishing for node "); 970 Write_Int (Nat (Old_N)); 971 Write_Eol; 972 973 if New_Kind = E_Void or else Old_Kind = E_Void then 974 Write_Line (" (E_Void case)"); 975 else 976 Write_Line (" (non-E_Void case)"); 977 end if; 978 end if; 979 end if; 980 end; 981 end loop; 982 end Check_Vanishing_Fields; 983 984 Nkind_Offset : constant Field_Offset := 985 Field_Descriptors (F_Nkind).Offset; 986 987 procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline; 988 989 procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is 990 pragma Assert (Field_Is_Initial_Zero (N, F_Nkind)); 991 begin 992 if Atree_Statistics_Enabled then 993 Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1; 994 end if; 995 996 Set_Node_Kind_Type (N, Nkind_Offset, Val); 997 end Init_Nkind; 998 999 procedure Mutate_Nkind 1000 (N : Node_Id; Val : Node_Kind; Old_Size : Slot_Count) 1001 is 1002 New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Val); 1003 1004 All_Node_Offsets : Node_Offsets.Table_Type renames 1005 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 1006 begin 1007 pragma Debug (Check_Vanishing_Fields (N, Val)); 1008 1009 -- Grow the slots if necessary 1010 1011 if Old_Size < New_Size then 1012 declare 1013 Old_Last_Slot : constant Node_Offset := Slots.Last; 1014 Old_Off_F : constant Node_Offset := Off_F (N); 1015 begin 1016 if Old_Last_Slot = Old_Off_F + Old_Size - 1 then 1017 -- In this case, the slots are at the end of Slots.Table, so we 1018 -- don't need to move them. 1019 Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size); 1020 1021 else 1022 -- Move the slots 1023 1024 declare 1025 New_Off_F : constant Node_Offset := Alloc_Slots (New_Size); 1026 begin 1027 All_Node_Offsets (N).Offset := New_Off_F - N_Head; 1028 Copy_Dynamic_Slots (Old_Off_F, New_Off_F, Old_Size); 1029 pragma Debug 1030 (Zero_Dynamic_Slots (Old_Off_F, Old_Off_F + Old_Size - 1)); 1031 end; 1032 end if; 1033 end; 1034 1035 Zero_Dynamic_Slots (Off_F (N) + Old_Size, Slots.Last); 1036 end if; 1037 1038 if Atree_Statistics_Enabled then 1039 Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1; 1040 end if; 1041 1042 Set_Node_Kind_Type (N, Nkind_Offset, Val); 1043 pragma Debug (Validate_Node_Write (N)); 1044 1045 New_Node_Debugging_Output (N); 1046 end Mutate_Nkind; 1047 1048 procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is 1049 begin 1050 Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N)); 1051 end Mutate_Nkind; 1052 1053 Ekind_Offset : constant Field_Offset := 1054 Field_Descriptors (F_Ekind).Offset; 1055 1056 procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind) 1057 with Inline; 1058 1059 procedure Mutate_Ekind 1060 (N : Entity_Id; Val : Entity_Kind) 1061 is 1062 begin 1063 if Ekind (N) = Val then 1064 return; 1065 end if; 1066 1067 if Debug_Flag_Underscore_V then 1068 pragma Debug (Check_Vanishing_Fields (N, Val)); 1069 end if; 1070 1071 -- For now, we are allocating all entities with the same size, so we 1072 -- don't need to reallocate slots here. 1073 1074 if Atree_Statistics_Enabled then 1075 Set_Count (F_Nkind) := Set_Count (F_Ekind) + 1; 1076 end if; 1077 1078 Set_Entity_Kind_Type (N, Ekind_Offset, Val); 1079 pragma Debug (Validate_Node_Write (N)); 1080 1081 New_Node_Debugging_Output (N); 1082 end Mutate_Ekind; 1083 1084 ----------------------- 1085 -- Allocate_New_Node -- 1086 ----------------------- 1087 1088 function Allocate_New_Node (Kind : Node_Kind) return Node_Id is 1089 begin 1090 return Result : constant Node_Id := Alloc_Node_Id do 1091 declare 1092 Sz : constant Slot_Count := Size_In_Slots_To_Alloc (Kind); 1093 Sl : constant Node_Offset := Alloc_Slots (Sz); 1094 begin 1095 Node_Offsets.Table (Result).Offset := Sl - N_Head; 1096 Zero_Dynamic_Slots (Sl, Sl + Sz - 1); 1097 Zero_Header_Slots (Result); 1098 end; 1099 1100 Init_Nkind (Result, Kind); 1101 1102 Orig_Nodes.Append (Result); 1103 Set_Comes_From_Source (Result, Comes_From_Source_Default); 1104 Allocate_List_Tables (Result); 1105 Report (Target => Result, Source => Empty); 1106 end return; 1107 end Allocate_New_Node; 1108 1109 -------------------------- 1110 -- Check_Error_Detected -- 1111 -------------------------- 1112 1113 procedure Check_Error_Detected is 1114 begin 1115 -- An anomaly has been detected which is assumed to be a consequence of 1116 -- a previous serious error or configurable run time violation. Raise 1117 -- an exception if no such error has been detected. 1118 1119 if Serious_Errors_Detected = 0 1120 and then Configurable_Run_Time_Violations = 0 1121 then 1122 raise Program_Error; 1123 end if; 1124 end Check_Error_Detected; 1125 1126 ----------------- 1127 -- Change_Node -- 1128 ----------------- 1129 1130 procedure Change_Node (N : Node_Id; New_Kind : Node_Kind) is 1131 pragma Debug (Validate_Node_Write (N)); 1132 pragma Assert (Nkind (N) not in N_Entity); 1133 pragma Assert (New_Kind not in N_Entity); 1134 1135 Old_Size : constant Slot_Count := Size_In_Slots_Dynamic (N); 1136 New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (New_Kind); 1137 1138 Save_Sloc : constant Source_Ptr := Sloc (N); 1139 Save_In_List : constant Boolean := In_List (N); 1140 Save_CFS : constant Boolean := Comes_From_Source (N); 1141 Save_Posted : constant Boolean := Error_Posted (N); 1142 Save_CA : constant Boolean := Check_Actuals (N); 1143 Save_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (N); 1144 Save_Link : constant Union_Id := Link (N); 1145 1146 Par_Count : Nat := 0; 1147 1148 begin 1149 if Nkind (N) in N_Subexpr then 1150 Par_Count := Paren_Count (N); 1151 end if; 1152 1153 if New_Size > Old_Size then 1154 declare 1155 New_Offset : constant Field_Offset := Alloc_Slots (New_Size); 1156 begin 1157 pragma Debug (Zero_Slots (N)); 1158 Node_Offsets.Table (N).Offset := New_Offset - N_Head; 1159 Zero_Dynamic_Slots (New_Offset, New_Offset + New_Size - 1); 1160 Zero_Header_Slots (N); 1161 end; 1162 1163 else 1164 Zero_Slots (N); 1165 end if; 1166 1167 Init_Nkind (N, New_Kind); -- Not Mutate, because of Zero_Slots above 1168 1169 Set_Sloc (N, Save_Sloc); 1170 Set_In_List (N, Save_In_List); 1171 Set_Comes_From_Source (N, Save_CFS); 1172 Set_Error_Posted (N, Save_Posted); 1173 Set_Check_Actuals (N, Save_CA); 1174 Set_Is_Ignored_Ghost_Node (N, Save_Is_IGN); 1175 Set_Link (N, Save_Link); 1176 1177 if New_Kind in N_Subexpr then 1178 Set_Paren_Count (N, Par_Count); 1179 end if; 1180 end Change_Node; 1181 1182 ---------------- 1183 -- Copy_Slots -- 1184 ---------------- 1185 1186 procedure Copy_Dynamic_Slots 1187 (From, To : Node_Offset; Num_Slots : Slot_Count) 1188 is 1189 pragma Assert (if Num_Slots /= 0 then From /= To); 1190 1191 All_Slots : Slots.Table_Type renames 1192 Slots.Table (Slots.First .. Slots.Last); 1193 1194 Source_Slots : Slots.Table_Type renames 1195 All_Slots (From .. From + Num_Slots - 1); 1196 1197 Destination_Slots : Slots.Table_Type renames 1198 All_Slots (To .. To + Num_Slots - 1); 1199 1200 begin 1201 Destination_Slots := Source_Slots; 1202 end Copy_Dynamic_Slots; 1203 1204 procedure Copy_Slots (Source, Destination : Node_Id) is 1205 pragma Debug (Validate_Node (Source)); 1206 pragma Assert (Source /= Destination); 1207 1208 S_Size : constant Slot_Count := Size_In_Slots_Dynamic (Source); 1209 1210 All_Node_Offsets : Node_Offsets.Table_Type renames 1211 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 1212 1213 begin 1214 Copy_Dynamic_Slots 1215 (Off_F (Source), Off_F (Destination), S_Size); 1216 All_Node_Offsets (Destination).Slots := All_Node_Offsets (Source).Slots; 1217 end Copy_Slots; 1218 1219 --------------- 1220 -- Copy_Node -- 1221 --------------- 1222 1223 procedure Copy_Node (Source, Destination : Node_Or_Entity_Id) is 1224 pragma Assert (Source /= Destination); 1225 1226 Save_In_List : constant Boolean := In_List (Destination); 1227 Save_Link : constant Union_Id := Link (Destination); 1228 1229 S_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Source); 1230 D_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Destination); 1231 1232 begin 1233 New_Node_Debugging_Output (Source); 1234 New_Node_Debugging_Output (Destination); 1235 1236 -- Currently all entities are allocated the same number of slots. 1237 -- Hopefully that won't always be the case, but if it is, the following 1238 -- is suboptimal if D_Size < S_Size, because in fact the Destination was 1239 -- allocated the max. 1240 1241 -- If Source doesn't fit in Destination, we need to allocate 1242 1243 if D_Size < S_Size then 1244 pragma Debug (Zero_Slots (Destination)); -- destroy old slots 1245 Node_Offsets.Table (Destination).Offset := 1246 Alloc_Slots (S_Size) - N_Head; 1247 end if; 1248 1249 Copy_Slots (Source, Destination); 1250 1251 Set_In_List (Destination, Save_In_List); 1252 Set_Link (Destination, Save_Link); 1253 Set_Paren_Count_Of_Copy (Target => Destination, Source => Source); 1254 end Copy_Node; 1255 1256 ------------------------ 1257 -- Copy_Separate_List -- 1258 ------------------------ 1259 1260 function Copy_Separate_List (Source : List_Id) return List_Id is 1261 Result : constant List_Id := New_List; 1262 Nod : Node_Id := First (Source); 1263 1264 begin 1265 while Present (Nod) loop 1266 Append (Copy_Separate_Tree (Nod), Result); 1267 Next (Nod); 1268 end loop; 1269 1270 return Result; 1271 end Copy_Separate_List; 1272 1273 ------------------------ 1274 -- Copy_Separate_Tree -- 1275 ------------------------ 1276 1277 function Copy_Separate_Tree (Source : Node_Id) return Node_Id is 1278 1279 pragma Debug (Validate_Node (Source)); 1280 1281 New_Id : Node_Id; 1282 1283 function Copy_Entity (E : Entity_Id) return Entity_Id; 1284 -- Copy Entity, copying only Chars field 1285 1286 function Copy_List (List : List_Id) return List_Id; 1287 -- Copy list 1288 1289 function Possible_Copy (Field : Union_Id) return Union_Id; 1290 -- Given a field, returns a copy of the node or list if its parent is 1291 -- the current source node, and otherwise returns the input. 1292 1293 ----------------- 1294 -- Copy_Entity -- 1295 ----------------- 1296 1297 function Copy_Entity (E : Entity_Id) return Entity_Id is 1298 begin 1299 pragma Assert (Nkind (E) in N_Entity); 1300 1301 return Result : constant Entity_Id := New_Entity (Nkind (E), Sloc (E)) 1302 do 1303 Set_Chars (Result, Chars (E)); 1304 end return; 1305 end Copy_Entity; 1306 1307 --------------- 1308 -- Copy_List -- 1309 --------------- 1310 1311 function Copy_List (List : List_Id) return List_Id is 1312 NL : List_Id; 1313 E : Node_Id; 1314 1315 begin 1316 if List = No_List then 1317 return No_List; 1318 1319 else 1320 NL := New_List; 1321 1322 E := First (List); 1323 while Present (E) loop 1324 if Is_Entity (E) then 1325 Append (Copy_Entity (E), NL); 1326 else 1327 Append (Copy_Separate_Tree (E), NL); 1328 end if; 1329 1330 Next (E); 1331 end loop; 1332 1333 return NL; 1334 end if; 1335 end Copy_List; 1336 1337 ------------------- 1338 -- Possible_Copy -- 1339 ------------------- 1340 1341 function Possible_Copy (Field : Union_Id) return Union_Id is 1342 New_N : Union_Id; 1343 1344 begin 1345 if Field in Node_Range then 1346 New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field))); 1347 1348 if Present (Node_Id (Field)) 1349 and then Parent (Node_Id (Field)) = Source 1350 then 1351 Set_Parent (Node_Id (New_N), New_Id); 1352 end if; 1353 1354 return New_N; 1355 1356 elsif Field in List_Range then 1357 New_N := Union_Id (Copy_List (List_Id (Field))); 1358 1359 if Parent (List_Id (Field)) = Source then 1360 Set_Parent (List_Id (New_N), New_Id); 1361 end if; 1362 1363 return New_N; 1364 1365 else 1366 return Field; 1367 end if; 1368 end Possible_Copy; 1369 1370 procedure Walk is new Walk_Sinfo_Fields_Pairwise (Possible_Copy); 1371 1372 -- Start of processing for Copy_Separate_Tree 1373 1374 begin 1375 if Source <= Empty_Or_Error then 1376 return Source; 1377 1378 elsif Is_Entity (Source) then 1379 return Copy_Entity (Source); 1380 1381 else 1382 New_Id := New_Copy (Source); 1383 1384 Walk (New_Id, Source); 1385 1386 -- Explicitly copy the aspect specifications as those do not reside 1387 -- in a node field. 1388 1389 if Permits_Aspect_Specifications (Source) 1390 and then Has_Aspects (Source) 1391 then 1392 Set_Aspect_Specifications 1393 (New_Id, Copy_List (Aspect_Specifications (Source))); 1394 end if; 1395 1396 -- Set Entity field to Empty to ensure that no entity references 1397 -- are shared between the two, if the source is already analyzed. 1398 1399 if Nkind (New_Id) in N_Has_Entity 1400 or else Nkind (New_Id) = N_Freeze_Entity 1401 then 1402 Set_Entity (New_Id, Empty); 1403 end if; 1404 1405 -- Reset all Etype fields and Analyzed flags, because input tree may 1406 -- have been fully or partially analyzed. 1407 1408 if Nkind (New_Id) in N_Has_Etype then 1409 Set_Etype (New_Id, Empty); 1410 end if; 1411 1412 Set_Analyzed (New_Id, False); 1413 1414 -- Rather special case, if we have an expanded name, then change 1415 -- it back into a selected component, so that the tree looks the 1416 -- way it did coming out of the parser. This will change back 1417 -- when we analyze the selected component node. 1418 1419 if Nkind (New_Id) = N_Expanded_Name then 1420 1421 -- The following code is a bit kludgy. It would be cleaner to 1422 -- Add an entry Change_Expanded_Name_To_Selected_Component to 1423 -- Sinfo.CN, but that's delicate because Atree is used in the 1424 -- binder, so we don't want to add that dependency. 1425 -- ??? Revisit now that ASIS is no longer using this unit. 1426 1427 -- Consequently we have no choice but to hold our noses and do the 1428 -- change manually. At least we are Atree, so this is at least all 1429 -- in the family. 1430 1431 -- Clear the Chars field which is not present in a selected 1432 -- component node, so we don't want a junk value around. Note that 1433 -- we can't just call Set_Chars, because Empty is of the wrong 1434 -- type, and is outside the range of Name_Id. 1435 1436 Reinit_Field_To_Zero (New_Id, F_Chars); 1437 Reinit_Field_To_Zero (New_Id, F_Has_Private_View); 1438 Reinit_Field_To_Zero (New_Id, F_Is_Elaboration_Checks_OK_Node); 1439 Reinit_Field_To_Zero (New_Id, F_Is_Elaboration_Warnings_OK_Node); 1440 Reinit_Field_To_Zero (New_Id, F_Is_SPARK_Mode_On_Node); 1441 1442 -- Change the node type 1443 1444 Mutate_Nkind (New_Id, N_Selected_Component); 1445 end if; 1446 1447 -- All done, return copied node 1448 1449 return New_Id; 1450 end if; 1451 end Copy_Separate_Tree; 1452 1453 ----------------------- 1454 -- Exchange_Entities -- 1455 ----------------------- 1456 1457 procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is 1458 pragma Debug (Validate_Node_Write (E1)); 1459 pragma Debug (Validate_Node_Write (E2)); 1460 pragma Assert 1461 (Is_Entity (E1) and then Is_Entity (E2) 1462 and then not In_List (E1) and then not In_List (E2)); 1463 1464 Old_E1 : constant Node_Header := Node_Offsets.Table (E1); 1465 1466 begin 1467 Node_Offsets.Table (E1) := Node_Offsets.Table (E2); 1468 Node_Offsets.Table (E2) := Old_E1; 1469 1470 -- That exchange exchanged the parent pointers as well, which is what 1471 -- we want, but we need to patch up the defining identifier pointers 1472 -- in the parent nodes (the child pointers) to match this switch 1473 -- unless for Implicit types entities which have no parent, in which 1474 -- case we don't do anything otherwise we won't be able to revert back 1475 -- to the original situation. 1476 1477 -- Shouldn't this use Is_Itype instead of the Parent test??? 1478 1479 if Present (Parent (E1)) and then Present (Parent (E2)) then 1480 Set_Defining_Identifier (Parent (E1), E1); 1481 Set_Defining_Identifier (Parent (E2), E2); 1482 end if; 1483 1484 New_Node_Debugging_Output (E1); 1485 New_Node_Debugging_Output (E2); 1486 end Exchange_Entities; 1487 1488 ----------------- 1489 -- Extend_Node -- 1490 ----------------- 1491 1492 procedure Extend_Node (Source : Node_Id) is 1493 pragma Assert (Present (Source)); 1494 pragma Assert (not Is_Entity (Source)); 1495 1496 Old_Kind : constant Node_Kind := Nkind (Source); 1497 pragma Assert (Old_Kind in N_Direct_Name); 1498 New_Kind : constant Node_Kind := 1499 (case Old_Kind is 1500 when N_Character_Literal => N_Defining_Character_Literal, 1501 when N_Identifier => N_Defining_Identifier, 1502 when N_Operator_Symbol => N_Defining_Operator_Symbol, 1503 when others => N_Unused_At_Start); -- can't happen 1504 -- The new NKind, which is the appropriate value of N_Entity based on 1505 -- the old Nkind. N_xxx is mapped to N_Defining_xxx. 1506 pragma Assert (New_Kind in N_Entity); 1507 1508 -- Start of processing for Extend_Node 1509 1510 begin 1511 Set_Check_Actuals (Source, False); 1512 Mutate_Nkind (Source, New_Kind); 1513 Report (Target => Source, Source => Source); 1514 end Extend_Node; 1515 1516 ----------------- 1517 -- Fix_Parents -- 1518 ----------------- 1519 1520 procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is 1521 pragma Assert (Nkind (Ref_Node) = Nkind (Fix_Node)); 1522 1523 procedure Fix_Parent (Field : Union_Id); 1524 -- Fix up one parent pointer. Field is checked to see if it points to 1525 -- a node, list, or element list that has a parent that points to 1526 -- Ref_Node. If so, the parent is reset to point to Fix_Node. 1527 1528 ---------------- 1529 -- Fix_Parent -- 1530 ---------------- 1531 1532 procedure Fix_Parent (Field : Union_Id) is 1533 begin 1534 -- Fix parent of node that is referenced by Field. Note that we must 1535 -- exclude the case where the node is a member of a list, because in 1536 -- this case the parent is the parent of the list. 1537 1538 if Field in Node_Range 1539 and then Present (Node_Id (Field)) 1540 and then not In_List (Node_Id (Field)) 1541 and then Parent (Node_Id (Field)) = Ref_Node 1542 then 1543 Set_Parent (Node_Id (Field), Fix_Node); 1544 1545 -- Fix parent of list that is referenced by Field 1546 1547 elsif Field in List_Range 1548 and then Present (List_Id (Field)) 1549 and then Parent (List_Id (Field)) = Ref_Node 1550 then 1551 Set_Parent (List_Id (Field), Fix_Node); 1552 end if; 1553 end Fix_Parent; 1554 1555 Fields : Node_Field_Array renames 1556 Node_Field_Table (Nkind (Fix_Node)).all; 1557 1558 -- Start of processing for Fix_Parents 1559 1560 begin 1561 for J in Fields'Range loop 1562 declare 1563 Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); 1564 begin 1565 if Desc.Kind in Node_Id_Field | List_Id_Field then 1566 Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset)); 1567 end if; 1568 end; 1569 end loop; 1570 end Fix_Parents; 1571 1572 ----------------------------------- 1573 -- Get_Comes_From_Source_Default -- 1574 ----------------------------------- 1575 1576 function Get_Comes_From_Source_Default return Boolean is 1577 begin 1578 return Comes_From_Source_Default; 1579 end Get_Comes_From_Source_Default; 1580 1581 --------------- 1582 -- Is_Entity -- 1583 --------------- 1584 1585 function Is_Entity (N : Node_Or_Entity_Id) return Boolean is 1586 begin 1587 return Nkind (N) in N_Entity; 1588 end Is_Entity; 1589 1590 ---------------- 1591 -- Initialize -- 1592 ---------------- 1593 1594 procedure Initialize is 1595 Dummy : Node_Id; 1596 pragma Warnings (Off, Dummy); 1597 1598 begin 1599 -- Allocate Empty node 1600 1601 Dummy := New_Node (N_Empty, No_Location); 1602 Set_Chars (Empty, No_Name); 1603 pragma Assert (Dummy = Empty); 1604 1605 -- Allocate Error node, and set Error_Posted, since we certainly 1606 -- only generate an Error node if we do post some kind of error. 1607 1608 Dummy := New_Node (N_Error, No_Location); 1609 Set_Chars (Error, Error_Name); 1610 Set_Error_Posted (Error, True); 1611 pragma Assert (Dummy = Error); 1612 end Initialize; 1613 1614 -------------------------- 1615 -- Is_Rewrite_Insertion -- 1616 -------------------------- 1617 1618 function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is 1619 begin 1620 return Rewrite_Ins (Node); 1621 end Is_Rewrite_Insertion; 1622 1623 ----------------------------- 1624 -- Is_Rewrite_Substitution -- 1625 ----------------------------- 1626 1627 function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is 1628 begin 1629 return Orig_Nodes.Table (Node) /= Node; 1630 end Is_Rewrite_Substitution; 1631 1632 ------------------ 1633 -- Last_Node_Id -- 1634 ------------------ 1635 1636 function Last_Node_Id return Node_Id is 1637 begin 1638 return Node_Offsets.Last; 1639 end Last_Node_Id; 1640 1641 ---------- 1642 -- Lock -- 1643 ---------- 1644 1645 procedure Lock is 1646 begin 1647 Orig_Nodes.Locked := True; 1648 end Lock; 1649 1650 ---------------- 1651 -- Lock_Nodes -- 1652 ---------------- 1653 1654 procedure Lock_Nodes is 1655 begin 1656 pragma Assert (not Locked); 1657 Locked := True; 1658 end Lock_Nodes; 1659 1660 ------------------------- 1661 -- Mark_New_Ghost_Node -- 1662 ------------------------- 1663 1664 procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id) is 1665 begin 1666 pragma Debug (Validate_Node_Write (N)); 1667 1668 -- The Ghost node is created within a Ghost region 1669 1670 if Ghost_Mode = Check then 1671 if Nkind (N) in N_Entity then 1672 Set_Is_Checked_Ghost_Entity (N); 1673 end if; 1674 1675 elsif Ghost_Mode = Ignore then 1676 if Nkind (N) in N_Entity then 1677 Set_Is_Ignored_Ghost_Entity (N); 1678 end if; 1679 1680 Set_Is_Ignored_Ghost_Node (N); 1681 1682 -- Record the ignored Ghost node or entity in order to eliminate it 1683 -- from the tree later. 1684 1685 if Ignored_Ghost_Recording_Proc /= null then 1686 Ignored_Ghost_Recording_Proc.all (N); 1687 end if; 1688 end if; 1689 end Mark_New_Ghost_Node; 1690 1691 ---------------------------- 1692 -- Mark_Rewrite_Insertion -- 1693 ---------------------------- 1694 1695 procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is 1696 begin 1697 Set_Rewrite_Ins (New_Node); 1698 end Mark_Rewrite_Insertion; 1699 1700 -------------- 1701 -- New_Copy -- 1702 -------------- 1703 1704 function New_Copy (Source : Node_Id) return Node_Id is 1705 pragma Debug (Validate_Node (Source)); 1706 S_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Source); 1707 begin 1708 if Source <= Empty_Or_Error then 1709 return Source; 1710 end if; 1711 1712 return New_Id : constant Node_Id := Alloc_Node_Id do 1713 Node_Offsets.Table (New_Id).Offset := 1714 Alloc_Slots (S_Size) - N_Head; 1715 Orig_Nodes.Append (New_Id); 1716 Copy_Slots (Source, New_Id); 1717 1718 Set_Check_Actuals (New_Id, False); 1719 Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source); 1720 1721 Allocate_List_Tables (New_Id); 1722 Report (Target => New_Id, Source => Source); 1723 1724 Set_In_List (New_Id, False); 1725 Set_Link (New_Id, Empty_List_Or_Node); 1726 1727 -- If the original is marked as a rewrite insertion, then unmark the 1728 -- copy, since we inserted the original, not the copy. 1729 1730 Set_Rewrite_Ins (New_Id, False); 1731 1732 -- Clear Is_Overloaded since we cannot have semantic interpretations 1733 -- of this new node. 1734 1735 if Nkind (Source) in N_Subexpr then 1736 Set_Is_Overloaded (New_Id, False); 1737 end if; 1738 1739 -- Always clear Has_Aspects, the caller must take care of copying 1740 -- aspects if this is required for the particular situation. 1741 1742 Set_Has_Aspects (New_Id, False); 1743 1744 -- Mark the copy as Ghost depending on the current Ghost region 1745 1746 Mark_New_Ghost_Node (New_Id); 1747 1748 New_Node_Debugging_Output (New_Id); 1749 1750 pragma Assert (New_Id /= Source); 1751 end return; 1752 end New_Copy; 1753 1754 ---------------- 1755 -- New_Entity -- 1756 ---------------- 1757 1758 function New_Entity 1759 (New_Node_Kind : Node_Kind; 1760 New_Sloc : Source_Ptr) return Entity_Id 1761 is 1762 pragma Assert (New_Node_Kind in N_Entity); 1763 New_Id : constant Entity_Id := Allocate_New_Node (New_Node_Kind); 1764 pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last); 1765 begin 1766 -- If this is a node with a real location and we are generating 1767 -- source nodes, then reset Current_Error_Node. This is useful 1768 -- if we bomb during parsing to get a error location for the bomb. 1769 1770 if New_Sloc > No_Location and then Comes_From_Source_Default then 1771 Current_Error_Node := New_Id; 1772 end if; 1773 1774 Set_Sloc (New_Id, New_Sloc); 1775 1776 -- Mark the new entity as Ghost depending on the current Ghost region 1777 1778 Mark_New_Ghost_Node (New_Id); 1779 1780 New_Node_Debugging_Output (New_Id); 1781 1782 return New_Id; 1783 end New_Entity; 1784 1785 -------------- 1786 -- New_Node -- 1787 -------------- 1788 1789 function New_Node 1790 (New_Node_Kind : Node_Kind; 1791 New_Sloc : Source_Ptr) return Node_Id 1792 is 1793 pragma Assert (New_Node_Kind not in N_Entity); 1794 New_Id : constant Node_Id := Allocate_New_Node (New_Node_Kind); 1795 pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last); 1796 begin 1797 Set_Sloc (New_Id, New_Sloc); 1798 1799 -- If this is a node with a real location and we are generating source 1800 -- nodes, then reset Current_Error_Node. This is useful if we bomb 1801 -- during parsing to get an error location for the bomb. 1802 1803 if Comes_From_Source_Default and then New_Sloc > No_Location then 1804 Current_Error_Node := New_Id; 1805 end if; 1806 1807 -- Mark the new node as Ghost depending on the current Ghost region 1808 1809 Mark_New_Ghost_Node (New_Id); 1810 1811 New_Node_Debugging_Output (New_Id); 1812 1813 return New_Id; 1814 end New_Node; 1815 1816 -------- 1817 -- No -- 1818 -------- 1819 1820 function No (N : Node_Id) return Boolean is 1821 begin 1822 return N = Empty; 1823 end No; 1824 1825 ------------------- 1826 -- Nodes_Address -- 1827 ------------------- 1828 1829 function Node_Offsets_Address return System.Address is 1830 begin 1831 return Node_Offsets.Table (First_Node_Id)'Address; 1832 end Node_Offsets_Address; 1833 1834 function Slots_Address return System.Address is 1835 Slot_Byte_Size : constant := 4; 1836 pragma Assert (Slot_Byte_Size * 8 = Slot'Size); 1837 Extra : constant := Slots_Low_Bound * Slot_Byte_Size; 1838 -- Slots does not start at 0, so we need to subtract off the extra 1839 -- amount. We are returning Slots.Table (0)'Address, except that 1840 -- that component does not exist. 1841 use System.Storage_Elements; 1842 begin 1843 return Slots.Table (Slots_Low_Bound)'Address - Extra; 1844 end Slots_Address; 1845 1846 ----------------------------------- 1847 -- Approx_Num_Nodes_And_Entities -- 1848 ----------------------------------- 1849 1850 function Approx_Num_Nodes_And_Entities return Nat is 1851 begin 1852 return Nat (Node_Offsets.Last - First_Node_Id); 1853 end Approx_Num_Nodes_And_Entities; 1854 1855 ----------- 1856 -- Off_0 -- 1857 ----------- 1858 1859 function Off_0 (N : Node_Id) return Node_Offset'Base is 1860 pragma Debug (Validate_Node (N)); 1861 1862 All_Node_Offsets : Node_Offsets.Table_Type renames 1863 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 1864 begin 1865 return All_Node_Offsets (N).Offset; 1866 end Off_0; 1867 1868 ----------- 1869 -- Off_F -- 1870 ----------- 1871 1872 function Off_F (N : Node_Id) return Node_Offset is 1873 begin 1874 return Off_0 (N) + N_Head; 1875 end Off_F; 1876 1877 ----------- 1878 -- Off_L -- 1879 ----------- 1880 1881 function Off_L (N : Node_Id) return Node_Offset is 1882 pragma Debug (Validate_Node (N)); 1883 1884 All_Node_Offsets : Node_Offsets.Table_Type renames 1885 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 1886 begin 1887 return All_Node_Offsets (N).Offset + Size_In_Slots (N) - 1; 1888 end Off_L; 1889 1890 ------------------- 1891 -- Original_Node -- 1892 ------------------- 1893 1894 function Original_Node (Node : Node_Id) return Node_Id is 1895 begin 1896 pragma Debug (Validate_Node (Node)); 1897 if Atree_Statistics_Enabled then 1898 Get_Original_Node_Count := Get_Original_Node_Count + 1; 1899 end if; 1900 1901 return Orig_Nodes.Table (Node); 1902 end Original_Node; 1903 1904 ----------------- 1905 -- Paren_Count -- 1906 ----------------- 1907 1908 function Paren_Count (N : Node_Id) return Nat is 1909 pragma Debug (Validate_Node (N)); 1910 1911 C : constant Small_Paren_Count_Type := Small_Paren_Count (N); 1912 1913 begin 1914 -- Value of 0,1,2 returned as is 1915 1916 if C <= 2 then 1917 return C; 1918 1919 -- Value of 3 means we search the table, and we must find an entry 1920 1921 else 1922 for J in Paren_Counts.First .. Paren_Counts.Last loop 1923 if N = Paren_Counts.Table (J).Nod then 1924 return Paren_Counts.Table (J).Count; 1925 end if; 1926 end loop; 1927 1928 raise Program_Error; 1929 end if; 1930 end Paren_Count; 1931 1932 function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is 1933 begin 1934 pragma Assert (Present (N)); 1935 1936 if Is_List_Member (N) then 1937 return Parent (List_Containing (N)); 1938 else 1939 return Node_Or_Entity_Id (Link (N)); 1940 end if; 1941 end Parent; 1942 1943 ------------- 1944 -- Present -- 1945 ------------- 1946 1947 function Present (N : Node_Id) return Boolean is 1948 begin 1949 return N /= Empty; 1950 end Present; 1951 1952 -------------------------------- 1953 -- Preserve_Comes_From_Source -- 1954 -------------------------------- 1955 1956 procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is 1957 begin 1958 Set_Comes_From_Source (NewN, Comes_From_Source (OldN)); 1959 end Preserve_Comes_From_Source; 1960 1961 ------------------- 1962 -- Relocate_Node -- 1963 ------------------- 1964 1965 function Relocate_Node (Source : Node_Id) return Node_Id is 1966 New_Node : Node_Id; 1967 1968 begin 1969 if No (Source) then 1970 return Empty; 1971 end if; 1972 1973 New_Node := New_Copy (Source); 1974 Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); 1975 1976 -- We now set the parent of the new node to be the same as the parent of 1977 -- the source. Almost always this parent will be replaced by a new value 1978 -- when the relocated node is reattached to the tree, but by doing it 1979 -- now, we ensure that this node is not even temporarily disconnected 1980 -- from the tree. Note that this does not happen free, because in the 1981 -- list case, the parent does not get set. 1982 1983 Set_Parent (New_Node, Parent (Source)); 1984 1985 -- If the node being relocated was a rewriting of some original node, 1986 -- then the relocated node has the same original node. 1987 1988 if Is_Rewrite_Substitution (Source) then 1989 Set_Original_Node (New_Node, Original_Node (Source)); 1990 end if; 1991 1992 -- If we're relocating a subprogram call and we're doing 1993 -- unnesting, be sure we make a new copy of any parameter associations 1994 -- so that we don't share them. 1995 1996 if Nkind (Source) in N_Subprogram_Call 1997 and then Opt.Unnest_Subprogram_Mode 1998 and then Present (Parameter_Associations (Source)) 1999 then 2000 declare 2001 New_Assoc : constant List_Id := Parameter_Associations (Source); 2002 begin 2003 Set_Parent (New_Assoc, New_Node); 2004 Set_Parameter_Associations (New_Node, New_Assoc); 2005 end; 2006 end if; 2007 2008 return New_Node; 2009 end Relocate_Node; 2010 2011 ------------- 2012 -- Replace -- 2013 ------------- 2014 2015 procedure Replace (Old_Node, New_Node : Node_Id) is 2016 Old_Post : constant Boolean := Error_Posted (Old_Node); 2017 Old_HasA : constant Boolean := Has_Aspects (Old_Node); 2018 Old_CFS : constant Boolean := Comes_From_Source (Old_Node); 2019 2020 procedure Destroy_New_Node; 2021 -- Overwrite New_Node data with junk, for debugging purposes 2022 2023 procedure Destroy_New_Node is 2024 begin 2025 Zero_Slots (New_Node); 2026 Node_Offsets.Table (New_Node).Offset := Field_Offset'Base'Last; 2027 end Destroy_New_Node; 2028 2029 begin 2030 New_Node_Debugging_Output (Old_Node); 2031 New_Node_Debugging_Output (New_Node); 2032 2033 pragma Assert 2034 (not Is_Entity (Old_Node) 2035 and not Is_Entity (New_Node) 2036 and not In_List (New_Node) 2037 and Old_Node /= New_Node); 2038 2039 -- Do copy, preserving link and in list status and required flags 2040 2041 Copy_Node (Source => New_Node, Destination => Old_Node); 2042 Set_Comes_From_Source (Old_Node, Old_CFS); 2043 Set_Error_Posted (Old_Node, Old_Post); 2044 Set_Has_Aspects (Old_Node, Old_HasA); 2045 2046 -- Fix parents of substituted node, since it has changed identity 2047 2048 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); 2049 2050 pragma Debug (Destroy_New_Node); 2051 2052 -- Since we are doing a replace, we assume that the original node 2053 -- is intended to become the new replaced node. The call would be 2054 -- to Rewrite if there were an intention to save the original node. 2055 2056 Set_Original_Node (Old_Node, Old_Node); 2057 2058 -- Invoke the reporting procedure (if available) 2059 2060 if Reporting_Proc /= null then 2061 Reporting_Proc.all (Target => Old_Node, Source => New_Node); 2062 end if; 2063 end Replace; 2064 2065 ------------ 2066 -- Report -- 2067 ------------ 2068 2069 procedure Report (Target, Source : Node_Id) is 2070 begin 2071 if Reporting_Proc /= null then 2072 Reporting_Proc.all (Target, Source); 2073 end if; 2074 end Report; 2075 2076 ------------- 2077 -- Rewrite -- 2078 ------------- 2079 2080 procedure Rewrite (Old_Node, New_Node : Node_Id) is 2081 Old_CA : constant Boolean := Check_Actuals (Old_Node); 2082 Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node); 2083 Old_Error_Posted : constant Boolean := 2084 Error_Posted (Old_Node); 2085 Old_Has_Aspects : constant Boolean := 2086 Has_Aspects (Old_Node); 2087 2088 Old_Must_Not_Freeze : constant Boolean := 2089 (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node) 2090 else False); 2091 Old_Paren_Count : constant Nat := 2092 (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0); 2093 -- These fields are preserved in the new node only if the new node and 2094 -- the old node are both subexpression nodes. We might be changing Nkind 2095 -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value 2096 -- (False/0) even if Old_Noed is not a N_Subexpr. 2097 2098 -- Note: it is a violation of abstraction levels for Must_Not_Freeze 2099 -- to be referenced like this. ??? 2100 2101 Sav_Node : Node_Id; 2102 2103 begin 2104 New_Node_Debugging_Output (Old_Node); 2105 New_Node_Debugging_Output (New_Node); 2106 2107 pragma Assert 2108 (not Is_Entity (Old_Node) 2109 and not Is_Entity (New_Node) 2110 and not In_List (New_Node)); 2111 2112 -- Allocate a new node, to be used to preserve the original contents 2113 -- of the Old_Node, for possible later retrival by Original_Node and 2114 -- make an entry in the Orig_Nodes table. This is only done if we have 2115 -- not already rewritten the node, as indicated by an Orig_Nodes entry 2116 -- that does not reference the Old_Node. 2117 2118 if Original_Node (Old_Node) = Old_Node then 2119 Sav_Node := New_Copy (Old_Node); 2120 Set_Original_Node (Sav_Node, Sav_Node); 2121 Set_Original_Node (Old_Node, Sav_Node); 2122 2123 -- Both the old and new copies of the node will share the same list 2124 -- of aspect specifications if aspect specifications are present. 2125 -- Restore the parent link of the aspect list to the old node, which 2126 -- is the one linked in the tree. 2127 2128 if Old_Has_Aspects then 2129 declare 2130 Aspects : constant List_Id := Aspect_Specifications (Old_Node); 2131 begin 2132 Set_Aspect_Specifications (Sav_Node, Aspects); 2133 Set_Parent (Aspects, Old_Node); 2134 end; 2135 end if; 2136 end if; 2137 2138 -- Copy substitute node into place, preserving old fields as required 2139 2140 Copy_Node (Source => New_Node, Destination => Old_Node); 2141 Set_Error_Posted (Old_Node, Old_Error_Posted); 2142 Set_Has_Aspects (Old_Node, Old_Has_Aspects); 2143 2144 Set_Check_Actuals (Old_Node, Old_CA); 2145 Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN); 2146 2147 if Nkind (New_Node) in N_Subexpr then 2148 Set_Paren_Count (Old_Node, Old_Paren_Count); 2149 Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); 2150 end if; 2151 2152 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); 2153 2154 -- Invoke the reporting procedure (if available) 2155 2156 if Reporting_Proc /= null then 2157 Reporting_Proc.all (Target => Old_Node, Source => New_Node); 2158 end if; 2159 2160 -- Invoke the rewriting procedure (if available) 2161 2162 if Rewriting_Proc /= null then 2163 Rewriting_Proc.all (Target => Old_Node, Source => New_Node); 2164 end if; 2165 end Rewrite; 2166 2167 ----------------------------------- 2168 -- Set_Comes_From_Source_Default -- 2169 ----------------------------------- 2170 2171 procedure Set_Comes_From_Source_Default (Default : Boolean) is 2172 begin 2173 Comes_From_Source_Default := Default; 2174 end Set_Comes_From_Source_Default; 2175 2176 -------------------------------------- 2177 -- Set_Ignored_Ghost_Recording_Proc -- 2178 -------------------------------------- 2179 2180 procedure Set_Ignored_Ghost_Recording_Proc 2181 (Proc : Ignored_Ghost_Record_Proc) 2182 is 2183 begin 2184 pragma Assert (Ignored_Ghost_Recording_Proc = null); 2185 Ignored_Ghost_Recording_Proc := Proc; 2186 end Set_Ignored_Ghost_Recording_Proc; 2187 2188 ----------------------- 2189 -- Set_Original_Node -- 2190 ----------------------- 2191 2192 procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is 2193 begin 2194 pragma Debug (Validate_Node_Write (N)); 2195 if Atree_Statistics_Enabled then 2196 Set_Original_Node_Count := Set_Original_Node_Count + 1; 2197 end if; 2198 2199 Orig_Nodes.Table (N) := Val; 2200 end Set_Original_Node; 2201 2202 --------------------- 2203 -- Set_Paren_Count -- 2204 --------------------- 2205 2206 procedure Set_Paren_Count (N : Node_Id; Val : Nat) is 2207 begin 2208 pragma Debug (Validate_Node_Write (N)); 2209 pragma Assert (Nkind (N) in N_Subexpr); 2210 2211 -- Value of 0,1,2 stored as is 2212 2213 if Val <= 2 then 2214 Set_Small_Paren_Count (N, Val); 2215 2216 -- Value of 3 or greater stores 3 in node and makes table entry 2217 2218 else 2219 Set_Small_Paren_Count (N, 3); 2220 2221 -- Search for existing table entry 2222 2223 for J in Paren_Counts.First .. Paren_Counts.Last loop 2224 if N = Paren_Counts.Table (J).Nod then 2225 Paren_Counts.Table (J).Count := Val; 2226 return; 2227 end if; 2228 end loop; 2229 2230 -- No existing table entry; make a new one 2231 2232 Paren_Counts.Append ((Nod => N, Count => Val)); 2233 end if; 2234 end Set_Paren_Count; 2235 2236 ----------------------------- 2237 -- Set_Paren_Count_Of_Copy -- 2238 ----------------------------- 2239 2240 procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is 2241 begin 2242 -- We already copied the Small_Paren_Count. We need to update the 2243 -- Paren_Counts table only if greater than 2. 2244 2245 if Nkind (Source) in N_Subexpr 2246 and then Small_Paren_Count (Source) = 3 2247 then 2248 Set_Paren_Count (Target, Paren_Count (Source)); 2249 end if; 2250 2251 pragma Assert (Paren_Count (Target) = Paren_Count (Source)); 2252 end Set_Paren_Count_Of_Copy; 2253 2254 ---------------- 2255 -- Set_Parent -- 2256 ---------------- 2257 2258 procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is 2259 begin 2260 pragma Assert (Present (N)); 2261 pragma Assert (not In_List (N)); 2262 Set_Link (N, Union_Id (Val)); 2263 end Set_Parent; 2264 2265 ------------------------ 2266 -- Set_Reporting_Proc -- 2267 ------------------------ 2268 2269 procedure Set_Reporting_Proc (Proc : Report_Proc) is 2270 begin 2271 pragma Assert (Reporting_Proc = null); 2272 Reporting_Proc := Proc; 2273 end Set_Reporting_Proc; 2274 2275 ------------------------ 2276 -- Set_Rewriting_Proc -- 2277 ------------------------ 2278 2279 procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is 2280 begin 2281 pragma Assert (Rewriting_Proc = null); 2282 Rewriting_Proc := Proc; 2283 end Set_Rewriting_Proc; 2284 2285 ---------------------------- 2286 -- Size_In_Slots_To_Alloc -- 2287 ---------------------------- 2288 2289 function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is 2290 begin 2291 return 2292 (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size 2293 else Sinfo.Nodes.Size (Kind)) - N_Head; 2294 -- Unfortunately, we don't know the Entity_Kind, so we have to use the 2295 -- max. 2296 end Size_In_Slots_To_Alloc; 2297 2298 function Size_In_Slots_To_Alloc 2299 (N : Node_Or_Entity_Id) return Slot_Count is 2300 begin 2301 return Size_In_Slots_To_Alloc (Nkind (N)); 2302 end Size_In_Slots_To_Alloc; 2303 2304 ------------------- 2305 -- Size_In_Slots -- 2306 ------------------- 2307 2308 function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is 2309 begin 2310 pragma Assert (Nkind (N) /= N_Unused_At_Start); 2311 return 2312 (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size 2313 else Sinfo.Nodes.Size (Nkind (N))); 2314 end Size_In_Slots; 2315 2316 --------------------------- 2317 -- Size_In_Slots_Dynamic -- 2318 --------------------------- 2319 2320 function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is 2321 begin 2322 return Size_In_Slots (N) - N_Head; 2323 end Size_In_Slots_Dynamic; 2324 2325 ------------------- 2326 -- Traverse_Func -- 2327 ------------------- 2328 2329 function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is 2330 pragma Debug (Validate_Node (Node)); 2331 2332 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result; 2333 -- Fld is one of the Traversed fields of Nod, which is necessarily a 2334 -- Node_Id or List_Id. It is traversed, and the result is the result of 2335 -- this traversal. 2336 2337 -------------------- 2338 -- Traverse_Field -- 2339 -------------------- 2340 2341 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is 2342 begin 2343 if Fld /= Union_Id (Empty) then 2344 2345 -- Descendant is a node 2346 2347 if Fld in Node_Range then 2348 return Traverse_Func (Node_Id (Fld)); 2349 2350 -- Descendant is a list 2351 2352 elsif Fld in List_Range then 2353 declare 2354 Elmt : Node_Id := First (List_Id (Fld)); 2355 begin 2356 while Present (Elmt) loop 2357 if Traverse_Func (Elmt) = Abandon then 2358 return Abandon; 2359 end if; 2360 2361 Next (Elmt); 2362 end loop; 2363 end; 2364 2365 else 2366 raise Program_Error; 2367 end if; 2368 end if; 2369 2370 return OK; 2371 end Traverse_Field; 2372 2373 Cur_Node : Node_Id := Node; 2374 2375 -- Start of processing for Traverse_Func 2376 2377 begin 2378 -- If the last field is a node, we eliminate the tail recursion by 2379 -- jumping back to this label. This is because concatenations are 2380 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the 2381 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the 2382 -- tail recursion is eliminated in that case. This trick prevents us 2383 -- from running out of stack memory in that case. We don't bother 2384 -- eliminating the tail recursion if the last field is a list. 2385 -- 2386 -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd 2387 -- getter, and note the offset of Left_Opnd. Then look in the spec of 2388 -- Sinfo.Nodes, look at the Traversed_Fields table, search for the 2389 -- N_Op_Concat component. The offset of Left_Opnd should be the last 2390 -- component before the No_Field_Offset sentinels.) 2391 2392 <<Tail_Recurse>> 2393 2394 case Process (Cur_Node) is 2395 when Abandon => 2396 return Abandon; 2397 2398 when Skip => 2399 return OK; 2400 2401 when OK => 2402 null; 2403 2404 when OK_Orig => 2405 Cur_Node := Original_Node (Cur_Node); 2406 end case; 2407 2408 -- Check for empty Traversed_Fields before entering loop below, so the 2409 -- tail recursive step won't go past the end. 2410 2411 declare 2412 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First; 2413 Offsets : Traversed_Offset_Array renames 2414 Traversed_Fields (Nkind (Cur_Node)); 2415 2416 begin 2417 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then 2418 while Offsets (Cur_Field + 1) /= No_Field_Offset loop 2419 declare 2420 F : constant Union_Id := 2421 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field)); 2422 2423 begin 2424 if Traverse_Field (F) = Abandon then 2425 return Abandon; 2426 end if; 2427 end; 2428 2429 Cur_Field := Cur_Field + 1; 2430 end loop; 2431 2432 declare 2433 F : constant Union_Id := 2434 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field)); 2435 2436 begin 2437 if F not in Node_Range then 2438 if Traverse_Field (F) = Abandon then 2439 return Abandon; 2440 end if; 2441 2442 elsif F /= Empty_List_Or_Node then 2443 -- Here is the tail recursion step, we reset Cur_Node and 2444 -- jump back to the start of the procedure, which has the 2445 -- same semantic effect as a call. 2446 2447 Cur_Node := Node_Id (F); 2448 goto Tail_Recurse; 2449 end if; 2450 end; 2451 end if; 2452 end; 2453 2454 return OK; 2455 end Traverse_Func; 2456 2457 ------------------- 2458 -- Traverse_Proc -- 2459 ------------------- 2460 2461 procedure Traverse_Proc (Node : Node_Id) is 2462 function Traverse is new Traverse_Func (Process); 2463 Discard : Traverse_Final_Result; 2464 pragma Warnings (Off, Discard); 2465 begin 2466 Discard := Traverse (Node); 2467 end Traverse_Proc; 2468 2469 ------------ 2470 -- Unlock -- 2471 ------------ 2472 2473 procedure Unlock is 2474 begin 2475 Orig_Nodes.Locked := False; 2476 end Unlock; 2477 2478 ------------------ 2479 -- Unlock_Nodes -- 2480 ------------------ 2481 2482 procedure Unlock_Nodes is 2483 begin 2484 pragma Assert (Locked); 2485 Locked := False; 2486 end Unlock_Nodes; 2487 2488 ---------------- 2489 -- Zero_Slots -- 2490 ---------------- 2491 2492 procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is 2493 begin 2494 Slots.Table (First .. Last) := (others => 0); 2495 end Zero_Dynamic_Slots; 2496 2497 procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is 2498 All_Node_Offsets : Node_Offsets.Table_Type renames 2499 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 2500 begin 2501 All_Node_Offsets (N).Slots := (others => 0); 2502 end Zero_Header_Slots; 2503 2504 procedure Zero_Slots (N : Node_Or_Entity_Id) is 2505 begin 2506 Zero_Dynamic_Slots (Off_F (N), Off_L (N)); 2507 Zero_Header_Slots (N); 2508 end Zero_Slots; 2509 2510 ---------------------- 2511 -- Print_Statistics -- 2512 ---------------------- 2513 2514 procedure Print_Node_Statistics; 2515 procedure Print_Field_Statistics; 2516 -- Helpers for Print_Statistics 2517 2518 procedure Write_Ratio (X : Nat_64; Y : Pos_64); 2519 -- Write the value of (X/Y) without using 'Image (approximately) 2520 2521 procedure Write_Ratio (X : Nat_64; Y : Pos_64) is 2522 pragma Assert (X <= Y); 2523 Ratio : constant Nat := Nat ((Long_Float (X) / Long_Float (Y)) * 1000.0); 2524 begin 2525 Write_Str (" ("); 2526 2527 if Ratio = 0 then 2528 Write_Str ("0.000"); 2529 elsif Ratio in 1 .. 9 then 2530 Write_Str ("0.00"); 2531 Write_Int (Ratio); 2532 elsif Ratio in 10 .. 99 then 2533 Write_Str ("0.0"); 2534 Write_Int (Ratio); 2535 elsif Ratio in 100 .. 999 then 2536 Write_Str ("0."); 2537 Write_Int (Ratio); 2538 else 2539 Write_Int (Ratio / 1000); 2540 end if; 2541 2542 Write_Str (")"); 2543 end Write_Ratio; 2544 2545 procedure Print_Node_Statistics is 2546 subtype Count is Nat_64; 2547 Node_Counts : array (Node_Kind) of Count := (others => 0); 2548 Entity_Counts : array (Entity_Kind) of Count := (others => 0); 2549 2550 All_Node_Offsets : Node_Offsets.Table_Type renames 2551 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); 2552 begin 2553 Write_Int (Int (Node_Offsets.Last)); 2554 Write_Line (" nodes (including entities)"); 2555 Write_Int (Int (Slots.Last)); 2556 Write_Line (" non-header slots"); 2557 2558 for N in All_Node_Offsets'Range loop 2559 declare 2560 K : constant Node_Kind := Nkind (N); 2561 2562 begin 2563 Node_Counts (K) := Node_Counts (K) + 1; 2564 2565 if K in N_Entity then 2566 Entity_Counts (Ekind (N)) := Entity_Counts (Ekind (N)) + 1; 2567 end if; 2568 end; 2569 end loop; 2570 2571 for K in Node_Kind loop 2572 declare 2573 Count : constant Nat_64 := Node_Counts (K); 2574 begin 2575 Write_Int_64 (Count); 2576 Write_Ratio (Count, Int_64 (Node_Offsets.Last)); 2577 Write_Str (" "); 2578 Write_Str (Node_Kind'Image (K)); 2579 Write_Str (" "); 2580 Write_Int (Int (Sinfo.Nodes.Size (K))); 2581 Write_Str (" slots"); 2582 Write_Eol; 2583 end; 2584 end loop; 2585 2586 for K in Entity_Kind loop 2587 declare 2588 Count : constant Nat_64 := Entity_Counts (K); 2589 begin 2590 Write_Int_64 (Count); 2591 Write_Ratio (Count, Int_64 (Node_Offsets.Last)); 2592 Write_Str (" "); 2593 Write_Str (Entity_Kind'Image (K)); 2594 Write_Str (" "); 2595 Write_Int (Int (Einfo.Entities.Size (K))); 2596 Write_Str (" slots"); 2597 Write_Eol; 2598 end; 2599 end loop; 2600 end Print_Node_Statistics; 2601 2602 procedure Print_Field_Statistics is 2603 Total, G_Total, S_Total : Call_Count := 0; 2604 begin 2605 Write_Int_64 (Get_Original_Node_Count); 2606 Write_Str (" + "); 2607 Write_Int_64 (Set_Original_Node_Count); 2608 Write_Eol; 2609 Write_Line (" Original_Node_Count getter and setter calls"); 2610 Write_Eol; 2611 2612 Write_Line ("Frequency of field getter and setter calls:"); 2613 2614 for Field in Node_Or_Entity_Field loop 2615 G_Total := G_Total + Get_Count (Field); 2616 S_Total := S_Total + Set_Count (Field); 2617 Total := G_Total + S_Total; 2618 end loop; 2619 2620 -- This assertion helps CodePeer understand that Total cannot be 0 (this 2621 -- is true because GNAT does not attempt to compile empty files). 2622 pragma Assert (Total > 0); 2623 2624 Write_Int_64 (Total); 2625 Write_Str (" (100%) = "); 2626 Write_Int_64 (G_Total); 2627 Write_Str (" + "); 2628 Write_Int_64 (S_Total); 2629 Write_Line (" total getter and setter calls"); 2630 2631 for Field in Node_Or_Entity_Field loop 2632 declare 2633 G : constant Call_Count := Get_Count (Field); 2634 S : constant Call_Count := Set_Count (Field); 2635 GS : constant Call_Count := G + S; 2636 2637 Desc : Field_Descriptor renames Field_Descriptors (Field); 2638 Slot : constant Field_Offset := 2639 (Field_Size (Desc.Kind) * Desc.Offset) / Slot_Size; 2640 2641 begin 2642 Write_Int_64 (GS); 2643 Write_Ratio (GS, Total); 2644 Write_Str (" = "); 2645 Write_Int_64 (G); 2646 Write_Str (" + "); 2647 Write_Int_64 (S); 2648 Write_Str (" "); 2649 Write_Str (Node_Or_Entity_Field'Image (Field)); 2650 Write_Str (" in slot "); 2651 Write_Int (Int (Slot)); 2652 Write_Str (" size "); 2653 Write_Int (Int (Field_Size (Desc.Kind))); 2654 Write_Eol; 2655 end; 2656 end loop; 2657 end Print_Field_Statistics; 2658 2659 procedure Print_Statistics is 2660 begin 2661 Write_Eol; 2662 Write_Eol; 2663 Print_Node_Statistics; 2664 Print_Field_Statistics; 2665 end Print_Statistics; 2666 2667end Atree; 2668