1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E L A B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Expander; use Expander; 36with Lib; use Lib; 37with Lib.Load; use Lib.Load; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Output; use Output; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Cat; use Sem_Cat; 49with Sem_Ch7; use Sem_Ch7; 50with Sem_Ch8; use Sem_Ch8; 51with Sem_Prag; use Sem_Prag; 52with Sem_Util; use Sem_Util; 53with Sinfo; use Sinfo; 54with Sinput; use Sinput; 55with Snames; use Snames; 56with Stand; use Stand; 57with Table; 58with Tbuild; use Tbuild; 59with Uintp; use Uintp; 60with Uname; use Uname; 61 62with GNAT.HTable; use GNAT.HTable; 63 64package body Sem_Elab is 65 66 ----------------------------------------- 67 -- Access-before-elaboration mechanism -- 68 ----------------------------------------- 69 70 -- The access-before-elaboration (ABE) mechanism implemented in this unit 71 -- has the following objectives: 72 -- 73 -- * Diagnose at compile-time or install run-time checks to prevent ABE 74 -- access to data and behaviour. 75 -- 76 -- The high-level idea is to accurately diagnose ABE issues within a 77 -- single unit because the ABE mechanism can inspect the whole unit. 78 -- As soon as the elaboration graph extends to an external unit, the 79 -- diagnostics stop because the body of the unit may not be available. 80 -- Due to control and data flow, the ABE mechanism cannot accurately 81 -- determine whether a particular scenario will be elaborated or not. 82 -- Conditional ABE checks are therefore used to verify the elaboration 83 -- status of a local and external target at run time. 84 -- 85 -- * Supply elaboration dependencies for a unit to binde 86 -- 87 -- The ABE mechanism registers each outgoing elaboration edge for the 88 -- main unit in its ALI file. GNATbind and binde can then reconstruct 89 -- the full elaboration graph and determine the proper elaboration 90 -- order for all units in the compilation. 91 -- 92 -- The ABE mechanism supports three models of elaboration: 93 -- 94 -- * Dynamic model - This is the most permissive of the three models. 95 -- When the dynamic model is in effect, the mechanism performs very 96 -- little diagnostics and generates run-time checks to detect ABE 97 -- issues. The behaviour of this model is identical to that specified 98 -- by the Ada RM. This model is enabled with switch -gnatE. 99 -- 100 -- * Static model - This is the middle ground of the three models. When 101 -- the static model is in effect, the mechanism diagnoses and installs 102 -- run-time checks to detect ABE issues in the main unit. In addition, 103 -- the mechanism generates implicit Elaborate or Elaborate_All pragmas 104 -- to ensure the prior elaboration of withed units. The model employs 105 -- textual order, with clause context, and elaboration-related source 106 -- pragmas. This is the default model. 107 -- 108 -- * SPARK model - This is the most conservative of the three models and 109 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model 110 -- is in effect only when a context resides in a SPARK_Mode On region, 111 -- otherwise the mechanism falls back to one of the previous models. 112 -- 113 -- The ABE mechanism consists of a "recording" phase and a "processing" 114 -- phase. 115 116 ----------------- 117 -- Terminology -- 118 ----------------- 119 120 -- * ABE - An attempt to activate, call, or instantiate a scenario which 121 -- has not been fully elaborated. 122 -- 123 -- * Bridge target - A type of target. A bridge target is a link between 124 -- scenarios. It is usually a byproduct of expansion and does not have 125 -- any direct ABE ramifications. 126 -- 127 -- * Call marker - A special node used to indicate the presence of a call 128 -- in the tree in case expansion transforms or eliminates the original 129 -- call. N_Call_Marker nodes do not have static and run-time semantics. 130 -- 131 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the 132 -- elaboration or invocation of a target by a scenario within the main 133 -- unit causes an ABE, but does not cause an ABE for another scenarios 134 -- within the main unit. 135 -- 136 -- * Declaration level - A type of enclosing level. A scenario or target is 137 -- at the declaration level when it appears within the declarations of a 138 -- block statement, entry body, subprogram body, or task body, ignoring 139 -- enclosing packages. 140 -- 141 -- * Early call region - A section of code which ends at a subprogram body 142 -- and starts from the nearest non-preelaborable construct which precedes 143 -- the subprogram body. The early call region extends from a package body 144 -- to a package spec when the spec carries pragma Elaborate_Body. 145 -- 146 -- * Generic library level - A type of enclosing level. A scenario or 147 -- target is at the generic library level if it appears in a generic 148 -- package library unit, ignoring enclosing packages. 149 -- 150 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the 151 -- elaboration or invocation of a target by all scenarios within the 152 -- main unit causes an ABE. 153 -- 154 -- * Instantiation library level - A type of enclosing level. A scenario 155 -- or target is at the instantiation library level if it appears in an 156 -- instantiation library unit, ignoring enclosing packages. 157 -- 158 -- * Library level - A type of enclosing level. A scenario or target is at 159 -- the library level if it appears in a package library unit, ignoring 160 -- enclosng packages. 161 -- 162 -- * Non-library-level encapsulator - A construct that cannot be elaborated 163 -- on its own and requires elaboration by a top-level scenario. 164 -- 165 -- * Scenario - A construct or context which may be elaborated or executed 166 -- by elaboration code. The scenarios recognized by the ABE mechanism are 167 -- as follows: 168 -- 169 -- - '[Unrestricted_]Access of entries, operators, and subprograms 170 -- 171 -- - Assignments to variables 172 -- 173 -- - Calls to entries, operators, and subprograms 174 -- 175 -- - Derived type declarations 176 -- 177 -- - Instantiations 178 -- 179 -- - Pragma Refined_State 180 -- 181 -- - Reads of variables 182 -- 183 -- - Task activation 184 -- 185 -- * Target - A construct referenced by a scenario. The targets recognized 186 -- by the ABE mechanism are as follows: 187 -- 188 -- - For '[Unrestricted_]Access of entries, operators, and subprograms, 189 -- the target is the entry, operator, or subprogram. 190 -- 191 -- - For assignments to variables, the target is the variable 192 -- 193 -- - For calls, the target is the entry, operator, or subprogram 194 -- 195 -- - For derived type declarations, the target is the derived type 196 -- 197 -- - For instantiations, the target is the generic template 198 -- 199 -- - For pragma Refined_State, the targets are the constituents 200 -- 201 -- - For reads of variables, the target is the variable 202 -- 203 -- - For task activation, the target is the task body 204 -- 205 -- * Top-level scenario - A scenario which appears in a non-generic main 206 -- unit. Depending on the elaboration model is in effect, the following 207 -- addotional restrictions apply: 208 -- 209 -- - Dynamic model - No restrictions 210 -- 211 -- - SPARK model - Falls back to either the dynamic or static model 212 -- 213 -- - Static model - The scenario must be at the library level 214 215 --------------------- 216 -- Recording phase -- 217 --------------------- 218 219 -- The Recording phase coincides with the analysis/resolution phase of the 220 -- compiler. It has the following objectives: 221 -- 222 -- * Record all top-level scenarios for examination by the Processing 223 -- phase. 224 -- 225 -- Saving only a certain number of nodes improves the performance of 226 -- the ABE mechanism. This eliminates the need to examine the whole 227 -- tree in a separate pass. 228 -- 229 -- * Record certain SPARK scenarios which are not necessarily executable 230 -- during elaboration, but still require elaboration-related checks. 231 -- 232 -- Saving only a certain number of nodes improves the performance of 233 -- the ABE mechanism. This eliminates the need to examine the whole 234 -- tree in a separate pass. 235 -- 236 -- * Detect and diagnose calls in preelaborable or pure units, including 237 -- generic bodies. 238 -- 239 -- This diagnostic is carried out during the Recording phase because it 240 -- does not need the heavy recursive traversal done by the Processing 241 -- phase. 242 -- 243 -- * Detect and diagnose guaranteed ABEs caused by instantiations, 244 -- calls, and task activation. 245 -- 246 -- The issues detected by the ABE mechanism are reported as warnings 247 -- because they do not violate Ada semantics. Forward instantiations 248 -- may thus reach gigi, however gigi cannot handle certain kinds of 249 -- premature instantiations and may crash. To avoid this limitation, 250 -- the ABE mechanism must identify forward instantiations as early as 251 -- possible and suppress their bodies. Calls and task activations are 252 -- included in this category for completeness. 253 254 ---------------------- 255 -- Processing phase -- 256 ---------------------- 257 258 -- The Processing phase is a separate pass which starts after instantiating 259 -- and/or inlining of bodies, but before the removal of Ghost code. It has 260 -- the following objectives: 261 -- 262 -- * Examine all top-level scenarios saved during the Recording phase 263 -- 264 -- The top-level scenarios act as roots for depth-first traversal of 265 -- the call/instantiation/task activation graph. The traversal stops 266 -- when an outgoing edge leaves the main unit. 267 -- 268 -- * Examine all SPARK scenarios saved during the Recording phase 269 -- 270 -- * Depending on the elaboration model in effect, perform the following 271 -- actions: 272 -- 273 -- - Dynamic model - Install run-time conditional ABE checks. 274 -- 275 -- - SPARK model - Enforce the SPARK elaboration rules 276 -- 277 -- - Static model - Diagnose conditional ABEs, install run-time 278 -- conditional ABE checks, and guarantee the elaboration of 279 -- external units. 280 -- 281 -- * Examine nested scenarios 282 -- 283 -- Nested scenarios discovered during the depth-first traversal are 284 -- in turn subjected to the same actions outlined above and examined 285 -- for the next level of nested scenarios. 286 287 ------------------ 288 -- Architecture -- 289 ------------------ 290 291 -- Analysis/Resolution 292 -- | 293 -- +- Build_Call_Marker 294 -- | 295 -- +- Build_Variable_Reference_Marker 296 -- | 297 -- +- | -------------------- Recording phase ---------------------------+ 298 -- | v | 299 -- | Record_Elaboration_Scenario | 300 -- | | | 301 -- | +--> Check_Preelaborated_Call | 302 -- | | | 303 -- | +--> Process_Guaranteed_ABE | 304 -- | | | | 305 -- | | +--> Process_Guaranteed_ABE_Activation | 306 -- | | | | 307 -- | | +--> Process_Guaranteed_ABE_Call | 308 -- | | | | 309 -- | | +--> Process_Guaranteed_ABE_Instantiation | 310 -- | | | 311 -- +- | ----------------------------------------------------------------+ 312 -- | 313 -- | 314 -- +--> SPARK_Scenarios 315 -- | +-----------+-----------+ .. +-----------+ 316 -- | | Scenario1 | Scenario2 | .. | ScenarioN | 317 -- | +-----------+-----------+ .. +-----------+ 318 -- | 319 -- +--> Top_Level_Scenarios 320 -- | +-----------+-----------+ .. +-----------+ 321 -- | | Scenario1 | Scenario2 | .. | ScenarioN | 322 -- | +-----------+-----------+ .. +-----------+ 323 -- | 324 -- End of Compilation 325 -- | 326 -- +- | --------------------- Processing phase -------------------------+ 327 -- | v | 328 -- | Check_Elaboration_Scenarios | 329 -- | | | 330 -- | +--> Check_SPARK_Scenario | 331 -- | | | | 332 -- | | +--> Check_SPARK_Derived_Type | 333 -- | | | | 334 -- | | +--> Check_SPARK_Instantiation | 335 -- | | | | 336 -- | | +--> Check_SPARK_Refined_State_Pragma | 337 -- | | | 338 -- | +--> Process_Conditional_ABE <---------------------------+ | 339 -- | | | | 340 -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario | 341 -- | | ^ | 342 -- | +--> Process_Conditional_ABE_Activation | | 343 -- | | | | | 344 -- | | +-----------------------------+ | | 345 -- | | | | | 346 -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body | 347 -- | | | | | 348 -- | | +-----------------------------+ | 349 -- | | | 350 -- | +--> Process_Conditional_ABE_Instantiation | 351 -- | | | 352 -- | +--> Process_Conditional_ABE_Variable_Assignment | 353 -- | | | 354 -- | +--> Process_Conditional_ABE_Variable_Reference | 355 -- | | 356 -- +--------------------------------------------------------------------+ 357 358 ---------------------- 359 -- Important points -- 360 ---------------------- 361 362 -- The Processing phase starts after the analysis, resolution, expansion 363 -- phase has completed. As a result, no current semantic information is 364 -- available. The scope stack is empty, global flags such as In_Instance 365 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism 366 -- must either save or recompute semantic information. 367 368 -- Expansion heavily transforms calls and to some extent instantiations. To 369 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to 370 -- capture the target and relevant attributes of the original call. 371 372 -- The diagnostics of the ABE mechanism depend on accurate source locations 373 -- to determine the spacial relation of nodes. 374 375 ----------------------------------------- 376 -- Suppression of elaboration warnings -- 377 ----------------------------------------- 378 379 -- Elaboration warnings along multiple traversal paths rooted at a scenario 380 -- are suppressed when the scenario has elaboration warnings suppressed. 381 -- 382 -- Root scenario 383 -- | 384 -- +-- Child scenario 1 385 -- | | 386 -- | +-- Grandchild scenario 1 387 -- | | 388 -- | +-- Grandchild scenario N 389 -- | 390 -- +-- Child scenario N 391 -- 392 -- If the root scenario has elaboration warnings suppressed, then all its 393 -- child, grandchild, etc. scenarios will have their elaboration warnings 394 -- suppressed. 395 -- 396 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress 397 -- elaboration-related warnings when used in the following manner: 398 -- 399 -- pragma Warnings ("L"); 400 -- <scenario-or-target> 401 -- 402 -- <target> 403 -- pragma Warnings (Off, target); 404 -- 405 -- pragma Warnings (Off); 406 -- <scenario-or-target> 407 -- 408 -- * To suppress elaboration warnings for '[Unrestricted_]Access of 409 -- entries, operators, and subprograms, either: 410 -- 411 -- - Suppress the entry, operator, or subprogram, or 412 -- - Suppress the attribute, or 413 -- - Use switch -gnatw.f 414 -- 415 -- * To suppress elaboration warnings for calls to entries, operators, 416 -- and subprograms, either: 417 -- 418 -- - Suppress the entry, operator, or subprogram, or 419 -- - Suppress the call 420 -- 421 -- * To suppress elaboration warnings for instantiations, suppress the 422 -- instantiation. 423 -- 424 -- * To suppress elaboration warnings for task activations, either: 425 -- 426 -- - Suppress the task object, or 427 -- - Suppress the task type, or 428 -- - Suppress the activation call 429 430 -------------- 431 -- Switches -- 432 -------------- 433 434 -- The following switches may be used to control the behavior of the ABE 435 -- mechanism. 436 -- 437 -- -gnatd_a stop elaboration checks on accept or select statement 438 -- 439 -- The ABE mechanism stops the traversal of a task body when it 440 -- encounters an accept or a select statement. This behavior is 441 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 442 -- but without penalizing actual entry calls during elaboration. 443 -- 444 -- -gnatd_e ignore entry calls and requeue statements for elaboration 445 -- 446 -- The ABE mechanism does not generate N_Call_Marker nodes for 447 -- protected or task entry calls as well as requeue statements. 448 -- As a result, the calls and requeues are not recorded or 449 -- processed. 450 -- 451 -- -gnatdE elaboration checks on predefined units 452 -- 453 -- The ABE mechanism considers scenarios which appear in internal 454 -- units (Ada, GNAT, Interfaces, System). 455 -- 456 -- -gnatd.G ignore calls through generic formal parameters for elaboration 457 -- 458 -- The ABE mechanism does not generate N_Call_Marker nodes for 459 -- calls which occur in expanded instances, and invoke generic 460 -- actual subprograms through generic formal subprograms. As a 461 -- result, the calls are not recorded or processed. 462 -- 463 -- -gnatd_i ignore activations and calls to instances for elaboration 464 -- 465 -- The ABE mechanism ignores calls and task activations when they 466 -- target a subprogram or task type defined an external instance. 467 -- As a result, the calls and task activations are not processed. 468 -- 469 -- -gnatdL ignore external calls from instances for elaboration 470 -- 471 -- The ABE mechanism does not generate N_Call_Marker nodes for 472 -- calls which occur in expanded instances, do not invoke generic 473 -- actual subprograms through formal subprograms, and the target 474 -- is external to the instance. As a result, the calls are not 475 -- recorded or processed. 476 -- 477 -- -gnatd.o conservative elaboration order for indirect calls 478 -- 479 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 480 -- operator, or subprogram as an immediate invocation of the 481 -- target. As a result, it performs ABE checks and diagnostics on 482 -- the immediate call. 483 -- 484 -- -gnatd_p ignore assertion pragmas for elaboration 485 -- 486 -- The ABE mechanism does not generate N_Call_Marker nodes for 487 -- calls to subprograms which verify the run-time semantics of 488 -- the following assertion pragmas: 489 -- 490 -- Default_Initial_Condition 491 -- Initial_Condition 492 -- Invariant 493 -- Invariant'Class 494 -- Post 495 -- Post'Class 496 -- Postcondition 497 -- Type_Invariant 498 -- Type_Invariant_Class 499 -- 500 -- As a result, the assertion expressions of the pragmas are not 501 -- processed. 502 -- 503 -- -gnatd_s stop elaboration checks on synchronous suspension 504 -- 505 -- The ABE mechanism stops the traversal of a task body when it 506 -- encounters a call to one of the following routines: 507 -- 508 -- Ada.Synchronous_Barriers.Wait_For_Release 509 -- Ada.Synchronous_Task_Control.Suspend_Until_True 510 -- 511 -- -gnatd.U ignore indirect calls for static elaboration 512 -- 513 -- The ABE mechanism does not consider '[Unrestricted_]Access of 514 -- entries, operators, and subprograms. As a result, the scenarios 515 -- are not recorder or processed. 516 -- 517 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 518 -- 519 -- The ABE mechanism applies some of the SPARK elaboration rules 520 -- defined in the SPARK reference manual, chapter 7.7. Note that 521 -- certain rules are always enforced, regardless of whether the 522 -- switch is active. 523 -- 524 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 525 -- 526 -- The ABE mechanism does not generate implicit Elaborate_All when 527 -- the need for the pragma came from a task body. 528 -- 529 -- -gnatE dynamic elaboration checking mode enabled 530 -- 531 -- The ABE mechanism assumes that any scenario is elaborated or 532 -- invoked by elaboration code. The ABE mechanism performs very 533 -- little diagnostics and generates condintional ABE checks to 534 -- detect ABE issues at run-time. 535 -- 536 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 537 -- 538 -- The ABE mechanism produces information messages on generated 539 -- implicit Elabote[_All] pragmas along with traceback showing 540 -- why the pragma was generated. In addition, the ABE mechanism 541 -- produces information messages for each scenario elaborated or 542 -- invoked by elaboration code. 543 -- 544 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 545 -- 546 -- The complementary switch for -gnatel. 547 -- 548 -- -gnatH legacy elaboration checking mode enabled 549 -- 550 -- When this switch is in effect, the pre-18.x ABE model becomes 551 -- the defacto ABE model. This ammounts to cutting off all entry 552 -- points into the new ABE mechanism, and giving full control to 553 -- the old ABE mechanism. 554 -- 555 -- -gnatJ permissive elaboration checking mode enabled 556 -- 557 -- This switch activates the following switches: 558 -- 559 -- -gnatd_a 560 -- -gnatd_e 561 -- -gnatd.G 562 -- -gnatd_i 563 -- -gnatdL 564 -- -gnatd_p 565 -- -gnatd_s 566 -- -gnatd.U 567 -- -gnatd.y 568 -- 569 -- IMPORTANT: The behavior of the ABE mechanism becomes more 570 -- permissive at the cost of accurate diagnostics and runtime 571 -- ABE checks. 572 -- 573 -- -gnatw.f turn on warnings for suspicious Subp'Access 574 -- 575 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 576 -- operator, or subprogram as a pseudo invocation of the target. 577 -- As a result, it performs ABE diagnostics on the pseudo call. 578 -- 579 -- -gnatw.F turn off warnings for suspicious Subp'Access 580 -- 581 -- The complementary switch for -gnatw.f. 582 -- 583 -- -gnatwl turn on warnings for elaboration problems 584 -- 585 -- The ABE mechanism produces warnings on detected ABEs along with 586 -- a traceback showing the graph of the ABE. 587 -- 588 -- -gnatwL turn off warnings for elaboration problems 589 -- 590 -- The complementary switch for -gnatwl. 591 592 --------------------------- 593 -- Adding a new scenario -- 594 --------------------------- 595 596 -- The following steps describe how to add a new elaboration scenario and 597 -- preserve the existing architecture. Note that not all of the steps may 598 -- need to be carried out. 599 -- 600 -- 1) Update predicate Is_Scenario 601 -- 602 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate 603 -- Is_Suitable_Scenario. 604 -- 605 -- 3) Update routine Record_Elaboration_Scenario 606 -- 607 -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in 608 -- routine Process_Conditional_ABE. 609 -- 610 -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in 611 -- routine Process_Guaranteed_ABE. 612 -- 613 -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine 614 -- Check_SPARK_Scenario. 615 -- 616 -- 7) Add routine Info_xxx. Include a call to it in routine 617 -- Process_Conditional_ABE_xxx. 618 -- 619 -- 8) Add routine Output_xxx. Include a call to it in routine 620 -- Output_Active_Scenarios. 621 -- 622 -- 9) Add routine Extract_xxx_Attributes 623 -- 624 -- 10) Update routine Is_Potential_Scenario 625 626 ------------------------- 627 -- Adding a new target -- 628 ------------------------- 629 630 -- The following steps describe how to add a new elaboration target and 631 -- preserve the existing architecture. Note that not all of the steps may 632 -- need to be carried out. 633 -- 634 -- 1) Add predicate Is_xxx. 635 -- 636 -- 2) Update the following predicates 637 -- 638 -- Is_Ada_Semantic_Target 639 -- Is_Assertion_Pragma_Target 640 -- Is_Bridge_Target 641 -- Is_SPARK_Semantic_Target 642 -- 643 -- If necessary, create a new category. 644 -- 645 -- 3) Update the appropriate Info_xxx routine. 646 -- 647 -- 4) Update the appropriate Output_xxx routine. 648 -- 649 -- 5) Update routine Extract_Target_Attributes. If necessary, create a 650 -- new Extract_xxx routine. 651 652 -------------------------- 653 -- Debugging ABE issues -- 654 -------------------------- 655 656 -- * If the issue involves a call, ensure that the call is eligible for ABE 657 -- processing and receives a corresponding call marker. The routines of 658 -- interest are 659 -- 660 -- Build_Call_Marker 661 -- Record_Elaboration_Scenario 662 663 -- * If the issue involves an arbitrary scenario, ensure that the scenario 664 -- is either recorded, or is successfully recognized while traversing a 665 -- body. The routines of interest are 666 -- 667 -- Record_Elaboration_Scenario 668 -- Process_Conditional_ABE 669 -- Process_Guaranteed_ABE 670 -- Traverse_Body 671 672 -- * If the issue involves a circularity in the elaboration order, examine 673 -- the ALI files and look for the following encodings next to units: 674 -- 675 -- E indicates a source Elaborate 676 -- 677 -- EA indicates a source Elaborate_All 678 -- 679 -- AD indicates an implicit Elaborate_All 680 -- 681 -- ED indicates an implicit Elaborate 682 -- 683 -- If possible, compare these encodings with those generated by the old 684 -- ABE mechanism. The routines of interest are 685 -- 686 -- Ensure_Prior_Elaboration 687 688 ---------------- 689 -- Attributes -- 690 ---------------- 691 692 -- To minimize the amount of code within routines, the ABE mechanism relies 693 -- on "attribute" records to capture relevant information for a scenario or 694 -- a target. 695 696 -- The following type captures relevant attributes which pertain to a call 697 698 type Call_Attributes is record 699 Elab_Checks_OK : Boolean; 700 -- This flag is set when the call has elaboration checks enabled 701 702 Elab_Warnings_OK : Boolean; 703 -- This flag is set when the call has elaboration warnings elabled 704 705 From_Source : Boolean; 706 -- This flag is set when the call comes from source 707 708 Ghost_Mode_Ignore : Boolean; 709 -- This flag is set when the call appears in a region subject to pragma 710 -- Ghost with policy Ignore. 711 712 In_Declarations : Boolean; 713 -- This flag is set when the call appears at the declaration level 714 715 Is_Dispatching : Boolean; 716 -- This flag is set when the call is dispatching 717 718 SPARK_Mode_On : Boolean; 719 -- This flag is set when the call appears in a region subject to pragma 720 -- SPARK_Mode with value On. 721 end record; 722 723 -- The following type captures relevant attributes which pertain to the 724 -- prior elaboration of a unit. This type is coupled together with a unit 725 -- to form a key -> value relationship. 726 727 type Elaboration_Attributes is record 728 Source_Pragma : Node_Id; 729 -- This attribute denotes a source Elaborate or Elaborate_All pragma 730 -- which guarantees the prior elaboration of some unit with respect 731 -- to the main unit. The pragma may come from the following contexts: 732 733 -- * The main unit 734 -- * The spec of the main unit (if applicable) 735 -- * Any parent spec of the main unit (if applicable) 736 -- * Any parent subunit of the main unit (if applicable) 737 738 -- The attribute remains Empty if no such pragma is available. Source 739 -- pragmas play a role in satisfying SPARK elaboration requirements. 740 741 With_Clause : Node_Id; 742 -- This attribute denotes an internally generated or source with clause 743 -- for some unit withed by the main unit. With clauses carry flags which 744 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses 745 -- play a role in supplying the elaboration dependencies to binde. 746 end record; 747 748 No_Elaboration_Attributes : constant Elaboration_Attributes := 749 (Source_Pragma => Empty, 750 With_Clause => Empty); 751 752 -- The following type captures relevant attributes which pertain to an 753 -- instantiation. 754 755 type Instantiation_Attributes is record 756 Elab_Checks_OK : Boolean; 757 -- This flag is set when the instantiation has elaboration checks 758 -- enabled. 759 760 Elab_Warnings_OK : Boolean; 761 -- This flag is set when the instantiation has elaboration warnings 762 -- enabled. 763 764 Ghost_Mode_Ignore : Boolean; 765 -- This flag is set when the instantiation appears in a region subject 766 -- to pragma Ghost with policy ignore, or starts one such region. 767 768 In_Declarations : Boolean; 769 -- This flag is set when the instantiation appears at the declaration 770 -- level. 771 772 SPARK_Mode_On : Boolean; 773 -- This flag is set when the instantiation appears in a region subject 774 -- to pragma SPARK_Mode with value On, or starts one such region. 775 end record; 776 777 -- The following type captures relevant attributes which pertain to the 778 -- state of the Processing phase. 779 780 type Processing_Attributes is record 781 Suppress_Implicit_Pragmas : Boolean; 782 -- This flag is set when the Processing phase must not generate any 783 -- implicit Elaborate[_All] pragmas. 784 785 Suppress_Warnings : Boolean; 786 -- This flag is set when the Processing phase must not emit any warnings 787 -- on elaboration problems. 788 789 Within_Initial_Condition : Boolean; 790 -- This flag is set when the Processing phase is currently examining a 791 -- scenario which was reached from an initial condition procedure. 792 793 Within_Instance : Boolean; 794 -- This flag is set when the Processing phase is currently examining a 795 -- scenario which was reached from a scenario defined in an instance. 796 797 Within_Partial_Finalization : Boolean; 798 -- This flag is set when the Processing phase is currently examining a 799 -- scenario which was reached from a partial finalization procedure. 800 801 Within_Task_Body : Boolean; 802 -- This flag is set when the Processing phase is currently examining a 803 -- scenario which was reached from a task body. 804 end record; 805 806 Initial_State : constant Processing_Attributes := 807 (Suppress_Implicit_Pragmas => False, 808 Suppress_Warnings => False, 809 Within_Initial_Condition => False, 810 Within_Instance => False, 811 Within_Partial_Finalization => False, 812 Within_Task_Body => False); 813 814 -- The following type captures relevant attributes which pertain to a 815 -- target. 816 817 type Target_Attributes is record 818 Elab_Checks_OK : Boolean; 819 -- This flag is set when the target has elaboration checks enabled 820 821 Elab_Warnings_OK : Boolean; 822 -- This flag is set when the target has elaboration warnings enabled 823 824 From_Source : Boolean; 825 -- This flag is set when the target comes from source 826 827 Ghost_Mode_Ignore : Boolean; 828 -- This flag is set when the target appears in a region subject to 829 -- pragma Ghost with policy ignore, or starts one such region. 830 831 SPARK_Mode_On : Boolean; 832 -- This flag is set when the target appears in a region subject to 833 -- pragma SPARK_Mode with value On, or starts one such region. 834 835 Spec_Decl : Node_Id; 836 -- This attribute denotes the declaration of Spec_Id 837 838 Unit_Id : Entity_Id; 839 -- This attribute denotes the top unit where Spec_Id resides 840 841 -- The semantics of the following attributes depend on the target 842 843 Body_Barf : Node_Id; 844 Body_Decl : Node_Id; 845 Spec_Id : Entity_Id; 846 847 -- The target is a generic package or a subprogram 848 -- 849 -- * Body_Barf - Empty 850 -- 851 -- * Body_Decl - This attribute denotes the generic or subprogram 852 -- body. 853 -- 854 -- * Spec_Id - This attribute denotes the entity of the generic 855 -- package or subprogram. 856 857 -- The target is a protected entry 858 -- 859 -- * Body_Barf - This attribute denotes the body of the barrier 860 -- function if expansion took place, otherwise it is Empty. 861 -- 862 -- * Body_Decl - This attribute denotes the body of the procedure 863 -- which emulates the entry if expansion took place, otherwise it 864 -- denotes the body of the protected entry. 865 -- 866 -- * Spec_Id - This attribute denotes the entity of the procedure 867 -- which emulates the entry if expansion took place, otherwise it 868 -- denotes the protected entry. 869 870 -- The target is a protected subprogram 871 -- 872 -- * Body_Barf - Empty 873 -- 874 -- * Body_Decl - This attribute denotes the body of the protected or 875 -- unprotected version of the protected subprogram if expansion took 876 -- place, otherwise it denotes the body of the protected subprogram. 877 -- 878 -- * Spec_Id - This attribute denotes the entity of the protected or 879 -- unprotected version of the protected subprogram if expansion took 880 -- place, otherwise it is the entity of the protected subprogram. 881 882 -- The target is a task entry 883 -- 884 -- * Body_Barf - Empty 885 -- 886 -- * Body_Decl - This attribute denotes the body of the procedure 887 -- which emulates the task body if expansion took place, otherwise 888 -- it denotes the body of the task type. 889 -- 890 -- * Spec_Id - This attribute denotes the entity of the procedure 891 -- which emulates the task body if expansion took place, otherwise 892 -- it denotes the entity of the task type. 893 end record; 894 895 -- The following type captures relevant attributes which pertain to a task 896 -- type. 897 898 type Task_Attributes is record 899 Body_Decl : Node_Id; 900 -- This attribute denotes the declaration of the procedure body which 901 -- emulates the behaviour of the task body. 902 903 Elab_Checks_OK : Boolean; 904 -- This flag is set when the task type has elaboration checks enabled 905 906 Elab_Warnings_OK : Boolean; 907 -- This flag is set when the task type has elaboration warnings enabled 908 909 Ghost_Mode_Ignore : Boolean; 910 -- This flag is set when the task type appears in a region subject to 911 -- pragma Ghost with policy ignore, or starts one such region. 912 913 SPARK_Mode_On : Boolean; 914 -- This flag is set when the task type appears in a region subject to 915 -- pragma SPARK_Mode with value On, or starts one such region. 916 917 Spec_Id : Entity_Id; 918 -- This attribute denotes the entity of the initial declaration of the 919 -- procedure body which emulates the behaviour of the task body. 920 921 Task_Decl : Node_Id; 922 -- This attribute denotes the declaration of the task type 923 924 Unit_Id : Entity_Id; 925 -- This attribute denotes the entity of the compilation unit where the 926 -- task type resides. 927 end record; 928 929 -- The following type captures relevant attributes which pertain to a 930 -- variable. 931 932 type Variable_Attributes is record 933 Unit_Id : Entity_Id; 934 -- This attribute denotes the entity of the compilation unit where the 935 -- variable resides. 936 end record; 937 938 --------------------- 939 -- Data structures -- 940 --------------------- 941 942 -- The ABE mechanism employs lists and hash tables to store information 943 -- pertaining to scenarios and targets, as well as the Processing phase. 944 -- The need for data structures comes partly from the size limitation of 945 -- nodes. Note that the use of hash tables is conservative and operations 946 -- are carried out only when a particular hash table has at least one key 947 -- value pair (see xxx_In_Use flags). 948 949 -- The following table stores the early call regions of subprogram bodies 950 951 Early_Call_Regions_Max : constant := 101; 952 953 type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; 954 955 function Early_Call_Regions_Hash 956 (Key : Entity_Id) return Early_Call_Regions_Index; 957 -- Obtain the hash value of entity Key 958 959 Early_Call_Regions_In_Use : Boolean := False; 960 -- This flag determines whether table Early_Call_Regions contains at least 961 -- least one key/value pair. 962 963 Early_Call_Regions_No_Element : constant Node_Id := Empty; 964 965 package Early_Call_Regions is new Simple_HTable 966 (Header_Num => Early_Call_Regions_Index, 967 Element => Node_Id, 968 No_Element => Early_Call_Regions_No_Element, 969 Key => Entity_Id, 970 Hash => Early_Call_Regions_Hash, 971 Equal => "="); 972 973 -- The following table stores the elaboration status of all units withed by 974 -- the main unit. 975 976 Elaboration_Statuses_Max : constant := 1009; 977 978 type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; 979 980 function Elaboration_Statuses_Hash 981 (Key : Entity_Id) return Elaboration_Statuses_Index; 982 -- Obtain the hash value of entity Key 983 984 Elaboration_Statuses_In_Use : Boolean := False; 985 -- This flag flag determines whether table Elaboration_Statuses contains at 986 -- least one key/value pair. 987 988 Elaboration_Statuses_No_Element : constant Elaboration_Attributes := 989 No_Elaboration_Attributes; 990 991 package Elaboration_Statuses is new Simple_HTable 992 (Header_Num => Elaboration_Statuses_Index, 993 Element => Elaboration_Attributes, 994 No_Element => Elaboration_Statuses_No_Element, 995 Key => Entity_Id, 996 Hash => Elaboration_Statuses_Hash, 997 Equal => "="); 998 999 -- The following table stores a status flag for each SPARK scenario saved 1000 -- in table SPARK_Scenarios. 1001 1002 Recorded_SPARK_Scenarios_Max : constant := 127; 1003 1004 type Recorded_SPARK_Scenarios_Index is 1005 range 0 .. Recorded_SPARK_Scenarios_Max - 1; 1006 1007 function Recorded_SPARK_Scenarios_Hash 1008 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; 1009 -- Obtain the hash value of Key 1010 1011 Recorded_SPARK_Scenarios_In_Use : Boolean := False; 1012 -- This flag flag determines whether table Recorded_SPARK_Scenarios 1013 -- contains at least one key/value pair. 1014 1015 Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; 1016 1017 package Recorded_SPARK_Scenarios is new Simple_HTable 1018 (Header_Num => Recorded_SPARK_Scenarios_Index, 1019 Element => Boolean, 1020 No_Element => Recorded_SPARK_Scenarios_No_Element, 1021 Key => Node_Id, 1022 Hash => Recorded_SPARK_Scenarios_Hash, 1023 Equal => "="); 1024 1025 -- The following table stores a status flag for each top-level scenario 1026 -- recorded in table Top_Level_Scenarios. 1027 1028 Recorded_Top_Level_Scenarios_Max : constant := 503; 1029 1030 type Recorded_Top_Level_Scenarios_Index is 1031 range 0 .. Recorded_Top_Level_Scenarios_Max - 1; 1032 1033 function Recorded_Top_Level_Scenarios_Hash 1034 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; 1035 -- Obtain the hash value of entity Key 1036 1037 Recorded_Top_Level_Scenarios_In_Use : Boolean := False; 1038 -- This flag flag determines whether table Recorded_Top_Level_Scenarios 1039 -- contains at least one key/value pair. 1040 1041 Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; 1042 1043 package Recorded_Top_Level_Scenarios is new Simple_HTable 1044 (Header_Num => Recorded_Top_Level_Scenarios_Index, 1045 Element => Boolean, 1046 No_Element => Recorded_Top_Level_Scenarios_No_Element, 1047 Key => Node_Id, 1048 Hash => Recorded_Top_Level_Scenarios_Hash, 1049 Equal => "="); 1050 1051 -- The following table stores all active scenarios in a recursive traversal 1052 -- starting from a top-level scenario. This table must be maintained in a 1053 -- FIFO fashion. 1054 1055 package Scenario_Stack is new Table.Table 1056 (Table_Component_Type => Node_Id, 1057 Table_Index_Type => Int, 1058 Table_Low_Bound => 1, 1059 Table_Initial => 50, 1060 Table_Increment => 100, 1061 Table_Name => "Scenario_Stack"); 1062 1063 -- The following table stores SPARK scenarios which are not necessarily 1064 -- executable during elaboration, but still require elaboration-related 1065 -- checks. 1066 1067 package SPARK_Scenarios is new Table.Table 1068 (Table_Component_Type => Node_Id, 1069 Table_Index_Type => Int, 1070 Table_Low_Bound => 1, 1071 Table_Initial => 50, 1072 Table_Increment => 100, 1073 Table_Name => "SPARK_Scenarios"); 1074 1075 -- The following table stores all top-level scenario saved during the 1076 -- Recording phase. The contents of this table act as traversal roots 1077 -- later in the Processing phase. This table must be maintained in a 1078 -- LIFO fashion. 1079 1080 package Top_Level_Scenarios is new Table.Table 1081 (Table_Component_Type => Node_Id, 1082 Table_Index_Type => Int, 1083 Table_Low_Bound => 1, 1084 Table_Initial => 1000, 1085 Table_Increment => 100, 1086 Table_Name => "Top_Level_Scenarios"); 1087 1088 -- The following table stores the bodies of all eligible scenarios visited 1089 -- during a traversal starting from a top-level scenario. The contents of 1090 -- this table must be reset upon each new traversal. 1091 1092 Visited_Bodies_Max : constant := 511; 1093 1094 type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; 1095 1096 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; 1097 -- Obtain the hash value of node Key 1098 1099 Visited_Bodies_In_Use : Boolean := False; 1100 -- This flag determines whether table Visited_Bodies contains at least one 1101 -- key/value pair. 1102 1103 Visited_Bodies_No_Element : constant Boolean := False; 1104 1105 package Visited_Bodies is new Simple_HTable 1106 (Header_Num => Visited_Bodies_Index, 1107 Element => Boolean, 1108 No_Element => Visited_Bodies_No_Element, 1109 Key => Node_Id, 1110 Hash => Visited_Bodies_Hash, 1111 Equal => "="); 1112 1113 ----------------------- 1114 -- Local subprograms -- 1115 ----------------------- 1116 1117 -- Multiple local subprograms are utilized to lower the semantic complexity 1118 -- of the Recording and Processing phase. 1119 1120 procedure Check_Preelaborated_Call (Call : Node_Id); 1121 pragma Inline (Check_Preelaborated_Call); 1122 -- Verify that entry, operator, or subprogram call Call does not appear at 1123 -- the library level of a preelaborated unit. 1124 1125 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); 1126 pragma Inline (Check_SPARK_Derived_Type); 1127 -- Verify that the freeze node of a derived type denoted by declaration 1128 -- Typ_Decl is within the early call region of each overriding primitive 1129 -- body that belongs to the derived type (SPARK RM 7.7(8)). 1130 1131 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); 1132 pragma Inline (Check_SPARK_Instantiation); 1133 -- Verify that expanded instance Exp_Inst does not precede the generic body 1134 -- it instantiates (SPARK RM 7.7(6)). 1135 1136 procedure Check_SPARK_Model_In_Effect (N : Node_Id); 1137 pragma Inline (Check_SPARK_Model_In_Effect); 1138 -- Determine whether a suitable elaboration model is currently in effect 1139 -- for verifying the SPARK rules of scenario N. Emit a warning if this is 1140 -- not the case. 1141 1142 procedure Check_SPARK_Scenario (N : Node_Id); 1143 pragma Inline (Check_SPARK_Scenario); 1144 -- Top-level dispatcher for verifying SPARK scenarios which are not always 1145 -- executable during elaboration but still need elaboration-related checks. 1146 1147 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); 1148 pragma Inline (Check_SPARK_Refined_State_Pragma); 1149 -- Verify that each constituent of Refined_State pragma N which belongs to 1150 -- an abstract state mentioned in pragma Initializes has prior elaboration 1151 -- with respect to the main unit (SPARK RM 7.7.1(7)). 1152 1153 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; 1154 pragma Inline (Compilation_Unit); 1155 -- Return the N_Compilation_Unit node of unit Unit_Id 1156 1157 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 1158 pragma Inline (Early_Call_Region); 1159 -- Return the early call region associated with entry or subprogram body 1160 -- Body_Id. IMPORTANT: This routine does not find the early call region. 1161 -- To compute it, use routine Find_Early_Call_Region. 1162 1163 procedure Elab_Msg_NE 1164 (Msg : String; 1165 N : Node_Id; 1166 Id : Entity_Id; 1167 Info_Msg : Boolean; 1168 In_SPARK : Boolean); 1169 pragma Inline (Elab_Msg_NE); 1170 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node 1171 -- N and entity. If flag Info_Msg is set, the routine emits an information 1172 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1173 -- string " in SPARK" is added to the end of the message. 1174 1175 function Elaboration_Status 1176 (Unit_Id : Entity_Id) return Elaboration_Attributes; 1177 pragma Inline (Elaboration_Status); 1178 -- Return the set of elaboration attributes associated with unit Unit_Id 1179 1180 procedure Ensure_Prior_Elaboration 1181 (N : Node_Id; 1182 Unit_Id : Entity_Id; 1183 Prag_Nam : Name_Id; 1184 State : Processing_Attributes); 1185 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1186 -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N 1187 -- denotes the related scenario. State denotes the current state of the 1188 -- Processing phase. 1189 1190 procedure Ensure_Prior_Elaboration_Dynamic 1191 (N : Node_Id; 1192 Unit_Id : Entity_Id; 1193 Prag_Nam : Name_Id); 1194 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1195 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes 1196 -- the related scenario. 1197 1198 procedure Ensure_Prior_Elaboration_Static 1199 (N : Node_Id; 1200 Unit_Id : Entity_Id; 1201 Prag_Nam : Name_Id); 1202 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1203 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N 1204 -- denotes the related scenario. 1205 1206 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; 1207 pragma Inline (Extract_Assignment_Name); 1208 -- Obtain the Name attribute of assignment statement Asmt 1209 1210 procedure Extract_Call_Attributes 1211 (Call : Node_Id; 1212 Target_Id : out Entity_Id; 1213 Attrs : out Call_Attributes); 1214 pragma Inline (Extract_Call_Attributes); 1215 -- Obtain attributes Attrs associated with call Call. Target_Id is the 1216 -- entity of the call target. 1217 1218 function Extract_Call_Name (Call : Node_Id) return Node_Id; 1219 pragma Inline (Extract_Call_Name); 1220 -- Obtain the Name attribute of entry or subprogram call Call 1221 1222 procedure Extract_Instance_Attributes 1223 (Exp_Inst : Node_Id; 1224 Inst_Body : out Node_Id; 1225 Inst_Decl : out Node_Id); 1226 pragma Inline (Extract_Instance_Attributes); 1227 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst 1228 1229 procedure Extract_Instantiation_Attributes 1230 (Exp_Inst : Node_Id; 1231 Inst : out Node_Id; 1232 Inst_Id : out Entity_Id; 1233 Gen_Id : out Entity_Id; 1234 Attrs : out Instantiation_Attributes); 1235 pragma Inline (Extract_Instantiation_Attributes); 1236 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. 1237 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id 1238 -- is the entity of the generic unit being instantiated. 1239 1240 procedure Extract_Target_Attributes 1241 (Target_Id : Entity_Id; 1242 Attrs : out Target_Attributes); 1243 -- Obtain attributes Attrs associated with an entry, package, or subprogram 1244 -- denoted by Target_Id. 1245 1246 procedure Extract_Task_Attributes 1247 (Typ : Entity_Id; 1248 Attrs : out Task_Attributes); 1249 pragma Inline (Extract_Task_Attributes); 1250 -- Obtain attributes Attrs associated with task type Typ 1251 1252 procedure Extract_Variable_Reference_Attributes 1253 (Ref : Node_Id; 1254 Var_Id : out Entity_Id; 1255 Attrs : out Variable_Attributes); 1256 pragma Inline (Extract_Variable_Reference_Attributes); 1257 -- Obtain attributes Attrs associated with reference Ref that mentions 1258 -- variable Var_Id. 1259 1260 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1261 pragma Inline (Find_Code_Unit); 1262 -- Return the code unit which contains arbitrary node or entity N. This 1263 -- is the unit of the file which physically contains the related construct 1264 -- denoted by N except when N is within an instantiation. In that case the 1265 -- unit is that of the top-level instantiation. 1266 1267 function Find_Early_Call_Region 1268 (Body_Decl : Node_Id; 1269 Assume_Elab_Body : Boolean := False; 1270 Skip_Memoization : Boolean := False) return Node_Id; 1271 -- Find the start of the early call region which belongs to subprogram body 1272 -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to 1273 -- find the early call region, memoize it, and return it, but this behavior 1274 -- can be altered. Flag Assume_Elab_Body should be set when a package spec 1275 -- may lack pragma Elaborate_Body, but the routine must still examine that 1276 -- spec. Flag Skip_Memoization should be set when the routine must avoid 1277 -- memoizing the region. 1278 1279 procedure Find_Elaborated_Units; 1280 -- Populate table Elaboration_Statuses with all units which have prior 1281 -- elaboration with respect to the main unit. 1282 1283 function Find_Enclosing_Instance (N : Node_Id) return Node_Id; 1284 pragma Inline (Find_Enclosing_Instance); 1285 -- Find the declaration or body of the nearest expanded instance which 1286 -- encloses arbitrary node N. Return Empty if no such instance exists. 1287 1288 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1289 pragma Inline (Find_Top_Unit); 1290 -- Return the top unit which contains arbitrary node or entity N. The unit 1291 -- is obtained by logically unwinding instantiations and subunits when N 1292 -- resides within one. 1293 1294 function Find_Unit_Entity (N : Node_Id) return Entity_Id; 1295 pragma Inline (Find_Unit_Entity); 1296 -- Return the entity of unit N 1297 1298 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; 1299 pragma Inline (First_Formal_Type); 1300 -- Return the type of subprogram Subp_Id's first formal parameter. If the 1301 -- subprogram lacks formal parameters, return Empty. 1302 1303 function Has_Body (Pack_Decl : Node_Id) return Boolean; 1304 -- Determine whether package declaration Pack_Decl has a corresponding body 1305 -- or would eventually have one. 1306 1307 function Has_Prior_Elaboration 1308 (Unit_Id : Entity_Id; 1309 Context_OK : Boolean := False; 1310 Elab_Body_OK : Boolean := False; 1311 Same_Unit_OK : Boolean := False) return Boolean; 1312 pragma Inline (Has_Prior_Elaboration); 1313 -- Determine whether unit Unit_Id is elaborated prior to the main unit. 1314 -- If flag Context_OK is set, the routine considers the following case 1315 -- as valid prior elaboration: 1316 -- 1317 -- * Unit_Id is in the elaboration context of the main unit 1318 -- 1319 -- If flag Elab_Body_OK is set, the routine considers the following case 1320 -- as valid prior elaboration: 1321 -- 1322 -- * Unit_Id has pragma Elaborate_Body and is not the main unit 1323 -- 1324 -- If flag Same_Unit_OK is set, the routine considers the following cases 1325 -- as valid prior elaboration: 1326 -- 1327 -- * Unit_Id is the main unit 1328 -- 1329 -- * Unit_Id denotes the spec of the main unit body 1330 1331 function In_External_Instance 1332 (N : Node_Id; 1333 Target_Decl : Node_Id) return Boolean; 1334 pragma Inline (In_External_Instance); 1335 -- Determine whether a target desctibed by its declaration Target_Decl 1336 -- resides in a package instance which is external to scenario N. 1337 1338 function In_Main_Context (N : Node_Id) return Boolean; 1339 pragma Inline (In_Main_Context); 1340 -- Determine whether arbitrary node N appears within the main compilation 1341 -- unit. 1342 1343 function In_Same_Context 1344 (N1 : Node_Id; 1345 N2 : Node_Id; 1346 Nested_OK : Boolean := False) return Boolean; 1347 -- Determine whether two arbitrary nodes N1 and N2 appear within the same 1348 -- context ignoring enclosing library levels. Nested_OK should be set when 1349 -- the context of N1 can enclose that of N2. 1350 1351 function In_Task_Body (N : Node_Id) return Boolean; 1352 pragma Inline (In_Task_Body); 1353 -- Determine whether arbitrary node N appears within a task body 1354 1355 procedure Info_Call 1356 (Call : Node_Id; 1357 Target_Id : Entity_Id; 1358 Info_Msg : Boolean; 1359 In_SPARK : Boolean); 1360 -- Output information concerning call Call which invokes target Target_Id. 1361 -- If flag Info_Msg is set, the routine emits an information message, 1362 -- otherwise it emits an error. If flag In_SPARK is set, then the string 1363 -- " in SPARK" is added to the end of the message. 1364 1365 procedure Info_Instantiation 1366 (Inst : Node_Id; 1367 Gen_Id : Entity_Id; 1368 Info_Msg : Boolean; 1369 In_SPARK : Boolean); 1370 pragma Inline (Info_Instantiation); 1371 -- Output information concerning instantiation Inst which instantiates 1372 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1373 -- information message, otherwise it emits an error. If flag In_SPARK 1374 -- is set, then string " in SPARK" is added to the end of the message. 1375 1376 procedure Info_Variable_Reference 1377 (Ref : Node_Id; 1378 Var_Id : Entity_Id; 1379 Info_Msg : Boolean; 1380 In_SPARK : Boolean); 1381 pragma Inline (Info_Variable_Reference); 1382 -- Output information concerning reference Ref which mentions variable 1383 -- Var_Id. If flag Info_Msg is set, the routine emits an information 1384 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1385 -- string " in SPARK" is added to the end of the message. 1386 1387 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; 1388 pragma Inline (Insertion_Node); 1389 -- Obtain the proper insertion node of an ABE check or failure for scenario 1390 -- N and candidate insertion node Ins_Nod. 1391 1392 procedure Install_ABE_Check 1393 (N : Node_Id; 1394 Id : Entity_Id; 1395 Ins_Nod : Node_Id); 1396 -- Insert a run-time ABE check for elaboration scenario N which verifies 1397 -- whether arbitrary entity Id is elaborated. The check in inserted prior 1398 -- to node Ins_Nod. 1399 1400 procedure Install_ABE_Check 1401 (N : Node_Id; 1402 Target_Id : Entity_Id; 1403 Target_Decl : Node_Id; 1404 Target_Body : Node_Id; 1405 Ins_Nod : Node_Id); 1406 -- Insert a run-time ABE check for elaboration scenario N which verifies 1407 -- whether target Target_Id with initial declaration Target_Decl and body 1408 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. 1409 1410 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); 1411 -- Insert a Program_Error concerning a guaranteed ABE for elaboration 1412 -- scenario N. The failure is inserted prior to node Node_Id. 1413 1414 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; 1415 pragma Inline (Is_Accept_Alternative_Proc); 1416 -- Determine whether arbitrary entity Id denotes an internally generated 1417 -- procedure which encapsulates the statements of an accept alternative. 1418 1419 function Is_Activation_Proc (Id : Entity_Id) return Boolean; 1420 pragma Inline (Is_Activation_Proc); 1421 -- Determine whether arbitrary entity Id denotes a runtime procedure in 1422 -- charge with activating tasks. 1423 1424 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; 1425 pragma Inline (Is_Ada_Semantic_Target); 1426 -- Determine whether arbitrary entity Id denodes a source or internally 1427 -- generated subprogram which emulates Ada semantics. 1428 1429 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; 1430 pragma Inline (Is_Assertion_Pragma_Target); 1431 -- Determine whether arbitrary entity Id denotes a procedure which varifies 1432 -- the run-time semantics of an assertion pragma. 1433 1434 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; 1435 pragma Inline (Is_Bodiless_Subprogram); 1436 -- Determine whether subprogram Subp_Id will never have a body 1437 1438 function Is_Controlled_Proc 1439 (Subp_Id : Entity_Id; 1440 Subp_Nam : Name_Id) return Boolean; 1441 pragma Inline (Is_Controlled_Proc); 1442 -- Determine whether subprogram Subp_Id denotes controlled type primitives 1443 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. 1444 1445 function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1446 pragma Inline (Is_Default_Initial_Condition_Proc); 1447 -- Determine whether arbitrary entity Id denotes internally generated 1448 -- routine Default_Initial_Condition. 1449 1450 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; 1451 pragma Inline (Is_Finalizer_Proc); 1452 -- Determine whether arbitrary entity Id denotes internally generated 1453 -- routine _Finalizer. 1454 1455 function Is_Guaranteed_ABE 1456 (N : Node_Id; 1457 Target_Decl : Node_Id; 1458 Target_Body : Node_Id) return Boolean; 1459 pragma Inline (Is_Guaranteed_ABE); 1460 -- Determine whether scenario N with a target described by its initial 1461 -- declaration Target_Decl and body Target_Decl results in a guaranteed 1462 -- ABE. 1463 1464 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1465 pragma Inline (Is_Initial_Condition_Proc); 1466 -- Determine whether arbitrary entity Id denotes internally generated 1467 -- routine Initial_Condition. 1468 1469 function Is_Initialized (Obj_Decl : Node_Id) return Boolean; 1470 pragma Inline (Is_Initialized); 1471 -- Determine whether object declaration Obj_Decl is initialized 1472 1473 function Is_Invariant_Proc (Id : Entity_Id) return Boolean; 1474 pragma Inline (Is_Invariant_Proc); 1475 -- Determine whether arbitrary entity Id denotes an invariant procedure 1476 1477 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; 1478 pragma Inline (Is_Non_Library_Level_Encapsulator); 1479 -- Determine whether arbitrary node N is a non-library encapsulator 1480 1481 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; 1482 pragma Inline (Is_Partial_Invariant_Proc); 1483 -- Determine whether arbitrary entity Id denotes a partial invariant 1484 -- procedure. 1485 1486 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; 1487 pragma Inline (Is_Postconditions_Proc); 1488 -- Determine whether arbitrary entity Id denotes internally generated 1489 -- routine _Postconditions. 1490 1491 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; 1492 pragma Inline (Is_Preelaborated_Unit); 1493 -- Determine whether arbitrary entity Id denotes a unit which is subject to 1494 -- one of the following pragmas: 1495 -- 1496 -- * Preelaborable 1497 -- * Pure 1498 -- * Remote_Call_Interface 1499 -- * Remote_Types 1500 -- * Shared_Passive 1501 1502 function Is_Protected_Entry (Id : Entity_Id) return Boolean; 1503 pragma Inline (Is_Protected_Entry); 1504 -- Determine whether arbitrary entity Id denotes a protected entry 1505 1506 function Is_Protected_Subp (Id : Entity_Id) return Boolean; 1507 pragma Inline (Is_Protected_Subp); 1508 -- Determine whether entity Id denotes a protected subprogram 1509 1510 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; 1511 pragma Inline (Is_Protected_Body_Subp); 1512 -- Determine whether entity Id denotes the protected or unprotected version 1513 -- of a protected subprogram. 1514 1515 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; 1516 pragma Inline (Is_Recorded_SPARK_Scenario); 1517 -- Determine whether arbitrary node N is a recorded SPARK scenario which 1518 -- appears in table SPARK_Scenarios. 1519 1520 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; 1521 pragma Inline (Is_Recorded_Top_Level_Scenario); 1522 -- Determine whether arbitrary node N is a recorded top-level scenario 1523 -- which appears in table Top_Level_Scenarios. 1524 1525 function Is_Safe_Activation 1526 (Call : Node_Id; 1527 Task_Decl : Node_Id) return Boolean; 1528 pragma Inline (Is_Safe_Activation); 1529 -- Determine whether call Call which activates a task object described by 1530 -- declaration Task_Decl is always ABE-safe. 1531 1532 function Is_Safe_Call 1533 (Call : Node_Id; 1534 Target_Attrs : Target_Attributes) return Boolean; 1535 pragma Inline (Is_Safe_Call); 1536 -- Determine whether call Call which invokes a target described by 1537 -- attributes Target_Attrs is always ABE-safe. 1538 1539 function Is_Safe_Instantiation 1540 (Inst : Node_Id; 1541 Gen_Attrs : Target_Attributes) return Boolean; 1542 pragma Inline (Is_Safe_Instantiation); 1543 -- Determine whether instance Inst which instantiates a generic unit 1544 -- described by attributes Gen_Attrs is always ABE-safe. 1545 1546 function Is_Same_Unit 1547 (Unit_1 : Entity_Id; 1548 Unit_2 : Entity_Id) return Boolean; 1549 pragma Inline (Is_Same_Unit); 1550 -- Determine whether entities Unit_1 and Unit_2 denote the same unit 1551 1552 function Is_Scenario (N : Node_Id) return Boolean; 1553 pragma Inline (Is_Scenario); 1554 -- Determine whether attribute node N denotes a scenario. The scenario may 1555 -- not necessarily be eligible for ABE processing. 1556 1557 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; 1558 pragma Inline (Is_SPARK_Semantic_Target); 1559 -- Determine whether arbitrary entity Id nodes a source or internally 1560 -- generated subprogram which emulates SPARK semantics. 1561 1562 function Is_Suitable_Access (N : Node_Id) return Boolean; 1563 pragma Inline (Is_Suitable_Access); 1564 -- Determine whether arbitrary node N denotes a suitable attribute for ABE 1565 -- processing. 1566 1567 function Is_Suitable_Call (N : Node_Id) return Boolean; 1568 pragma Inline (Is_Suitable_Call); 1569 -- Determine whether arbitrary node N denotes a suitable call for ABE 1570 -- processing. 1571 1572 function Is_Suitable_Instantiation (N : Node_Id) return Boolean; 1573 pragma Inline (Is_Suitable_Instantiation); 1574 -- Determine whether arbitrary node N is a suitable instantiation for ABE 1575 -- processing. 1576 1577 function Is_Suitable_Scenario (N : Node_Id) return Boolean; 1578 pragma Inline (Is_Suitable_Scenario); 1579 -- Determine whether arbitrary node N is a suitable scenario for ABE 1580 -- processing. 1581 1582 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; 1583 pragma Inline (Is_Suitable_SPARK_Derived_Type); 1584 -- Determine whether arbitrary node N denotes a suitable derived type 1585 -- declaration for ABE processing using the SPARK rules. 1586 1587 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; 1588 pragma Inline (Is_Suitable_SPARK_Instantiation); 1589 -- Determine whether arbitrary node N denotes a suitable instantiation for 1590 -- ABE processing using the SPARK rules. 1591 1592 function Is_Suitable_SPARK_Refined_State_Pragma 1593 (N : Node_Id) return Boolean; 1594 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); 1595 -- Determine whether arbitrary node N denotes a suitable Refined_State 1596 -- pragma for ABE processing using the SPARK rules. 1597 1598 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; 1599 pragma Inline (Is_Suitable_Variable_Assignment); 1600 -- Determine whether arbitrary node N denotes a suitable assignment for ABE 1601 -- processing. 1602 1603 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; 1604 pragma Inline (Is_Suitable_Variable_Reference); 1605 -- Determine whether arbitrary node N is a suitable variable reference for 1606 -- ABE processing. 1607 1608 function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; 1609 pragma Inline (Is_Synchronous_Suspension_Call); 1610 -- Determine whether arbitrary node N denotes a call to one the following 1611 -- routines: 1612 -- 1613 -- Ada.Synchronous_Barriers.Wait_For_Release 1614 -- Ada.Synchronous_Task_Control.Suspend_Until_True 1615 1616 function Is_Task_Entry (Id : Entity_Id) return Boolean; 1617 pragma Inline (Is_Task_Entry); 1618 -- Determine whether arbitrary entity Id denotes a task entry 1619 1620 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; 1621 pragma Inline (Is_Up_Level_Target); 1622 -- Determine whether the current root resides at the declaration level. If 1623 -- this is the case, determine whether a target described by declaration 1624 -- Target_Decl is within a context which encloses the current root or is in 1625 -- a different unit. 1626 1627 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; 1628 pragma Inline (Is_Visited_Body); 1629 -- Determine whether subprogram body Body_Decl is already visited during a 1630 -- recursive traversal started from a top-level scenario. 1631 1632 procedure Meet_Elaboration_Requirement 1633 (N : Node_Id; 1634 Target_Id : Entity_Id; 1635 Req_Nam : Name_Id); 1636 -- Determine whether elaboration requirement Req_Nam for scenario N with 1637 -- target Target_Id is met by the context of the main unit using the SPARK 1638 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an 1639 -- error if this is not the case. 1640 1641 function Non_Private_View (Typ : Entity_Id) return Entity_Id; 1642 pragma Inline (Non_Private_View); 1643 -- Return the full view of private type Typ if available, otherwise return 1644 -- type Typ. 1645 1646 procedure Output_Active_Scenarios (Error_Nod : Node_Id); 1647 -- Output the contents of the active scenario stack from earliest to latest 1648 -- to supplement an earlier error emitted for node Error_Nod. 1649 1650 procedure Pop_Active_Scenario (N : Node_Id); 1651 pragma Inline (Pop_Active_Scenario); 1652 -- Pop the top of the scenario stack. A check is made to ensure that the 1653 -- scenario being removed is the same as N. 1654 1655 generic 1656 with procedure Process_Single_Activation 1657 (Call : Node_Id; 1658 Call_Attrs : Call_Attributes; 1659 Obj_Id : Entity_Id; 1660 Task_Attrs : Task_Attributes; 1661 State : Processing_Attributes); 1662 -- Perform ABE checks and diagnostics for task activation call Call 1663 -- which activates task Obj_Id. Call_Attrs are the attributes of the 1664 -- activation call. Task_Attrs are the attributes of the task type. 1665 -- State is the current state of the Processing phase. 1666 1667 procedure Process_Activation_Generic 1668 (Call : Node_Id; 1669 Call_Attrs : Call_Attributes; 1670 State : Processing_Attributes); 1671 -- Perform ABE checks and diagnostics for activation call Call by invoking 1672 -- routine Process_Single_Activation on each task object being activated. 1673 -- Call_Attrs are the attributes of the activation call. State is the 1674 -- current state of the Processing phase. 1675 1676 procedure Process_Conditional_ABE 1677 (N : Node_Id; 1678 State : Processing_Attributes := Initial_State); 1679 -- Top-level dispatcher for processing of various elaboration scenarios. 1680 -- Perform conditional ABE checks and diagnostics for scenario N. State 1681 -- is the current state of the Processing phase. 1682 1683 procedure Process_Conditional_ABE_Access 1684 (Attr : Node_Id; 1685 State : Processing_Attributes); 1686 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or 1687 -- subprogram denoted by Attr. State is the current state of the Processing 1688 -- phase. 1689 1690 procedure Process_Conditional_ABE_Activation_Impl 1691 (Call : Node_Id; 1692 Call_Attrs : Call_Attributes; 1693 Obj_Id : Entity_Id; 1694 Task_Attrs : Task_Attributes; 1695 State : Processing_Attributes); 1696 -- Perform common conditional ABE checks and diagnostics for call Call 1697 -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs 1698 -- are the attributes of the activation call. Task_Attrs are the attributes 1699 -- of the task type. State is the current state of the Processing phase. 1700 1701 procedure Process_Conditional_ABE_Call 1702 (Call : Node_Id; 1703 Call_Attrs : Call_Attributes; 1704 Target_Id : Entity_Id; 1705 State : Processing_Attributes); 1706 -- Top-level dispatcher for processing of calls. Perform ABE checks and 1707 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs 1708 -- are the attributes of the call. State is the current state of the 1709 -- Processing phase. 1710 1711 procedure Process_Conditional_ABE_Call_Ada 1712 (Call : Node_Id; 1713 Call_Attrs : Call_Attributes; 1714 Target_Id : Entity_Id; 1715 Target_Attrs : Target_Attributes; 1716 State : Processing_Attributes); 1717 -- Perform ABE checks and diagnostics for call Call which invokes target 1718 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the 1719 -- call. Target_Attrs are attributes of the target. State is the current 1720 -- state of the Processing phase. 1721 1722 procedure Process_Conditional_ABE_Call_SPARK 1723 (Call : Node_Id; 1724 Target_Id : Entity_Id; 1725 Target_Attrs : Target_Attributes; 1726 State : Processing_Attributes); 1727 -- Perform ABE checks and diagnostics for call Call which invokes target 1728 -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of 1729 -- the target. State is the current state of the Processing phase. 1730 1731 procedure Process_Conditional_ABE_Instantiation 1732 (Exp_Inst : Node_Id; 1733 State : Processing_Attributes); 1734 -- Top-level dispatcher for processing of instantiations. Perform ABE 1735 -- checks and diagnostics for expanded instantiation Exp_Inst. State is 1736 -- the current state of the Processing phase. 1737 1738 procedure Process_Conditional_ABE_Instantiation_Ada 1739 (Exp_Inst : Node_Id; 1740 Inst : Node_Id; 1741 Inst_Attrs : Instantiation_Attributes; 1742 Gen_Id : Entity_Id; 1743 Gen_Attrs : Target_Attributes; 1744 State : Processing_Attributes); 1745 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst 1746 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. 1747 -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the 1748 -- attributes of the generic. State is the current state of the Processing 1749 -- phase. 1750 1751 procedure Process_Conditional_ABE_Instantiation_SPARK 1752 (Inst : Node_Id; 1753 Gen_Id : Entity_Id; 1754 Gen_Attrs : Target_Attributes; 1755 State : Processing_Attributes); 1756 -- Perform ABE checks and diagnostics for instantiation Inst of generic 1757 -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the 1758 -- generic. State is the current state of the Processing phase. 1759 1760 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); 1761 -- Top-level dispatcher for processing of variable assignments. Perform ABE 1762 -- checks and diagnostics for assignment statement Asmt. 1763 1764 procedure Process_Conditional_ABE_Variable_Assignment_Ada 1765 (Asmt : Node_Id; 1766 Var_Id : Entity_Id); 1767 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1768 -- updates the value of variable Var_Id using the Ada rules. 1769 1770 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 1771 (Asmt : Node_Id; 1772 Var_Id : Entity_Id); 1773 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1774 -- updates the value of variable Var_Id using the SPARK rules. 1775 1776 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); 1777 -- Top-level dispatcher for processing of variable references. Perform ABE 1778 -- checks and diagnostics for variable reference Ref. 1779 1780 procedure Process_Conditional_ABE_Variable_Reference_Read 1781 (Ref : Node_Id; 1782 Var_Id : Entity_Id; 1783 Attrs : Variable_Attributes); 1784 -- Perform ABE checks and diagnostics for reference Ref described by its 1785 -- attributes Attrs, that reads variable Var_Id. 1786 1787 procedure Process_Guaranteed_ABE (N : Node_Id); 1788 -- Top-level dispatcher for processing of scenarios which result in a 1789 -- guaranteed ABE. 1790 1791 procedure Process_Guaranteed_ABE_Activation_Impl 1792 (Call : Node_Id; 1793 Call_Attrs : Call_Attributes; 1794 Obj_Id : Entity_Id; 1795 Task_Attrs : Task_Attributes; 1796 State : Processing_Attributes); 1797 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1798 -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are 1799 -- the attributes of the activation call. Task_Attrs are the attributes of 1800 -- the task type. State is provided for compatibility and is not used. 1801 1802 procedure Process_Guaranteed_ABE_Call 1803 (Call : Node_Id; 1804 Call_Attrs : Call_Attributes; 1805 Target_Id : Entity_Id); 1806 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1807 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are 1808 -- the attributes of the call. 1809 1810 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id); 1811 -- Perform common guaranteed ABE checks and diagnostics for expanded 1812 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK 1813 -- rules. 1814 1815 procedure Push_Active_Scenario (N : Node_Id); 1816 pragma Inline (Push_Active_Scenario); 1817 -- Push scenario N on top of the scenario stack 1818 1819 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); 1820 pragma Inline (Record_SPARK_Elaboration_Scenario); 1821 -- Save SPARK scenario N in table SPARK_Scenarios for later processing 1822 1823 procedure Reset_Visited_Bodies; 1824 pragma Inline (Reset_Visited_Bodies); 1825 -- Clear the contents of table Visited_Bodies 1826 1827 function Root_Scenario return Node_Id; 1828 pragma Inline (Root_Scenario); 1829 -- Return the top-level scenario which started a recursive search for other 1830 -- scenarios. It is assumed that there is a valid top-level scenario on the 1831 -- active scenario stack. 1832 1833 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 1834 pragma Inline (Set_Early_Call_Region); 1835 -- Associate an early call region with begins at construct Start with entry 1836 -- or subprogram body Body_Id. 1837 1838 procedure Set_Elaboration_Status 1839 (Unit_Id : Entity_Id; 1840 Val : Elaboration_Attributes); 1841 pragma Inline (Set_Elaboration_Status); 1842 -- Associate an set of elaboration attributes with unit Unit_Id 1843 1844 procedure Set_Is_Recorded_SPARK_Scenario 1845 (N : Node_Id; 1846 Val : Boolean := True); 1847 pragma Inline (Set_Is_Recorded_SPARK_Scenario); 1848 -- Mark scenario N as being recorded in table SPARK_Scenarios 1849 1850 procedure Set_Is_Recorded_Top_Level_Scenario 1851 (N : Node_Id; 1852 Val : Boolean := True); 1853 pragma Inline (Set_Is_Recorded_Top_Level_Scenario); 1854 -- Mark scenario N as being recorded in table Top_Level_Scenarios 1855 1856 procedure Set_Is_Visited_Body (Subp_Body : Node_Id); 1857 pragma Inline (Set_Is_Visited_Body); 1858 -- Mark subprogram body Subp_Body as being visited during a recursive 1859 -- traversal started from a top-level scenario. 1860 1861 function Static_Elaboration_Checks return Boolean; 1862 pragma Inline (Static_Elaboration_Checks); 1863 -- Determine whether the static model is in effect 1864 1865 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); 1866 -- Inspect the declarative and statement lists of subprogram body N for 1867 -- suitable elaboration scenarios and process them. State is the current 1868 -- state of the Processing phase. 1869 1870 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; 1871 pragma Inline (Unit_Entity); 1872 -- Return the entity of the initial declaration for unit Unit_Id 1873 1874 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); 1875 pragma Inline (Update_Elaboration_Scenario); 1876 -- Update all relevant internal data structures when scenario Old_N is 1877 -- transformed into scenario New_N by Atree.Rewrite. 1878 1879 ----------------------- 1880 -- Build_Call_Marker -- 1881 ----------------------- 1882 1883 procedure Build_Call_Marker (N : Node_Id) is 1884 function In_External_Context 1885 (Call : Node_Id; 1886 Target_Attrs : Target_Attributes) return Boolean; 1887 pragma Inline (In_External_Context); 1888 -- Determine whether a target described by attributes Target_Attrs is 1889 -- external to call Call which must reside within an instance. 1890 1891 function In_Premature_Context (Call : Node_Id) return Boolean; 1892 -- Determine whether call Call appears within a premature context 1893 1894 function Is_Bridge_Target (Id : Entity_Id) return Boolean; 1895 pragma Inline (Is_Bridge_Target); 1896 -- Determine whether arbitrary entity Id denotes a bridge target 1897 1898 function Is_Default_Expression (Call : Node_Id) return Boolean; 1899 pragma Inline (Is_Default_Expression); 1900 -- Determine whether call Call acts as the expression of a defaulted 1901 -- parameter within a source call. 1902 1903 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 1904 pragma Inline (Is_Generic_Formal_Subp); 1905 -- Determine whether subprogram Subp_Id denotes a generic formal 1906 -- subprogram which appears in the "prologue" of an instantiation. 1907 1908 ------------------------- 1909 -- In_External_Context -- 1910 ------------------------- 1911 1912 function In_External_Context 1913 (Call : Node_Id; 1914 Target_Attrs : Target_Attributes) return Boolean 1915 is 1916 Inst : Node_Id; 1917 Inst_Body : Node_Id; 1918 Inst_Decl : Node_Id; 1919 1920 begin 1921 -- Performance note: parent traversal 1922 1923 Inst := Find_Enclosing_Instance (Call); 1924 1925 -- The call appears within an instance 1926 1927 if Present (Inst) then 1928 1929 -- The call comes from the main unit and the target does not 1930 1931 if In_Extended_Main_Code_Unit (Call) 1932 and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) 1933 then 1934 return True; 1935 1936 -- Otherwise the target declaration must not appear within the 1937 -- instance spec or body. 1938 1939 else 1940 Extract_Instance_Attributes 1941 (Exp_Inst => Inst, 1942 Inst_Decl => Inst_Decl, 1943 Inst_Body => Inst_Body); 1944 1945 -- Performance note: parent traversal 1946 1947 return not In_Subtree 1948 (N => Target_Attrs.Spec_Decl, 1949 Root1 => Inst_Decl, 1950 Root2 => Inst_Body); 1951 end if; 1952 end if; 1953 1954 return False; 1955 end In_External_Context; 1956 1957 -------------------------- 1958 -- In_Premature_Context -- 1959 -------------------------- 1960 1961 function In_Premature_Context (Call : Node_Id) return Boolean is 1962 Par : Node_Id; 1963 1964 begin 1965 -- Climb the parent chain looking for premature contexts 1966 1967 Par := Parent (Call); 1968 while Present (Par) loop 1969 1970 -- Aspect specifications and generic associations are premature 1971 -- contexts because nested calls has not been relocated to their 1972 -- final context. 1973 1974 if Nkind_In (Par, N_Aspect_Specification, 1975 N_Generic_Association) 1976 then 1977 return True; 1978 1979 -- Prevent the search from going too far 1980 1981 elsif Is_Body_Or_Package_Declaration (Par) then 1982 exit; 1983 end if; 1984 1985 Par := Parent (Par); 1986 end loop; 1987 1988 return False; 1989 end In_Premature_Context; 1990 1991 ---------------------- 1992 -- Is_Bridge_Target -- 1993 ---------------------- 1994 1995 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 1996 begin 1997 return 1998 Is_Accept_Alternative_Proc (Id) 1999 or else Is_Finalizer_Proc (Id) 2000 or else Is_Partial_Invariant_Proc (Id) 2001 or else Is_Postconditions_Proc (Id) 2002 or else Is_TSS (Id, TSS_Deep_Adjust) 2003 or else Is_TSS (Id, TSS_Deep_Finalize) 2004 or else Is_TSS (Id, TSS_Deep_Initialize); 2005 end Is_Bridge_Target; 2006 2007 --------------------------- 2008 -- Is_Default_Expression -- 2009 --------------------------- 2010 2011 function Is_Default_Expression (Call : Node_Id) return Boolean is 2012 Outer_Call : constant Node_Id := Parent (Call); 2013 Outer_Nam : Node_Id; 2014 2015 begin 2016 -- To qualify, the node must appear immediately within a source call 2017 -- which invokes a source target. 2018 2019 if Nkind_In (Outer_Call, N_Entry_Call_Statement, 2020 N_Function_Call, 2021 N_Procedure_Call_Statement) 2022 and then Comes_From_Source (Outer_Call) 2023 then 2024 Outer_Nam := Extract_Call_Name (Outer_Call); 2025 2026 return 2027 Is_Entity_Name (Outer_Nam) 2028 and then Present (Entity (Outer_Nam)) 2029 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 2030 and then Comes_From_Source (Entity (Outer_Nam)); 2031 end if; 2032 2033 return False; 2034 end Is_Default_Expression; 2035 2036 ---------------------------- 2037 -- Is_Generic_Formal_Subp -- 2038 ---------------------------- 2039 2040 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 2041 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 2042 Context : constant Node_Id := Parent (Subp_Decl); 2043 2044 begin 2045 -- To qualify, the subprogram must rename a generic actual subprogram 2046 -- where the enclosing context is an instantiation. 2047 2048 return 2049 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 2050 and then not Comes_From_Source (Subp_Decl) 2051 and then Nkind_In (Context, N_Function_Specification, 2052 N_Package_Specification, 2053 N_Procedure_Specification) 2054 and then Present (Generic_Parent (Context)); 2055 end Is_Generic_Formal_Subp; 2056 2057 -- Local variables 2058 2059 Call_Attrs : Call_Attributes; 2060 Call_Nam : Node_Id; 2061 Marker : Node_Id; 2062 Target_Attrs : Target_Attributes; 2063 Target_Id : Entity_Id; 2064 2065 -- Start of processing for Build_Call_Marker 2066 2067 begin 2068 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2069 -- enabled) is in effect because the legacy ABE mechanism does not need 2070 -- to carry out this action. 2071 2072 if Legacy_Elaboration_Checks then 2073 return; 2074 2075 -- Nothing to do for ASIS because ABE checks and diagnostics are not 2076 -- performed in this mode. 2077 2078 elsif ASIS_Mode then 2079 return; 2080 2081 -- Nothing to do when the call is being preanalyzed as the marker will 2082 -- be inserted in the wrong place. 2083 2084 elsif Preanalysis_Active then 2085 return; 2086 2087 -- Nothing to do when the input does not denote a call or a requeue 2088 2089 elsif not Nkind_In (N, N_Entry_Call_Statement, 2090 N_Function_Call, 2091 N_Procedure_Call_Statement, 2092 N_Requeue_Statement) 2093 then 2094 return; 2095 2096 -- Nothing to do when the input denotes entry call or requeue statement, 2097 -- and switch -gnatd_e (ignore entry calls and requeue statements for 2098 -- elaboration) is in effect. 2099 2100 elsif Debug_Flag_Underscore_E 2101 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) 2102 then 2103 return; 2104 end if; 2105 2106 Call_Nam := Extract_Call_Name (N); 2107 2108 -- Nothing to do when the call is erroneous or left in a bad state 2109 2110 if not (Is_Entity_Name (Call_Nam) 2111 and then Present (Entity (Call_Nam)) 2112 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 2113 then 2114 return; 2115 2116 -- Nothing to do when the call invokes a generic formal subprogram and 2117 -- switch -gnatd.G (ignore calls through generic formal parameters for 2118 -- elaboration) is in effect. This check must be performed with the 2119 -- direct target of the call to avoid the side effects of mapping 2120 -- actuals to formals using renamings. 2121 2122 elsif Debug_Flag_Dot_GG 2123 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 2124 then 2125 return; 2126 2127 -- Nothing to do when the call is analyzed/resolved too early within an 2128 -- intermediate context. This check is saved for last because it incurs 2129 -- a performance penalty. 2130 2131 -- Performance note: parent traversal 2132 2133 elsif In_Premature_Context (N) then 2134 return; 2135 end if; 2136 2137 Extract_Call_Attributes 2138 (Call => N, 2139 Target_Id => Target_Id, 2140 Attrs => Call_Attrs); 2141 2142 Extract_Target_Attributes 2143 (Target_Id => Target_Id, 2144 Attrs => Target_Attrs); 2145 2146 -- Nothing to do when the call appears within the expanded spec or 2147 -- body of an instantiated generic, the call does not invoke a generic 2148 -- formal subprogram, the target is external to the instance, and switch 2149 -- -gnatdL (ignore external calls from instances for elaboration) is in 2150 -- effect. 2151 2152 if Debug_Flag_LL 2153 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 2154 2155 -- Performance note: parent traversal 2156 2157 and then In_External_Context 2158 (Call => N, 2159 Target_Attrs => Target_Attrs) 2160 then 2161 return; 2162 2163 -- Nothing to do when the call invokes an assertion pragma procedure 2164 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 2165 -- in effect. 2166 2167 elsif Debug_Flag_Underscore_P 2168 and then Is_Assertion_Pragma_Target (Target_Id) 2169 then 2170 return; 2171 2172 -- Source calls to source targets are always considered because they 2173 -- reflect the original call graph. 2174 2175 elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then 2176 null; 2177 2178 -- A call to a source function which acts as the default expression in 2179 -- another call requires special detection. 2180 2181 elsif Target_Attrs.From_Source 2182 and then Nkind (N) = N_Function_Call 2183 and then Is_Default_Expression (N) 2184 then 2185 null; 2186 2187 -- The target emulates Ada semantics 2188 2189 elsif Is_Ada_Semantic_Target (Target_Id) then 2190 null; 2191 2192 -- The target acts as a link between scenarios 2193 2194 elsif Is_Bridge_Target (Target_Id) then 2195 null; 2196 2197 -- The target emulates SPARK semantics 2198 2199 elsif Is_SPARK_Semantic_Target (Target_Id) then 2200 null; 2201 2202 -- Otherwise the call is not suitable for ABE processing. This prevents 2203 -- the generation of call markers which will never play a role in ABE 2204 -- diagnostics. 2205 2206 else 2207 return; 2208 end if; 2209 2210 -- At this point it is known that the call will play some role in ABE 2211 -- checks and diagnostics. Create a corresponding call marker in case 2212 -- the original call is heavily transformed by expansion later on. 2213 2214 Marker := Make_Call_Marker (Sloc (N)); 2215 2216 -- Inherit the attributes of the original call 2217 2218 Set_Target (Marker, Target_Id); 2219 Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); 2220 Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); 2221 Set_Is_Elaboration_Checks_OK_Node 2222 (Marker, Call_Attrs.Elab_Checks_OK); 2223 Set_Is_Elaboration_Warnings_OK_Node 2224 (Marker, Call_Attrs.Elab_Warnings_OK); 2225 Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); 2226 Set_Is_Source_Call (Marker, Call_Attrs.From_Source); 2227 Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); 2228 2229 -- The marker is inserted prior to the original call. This placement has 2230 -- several desirable effects: 2231 2232 -- 1) The marker appears in the same context, in close proximity to 2233 -- the call. 2234 2235 -- <marker> 2236 -- <call> 2237 2238 -- 2) Inserting the marker prior to the call ensures that an ABE check 2239 -- will take effect prior to the call. 2240 2241 -- <ABE check> 2242 -- <marker> 2243 -- <call> 2244 2245 -- 3) The above two properties are preserved even when the call is a 2246 -- function which is subsequently relocated in order to capture its 2247 -- result. Note that if the call is relocated to a new context, the 2248 -- relocated call will receive a marker of its own. 2249 2250 -- <ABE check> 2251 -- <maker> 2252 -- Temp : ... := Func_Call ...; 2253 -- ... Temp ... 2254 2255 -- The insertion must take place even when the call does not occur in 2256 -- the main unit to keep the tree symmetric. This ensures that internal 2257 -- name serialization is consistent in case the call marker causes the 2258 -- tree to transform in some way. 2259 2260 Insert_Action (N, Marker); 2261 2262 -- The marker becomes the "corresponding" scenario for the call. Save 2263 -- the marker for later processing by the ABE phase. 2264 2265 Record_Elaboration_Scenario (Marker); 2266 end Build_Call_Marker; 2267 2268 ------------------------------------- 2269 -- Build_Variable_Reference_Marker -- 2270 ------------------------------------- 2271 2272 procedure Build_Variable_Reference_Marker 2273 (N : Node_Id; 2274 Read : Boolean; 2275 Write : Boolean) 2276 is 2277 Marker : Node_Id; 2278 Var_Attrs : Variable_Attributes; 2279 Var_Id : Entity_Id; 2280 2281 begin 2282 Extract_Variable_Reference_Attributes 2283 (Ref => N, 2284 Var_Id => Var_Id, 2285 Attrs => Var_Attrs); 2286 2287 Marker := Make_Variable_Reference_Marker (Sloc (N)); 2288 2289 -- Inherit the attributes of the original variable reference 2290 2291 Set_Target (Marker, Var_Id); 2292 Set_Is_Read (Marker, Read); 2293 Set_Is_Write (Marker, Write); 2294 2295 -- The marker is inserted prior to the original variable reference. The 2296 -- insertion must take place even when the reference does not occur in 2297 -- the main unit to keep the tree symmetric. This ensures that internal 2298 -- name serialization is consistent in case the variable marker causes 2299 -- the tree to transform in some way. 2300 2301 Insert_Action (N, Marker); 2302 2303 -- The marker becomes the "corresponding" scenario for the reference. 2304 -- Save the marker for later processing for the ABE phase. 2305 2306 Record_Elaboration_Scenario (Marker); 2307 end Build_Variable_Reference_Marker; 2308 2309 --------------------------------- 2310 -- Check_Elaboration_Scenarios -- 2311 --------------------------------- 2312 2313 procedure Check_Elaboration_Scenarios is 2314 begin 2315 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2316 -- enabled) is in effect because the legacy ABE mechanism does not need 2317 -- to carry out this action. 2318 2319 if Legacy_Elaboration_Checks then 2320 return; 2321 2322 -- Nothing to do for ASIS because ABE checks and diagnostics are not 2323 -- performed in this mode. 2324 2325 elsif ASIS_Mode then 2326 return; 2327 end if; 2328 2329 -- Restore the original elaboration model which was in effect when the 2330 -- scenarios were first recorded. The model may be specified by pragma 2331 -- Elaboration_Checks which appears on the initial declaration of the 2332 -- main unit. 2333 2334 Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); 2335 2336 -- Examine the context of the main unit and record all units with prior 2337 -- elaboration with respect to it. 2338 2339 Find_Elaborated_Units; 2340 2341 -- Examine each top-level scenario saved during the Recording phase for 2342 -- conditional ABEs and perform various actions depending on the model 2343 -- in effect. The table of visited bodies is created for each new top- 2344 -- level scenario. 2345 2346 for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop 2347 Reset_Visited_Bodies; 2348 2349 Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); 2350 end loop; 2351 2352 -- Examine each SPARK scenario saved during the Recording phase which 2353 -- is not necessarily executable during elaboration, but still requires 2354 -- elaboration-related checks. 2355 2356 for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop 2357 Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); 2358 end loop; 2359 end Check_Elaboration_Scenarios; 2360 2361 ------------------------------ 2362 -- Check_Preelaborated_Call -- 2363 ------------------------------ 2364 2365 procedure Check_Preelaborated_Call (Call : Node_Id) is 2366 function In_Preelaborated_Context (N : Node_Id) return Boolean; 2367 -- Determine whether arbitrary node appears in a preelaborated context 2368 2369 ------------------------------ 2370 -- In_Preelaborated_Context -- 2371 ------------------------------ 2372 2373 function In_Preelaborated_Context (N : Node_Id) return Boolean is 2374 Body_Id : constant Entity_Id := Find_Code_Unit (N); 2375 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 2376 2377 begin 2378 -- The node appears within a package body whose corresponding spec is 2379 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 2380 -- not result in a preelaborated context because the package body may 2381 -- be on another machine. 2382 2383 if Ekind (Body_Id) = E_Package_Body 2384 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) 2385 and then (Is_Remote_Call_Interface (Spec_Id) 2386 or else Is_Remote_Types (Spec_Id)) 2387 then 2388 return False; 2389 2390 -- Otherwise the node appears within a preelaborated context when the 2391 -- associated unit is preelaborated. 2392 2393 else 2394 return Is_Preelaborated_Unit (Spec_Id); 2395 end if; 2396 end In_Preelaborated_Context; 2397 2398 -- Local variables 2399 2400 Call_Attrs : Call_Attributes; 2401 Level : Enclosing_Level_Kind; 2402 Target_Id : Entity_Id; 2403 2404 -- Start of processing for Check_Preelaborated_Call 2405 2406 begin 2407 Extract_Call_Attributes 2408 (Call => Call, 2409 Target_Id => Target_Id, 2410 Attrs => Call_Attrs); 2411 2412 -- Nothing to do when the call is internally generated because it is 2413 -- assumed that it will never violate preelaboration. 2414 2415 if not Call_Attrs.From_Source then 2416 return; 2417 end if; 2418 2419 -- Performance note: parent traversal 2420 2421 Level := Find_Enclosing_Level (Call); 2422 2423 -- Library-level calls are always considered because they are part of 2424 -- the associated unit's elaboration actions. 2425 2426 if Level in Library_Level then 2427 null; 2428 2429 -- Calls at the library level of a generic package body must be checked 2430 -- because they would render an instantiation illegal if the template is 2431 -- marked as preelaborated. Note that this does not apply to calls at 2432 -- the library level of a generic package spec. 2433 2434 elsif Level = Generic_Package_Body then 2435 null; 2436 2437 -- Otherwise the call does not appear at the proper level and must not 2438 -- be considered for this check. 2439 2440 else 2441 return; 2442 end if; 2443 2444 -- The call appears within a preelaborated unit. Emit a warning only for 2445 -- internal uses, otherwise this is an error. 2446 2447 if In_Preelaborated_Context (Call) then 2448 Error_Msg_Warn := GNAT_Mode; 2449 Error_Msg_N 2450 ("<<non-static call not allowed in preelaborated unit", Call); 2451 end if; 2452 end Check_Preelaborated_Call; 2453 2454 ------------------------------ 2455 -- Check_SPARK_Derived_Type -- 2456 ------------------------------ 2457 2458 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is 2459 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 2460 2461 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally 2462 -- unnested to avoid deep indentation of code. 2463 2464 Stop_Check : exception; 2465 -- This exception is raised when the freeze node violates the placement 2466 -- rules. 2467 2468 procedure Check_Overriding_Primitive 2469 (Prim : Entity_Id; 2470 FNode : Node_Id); 2471 pragma Inline (Check_Overriding_Primitive); 2472 -- Verify that freeze node FNode is within the early call region of 2473 -- overriding primitive Prim's body. 2474 2475 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 2476 pragma Inline (Freeze_Node_Location); 2477 -- Return a more accurate source location associated with freeze node 2478 -- FNode. 2479 2480 function Precedes_Source_Construct (N : Node_Id) return Boolean; 2481 pragma Inline (Precedes_Source_Construct); 2482 -- Determine whether arbitrary node N appears prior to some source 2483 -- construct. 2484 2485 procedure Suggest_Elaborate_Body 2486 (N : Node_Id; 2487 Body_Decl : Node_Id; 2488 Error_Nod : Node_Id); 2489 pragma Inline (Suggest_Elaborate_Body); 2490 -- Suggest the use of pragma Elaborate_Body when the pragma will allow 2491 -- for node N to appear within the early call region of subprogram body 2492 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation 2493 -- error. 2494 2495 -------------------------------- 2496 -- Check_Overriding_Primitive -- 2497 -------------------------------- 2498 2499 procedure Check_Overriding_Primitive 2500 (Prim : Entity_Id; 2501 FNode : Node_Id) 2502 is 2503 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 2504 Body_Decl : Node_Id; 2505 Body_Id : Entity_Id; 2506 Region : Node_Id; 2507 2508 begin 2509 -- Nothing to do for predefined primitives because they are artifacts 2510 -- of tagged type expansion and cannot override source primitives. 2511 2512 if Is_Predefined_Dispatching_Operation (Prim) then 2513 return; 2514 end if; 2515 2516 Body_Id := Corresponding_Body (Prim_Decl); 2517 2518 -- Nothing to do when the primitive does not have a corresponding 2519 -- body. This can happen when the unit with the bodies is not the 2520 -- main unit subjected to ABE checks. 2521 2522 if No (Body_Id) then 2523 return; 2524 2525 -- The primitive overrides a parent or progenitor primitive 2526 2527 elsif Present (Overridden_Operation (Prim)) then 2528 2529 -- Nothing to do when overriding an interface primitive happens by 2530 -- inheriting a non-interface primitive as the check would be done 2531 -- on the parent primitive. 2532 2533 if Present (Alias (Prim)) then 2534 return; 2535 end if; 2536 2537 -- Nothing to do when the primitive is not overriding. The body of 2538 -- such a primitive cannot be targeted by a dispatching call which 2539 -- is executable during elaboration, and cannot cause an ABE. 2540 2541 else 2542 return; 2543 end if; 2544 2545 Body_Decl := Unit_Declaration_Node (Body_Id); 2546 Region := Find_Early_Call_Region (Body_Decl); 2547 2548 -- The freeze node appears prior to the early call region of the 2549 -- primitive body. 2550 2551 -- IMPORTANT: This check must always be performed even when -gnatd.v 2552 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2553 -- because the static model cannot guarantee the absence of ABEs in 2554 -- in the presence of dispatching calls. 2555 2556 if Earlier_In_Extended_Unit (FNode, Region) then 2557 Error_Msg_Node_2 := Prim; 2558 Error_Msg_NE 2559 ("first freezing point of type & must appear within early call " 2560 & "region of primitive body & (SPARK RM 7.7(8))", 2561 Typ_Decl, Typ); 2562 2563 Error_Msg_Sloc := Sloc (Region); 2564 Error_Msg_N ("\region starts #", Typ_Decl); 2565 2566 Error_Msg_Sloc := Sloc (Body_Decl); 2567 Error_Msg_N ("\region ends #", Typ_Decl); 2568 2569 Error_Msg_Sloc := Freeze_Node_Location (FNode); 2570 Error_Msg_N ("\first freezing point #", Typ_Decl); 2571 2572 -- If applicable, suggest the use of pragma Elaborate_Body in the 2573 -- associated package spec. 2574 2575 Suggest_Elaborate_Body 2576 (N => FNode, 2577 Body_Decl => Body_Decl, 2578 Error_Nod => Typ_Decl); 2579 2580 raise Stop_Check; 2581 end if; 2582 end Check_Overriding_Primitive; 2583 2584 -------------------------- 2585 -- Freeze_Node_Location -- 2586 -------------------------- 2587 2588 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 2589 Context : constant Node_Id := Parent (FNode); 2590 Loc : constant Source_Ptr := Sloc (FNode); 2591 2592 Prv_Decls : List_Id; 2593 Vis_Decls : List_Id; 2594 2595 begin 2596 -- In general, the source location of the freeze node is as close as 2597 -- possible to the real freeze point, except when the freeze node is 2598 -- at the "bottom" of a package spec. 2599 2600 if Nkind (Context) = N_Package_Specification then 2601 Prv_Decls := Private_Declarations (Context); 2602 Vis_Decls := Visible_Declarations (Context); 2603 2604 -- The freeze node appears in the private declarations of the 2605 -- package. 2606 2607 if Present (Prv_Decls) 2608 and then List_Containing (FNode) = Prv_Decls 2609 then 2610 null; 2611 2612 -- The freeze node appears in the visible declarations of the 2613 -- package and there are no private declarations. 2614 2615 elsif Present (Vis_Decls) 2616 and then List_Containing (FNode) = Vis_Decls 2617 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 2618 then 2619 null; 2620 2621 -- Otherwise the freeze node is not in the "last" declarative list 2622 -- of the package. Use the existing source location of the freeze 2623 -- node. 2624 2625 else 2626 return Loc; 2627 end if; 2628 2629 -- The freeze node appears at the "bottom" of the package when it 2630 -- is in the "last" declarative list and is either the last in the 2631 -- list or is followed by internal constructs only. In that case 2632 -- the more appropriate source location is that of the package end 2633 -- label. 2634 2635 if not Precedes_Source_Construct (FNode) then 2636 return Sloc (End_Label (Context)); 2637 end if; 2638 end if; 2639 2640 return Loc; 2641 end Freeze_Node_Location; 2642 2643 ------------------------------- 2644 -- Precedes_Source_Construct -- 2645 ------------------------------- 2646 2647 function Precedes_Source_Construct (N : Node_Id) return Boolean is 2648 Decl : Node_Id; 2649 2650 begin 2651 Decl := Next (N); 2652 while Present (Decl) loop 2653 if Comes_From_Source (Decl) then 2654 return True; 2655 2656 -- A generated body for a source expression function is treated as 2657 -- a source construct. 2658 2659 elsif Nkind (Decl) = N_Subprogram_Body 2660 and then Was_Expression_Function (Decl) 2661 and then Comes_From_Source (Original_Node (Decl)) 2662 then 2663 return True; 2664 end if; 2665 2666 Next (Decl); 2667 end loop; 2668 2669 return False; 2670 end Precedes_Source_Construct; 2671 2672 ---------------------------- 2673 -- Suggest_Elaborate_Body -- 2674 ---------------------------- 2675 2676 procedure Suggest_Elaborate_Body 2677 (N : Node_Id; 2678 Body_Decl : Node_Id; 2679 Error_Nod : Node_Id) 2680 is 2681 Unt : constant Node_Id := Unit (Cunit (Main_Unit)); 2682 Region : Node_Id; 2683 2684 begin 2685 -- The suggestion applies only when the subprogram body resides in a 2686 -- compilation package body, and a pragma Elaborate_Body would allow 2687 -- for the node to appear in the early call region of the subprogram 2688 -- body. This implies that all code from the subprogram body up to 2689 -- the node is preelaborable. 2690 2691 if Nkind (Unt) = N_Package_Body then 2692 2693 -- Find the start of the early call region again assuming that the 2694 -- package spec has pragma Elaborate_Body. Note that the internal 2695 -- data structures are intentionally not updated because this is a 2696 -- speculative search. 2697 2698 Region := 2699 Find_Early_Call_Region 2700 (Body_Decl => Body_Decl, 2701 Assume_Elab_Body => True, 2702 Skip_Memoization => True); 2703 2704 -- If the node appears within the early call region, assuming that 2705 -- the package spec carries pragma Elaborate_Body, then it is safe 2706 -- to suggest the pragma. 2707 2708 if Earlier_In_Extended_Unit (Region, N) then 2709 Error_Msg_Name_1 := Name_Elaborate_Body; 2710 Error_Msg_NE 2711 ("\consider adding pragma % in spec of unit &", 2712 Error_Nod, Defining_Entity (Unt)); 2713 end if; 2714 end if; 2715 end Suggest_Elaborate_Body; 2716 2717 -- Local variables 2718 2719 FNode : constant Node_Id := Freeze_Node (Typ); 2720 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 2721 2722 Prim_Elmt : Elmt_Id; 2723 2724 -- Start of processing for Check_SPARK_Derived_Type 2725 2726 begin 2727 -- A type should have its freeze node set by the time SPARK scenarios 2728 -- are being verified. 2729 2730 pragma Assert (Present (FNode)); 2731 2732 -- Verify that the freeze node of the derived type is within the early 2733 -- call region of each overriding primitive body (SPARK RM 7.7(8)). 2734 2735 if Present (Prims) then 2736 Prim_Elmt := First_Elmt (Prims); 2737 while Present (Prim_Elmt) loop 2738 Check_Overriding_Primitive 2739 (Prim => Node (Prim_Elmt), 2740 FNode => FNode); 2741 2742 Next_Elmt (Prim_Elmt); 2743 end loop; 2744 end if; 2745 2746 exception 2747 when Stop_Check => 2748 null; 2749 end Check_SPARK_Derived_Type; 2750 2751 ------------------------------- 2752 -- Check_SPARK_Instantiation -- 2753 ------------------------------- 2754 2755 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is 2756 Gen_Attrs : Target_Attributes; 2757 Gen_Id : Entity_Id; 2758 Inst : Node_Id; 2759 Inst_Attrs : Instantiation_Attributes; 2760 Inst_Id : Entity_Id; 2761 2762 begin 2763 Extract_Instantiation_Attributes 2764 (Exp_Inst => Exp_Inst, 2765 Inst => Inst, 2766 Inst_Id => Inst_Id, 2767 Gen_Id => Gen_Id, 2768 Attrs => Inst_Attrs); 2769 2770 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 2771 2772 -- The instantiation and the generic body are both in the main unit 2773 2774 if Present (Gen_Attrs.Body_Decl) 2775 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 2776 2777 -- If the instantiation appears prior to the generic body, then the 2778 -- instantiation is illegal (SPARK RM 7.7(6)). 2779 2780 -- IMPORTANT: This check must always be performed even when -gnatd.v 2781 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2782 -- because the rule prevents use-before-declaration of objects that 2783 -- may precede the generic body. 2784 2785 and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) 2786 then 2787 Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); 2788 end if; 2789 end Check_SPARK_Instantiation; 2790 2791 --------------------------------- 2792 -- Check_SPARK_Model_In_Effect -- 2793 --------------------------------- 2794 2795 SPARK_Model_Warning_Posted : Boolean := False; 2796 -- This flag prevents the same SPARK model-related warning from being 2797 -- emitted multiple times. 2798 2799 procedure Check_SPARK_Model_In_Effect (N : Node_Id) is 2800 begin 2801 -- Do not emit the warning multiple times as this creates useless noise 2802 2803 if SPARK_Model_Warning_Posted then 2804 null; 2805 2806 -- SPARK rule verification requires the "strict" static model 2807 2808 elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then 2809 null; 2810 2811 -- Any other combination of models does not guarantee the absence of ABE 2812 -- problems for SPARK rule verification purposes. Note that there is no 2813 -- need to check for the legacy ABE mechanism because the legacy code 2814 -- has its own orthogonal processing for SPARK rules. 2815 2816 else 2817 SPARK_Model_Warning_Posted := True; 2818 2819 Error_Msg_N 2820 ("??SPARK elaboration checks require static elaboration model", N); 2821 2822 if Dynamic_Elaboration_Checks then 2823 Error_Msg_N ("\dynamic elaboration model is in effect", N); 2824 else 2825 pragma Assert (Relaxed_Elaboration_Checks); 2826 Error_Msg_N ("\relaxed elaboration model is in effect", N); 2827 end if; 2828 end if; 2829 end Check_SPARK_Model_In_Effect; 2830 2831 -------------------------- 2832 -- Check_SPARK_Scenario -- 2833 -------------------------- 2834 2835 procedure Check_SPARK_Scenario (N : Node_Id) is 2836 begin 2837 -- Ensure that a suitable elaboration model is in effect for SPARK rule 2838 -- verification. 2839 2840 Check_SPARK_Model_In_Effect (N); 2841 2842 -- Add the current scenario to the stack of active scenarios 2843 2844 Push_Active_Scenario (N); 2845 2846 if Is_Suitable_SPARK_Derived_Type (N) then 2847 Check_SPARK_Derived_Type (N); 2848 2849 elsif Is_Suitable_SPARK_Instantiation (N) then 2850 Check_SPARK_Instantiation (N); 2851 2852 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 2853 Check_SPARK_Refined_State_Pragma (N); 2854 end if; 2855 2856 -- Remove the current scenario from the stack of active scenarios once 2857 -- all ABE diagnostics and checks have been performed. 2858 2859 Pop_Active_Scenario (N); 2860 end Check_SPARK_Scenario; 2861 2862 -------------------------------------- 2863 -- Check_SPARK_Refined_State_Pragma -- 2864 -------------------------------------- 2865 2866 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is 2867 2868 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are 2869 -- intentionally unnested to avoid deep indentation of code. 2870 2871 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 2872 pragma Inline (Check_SPARK_Constituent); 2873 -- Ensure that a single constituent Constit_Id is elaborated prior to 2874 -- the main unit. 2875 2876 procedure Check_SPARK_Constituents (Constits : Elist_Id); 2877 pragma Inline (Check_SPARK_Constituents); 2878 -- Ensure that all constituents found in list Constits are elaborated 2879 -- prior to the main unit. 2880 2881 procedure Check_SPARK_Initialized_State (State : Node_Id); 2882 pragma Inline (Check_SPARK_Initialized_State); 2883 -- Ensure that the constituents of single abstract state State are 2884 -- elaborated prior to the main unit. 2885 2886 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 2887 pragma Inline (Check_SPARK_Initialized_States); 2888 -- Ensure that the constituents of all abstract states which appear in 2889 -- the Initializes pragma of package Pack_Id are elaborated prior to the 2890 -- main unit. 2891 2892 ----------------------------- 2893 -- Check_SPARK_Constituent -- 2894 ----------------------------- 2895 2896 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 2897 Prag : Node_Id; 2898 2899 begin 2900 -- Nothing to do for "null" constituents 2901 2902 if Nkind (Constit_Id) = N_Null then 2903 return; 2904 2905 -- Nothing to do for illegal constituents 2906 2907 elsif Error_Posted (Constit_Id) then 2908 return; 2909 end if; 2910 2911 Prag := SPARK_Pragma (Constit_Id); 2912 2913 -- The check applies only when the constituent is subject to pragma 2914 -- SPARK_Mode On. 2915 2916 if Present (Prag) 2917 and then Get_SPARK_Mode_From_Annotation (Prag) = On 2918 then 2919 -- An external constituent of an abstract state which appears in 2920 -- the Initializes pragma of a package spec imposes an Elaborate 2921 -- requirement on the context of the main unit. Determine whether 2922 -- the context has a pragma strong enough to meet the requirement. 2923 2924 -- IMPORTANT: This check is performed only when -gnatd.v (enforce 2925 -- SPARK elaboration rules in SPARK code) is in effect because the 2926 -- static model can ensure the prior elaboration of the unit which 2927 -- contains a constituent by installing implicit Elaborate pragma. 2928 2929 if Debug_Flag_Dot_V then 2930 Meet_Elaboration_Requirement 2931 (N => N, 2932 Target_Id => Constit_Id, 2933 Req_Nam => Name_Elaborate); 2934 2935 -- Otherwise ensure that the unit with the external constituent is 2936 -- elaborated prior to the main unit. 2937 2938 else 2939 Ensure_Prior_Elaboration 2940 (N => N, 2941 Unit_Id => Find_Top_Unit (Constit_Id), 2942 Prag_Nam => Name_Elaborate, 2943 State => Initial_State); 2944 end if; 2945 end if; 2946 end Check_SPARK_Constituent; 2947 2948 ------------------------------ 2949 -- Check_SPARK_Constituents -- 2950 ------------------------------ 2951 2952 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 2953 Constit_Elmt : Elmt_Id; 2954 2955 begin 2956 if Present (Constits) then 2957 Constit_Elmt := First_Elmt (Constits); 2958 while Present (Constit_Elmt) loop 2959 Check_SPARK_Constituent (Node (Constit_Elmt)); 2960 Next_Elmt (Constit_Elmt); 2961 end loop; 2962 end if; 2963 end Check_SPARK_Constituents; 2964 2965 ----------------------------------- 2966 -- Check_SPARK_Initialized_State -- 2967 ----------------------------------- 2968 2969 procedure Check_SPARK_Initialized_State (State : Node_Id) is 2970 Prag : Node_Id; 2971 State_Id : Entity_Id; 2972 2973 begin 2974 -- Nothing to do for "null" initialization items 2975 2976 if Nkind (State) = N_Null then 2977 return; 2978 2979 -- Nothing to do for illegal states 2980 2981 elsif Error_Posted (State) then 2982 return; 2983 end if; 2984 2985 State_Id := Entity_Of (State); 2986 2987 -- Sanitize the state 2988 2989 if No (State_Id) then 2990 return; 2991 2992 elsif Error_Posted (State_Id) then 2993 return; 2994 2995 elsif Ekind (State_Id) /= E_Abstract_State then 2996 return; 2997 end if; 2998 2999 -- The check is performed only when the abstract state is subject to 3000 -- SPARK_Mode On. 3001 3002 Prag := SPARK_Pragma (State_Id); 3003 3004 if Present (Prag) 3005 and then Get_SPARK_Mode_From_Annotation (Prag) = On 3006 then 3007 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 3008 end if; 3009 end Check_SPARK_Initialized_State; 3010 3011 ------------------------------------ 3012 -- Check_SPARK_Initialized_States -- 3013 ------------------------------------ 3014 3015 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 3016 Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); 3017 Init : Node_Id; 3018 Inits : Node_Id; 3019 3020 begin 3021 if Present (Prag) then 3022 Inits := Expression (Get_Argument (Prag, Pack_Id)); 3023 3024 -- Avoid processing a "null" initialization list. The only other 3025 -- alternative is an aggregate. 3026 3027 if Nkind (Inits) = N_Aggregate then 3028 3029 -- The initialization items appear in list form: 3030 -- 3031 -- (state1, state2) 3032 3033 if Present (Expressions (Inits)) then 3034 Init := First (Expressions (Inits)); 3035 while Present (Init) loop 3036 Check_SPARK_Initialized_State (Init); 3037 Next (Init); 3038 end loop; 3039 end if; 3040 3041 -- The initialization items appear in associated form: 3042 -- 3043 -- (state1 => item1, 3044 -- state2 => (item2, item3)) 3045 3046 if Present (Component_Associations (Inits)) then 3047 Init := First (Component_Associations (Inits)); 3048 while Present (Init) loop 3049 Check_SPARK_Initialized_State (Init); 3050 Next (Init); 3051 end loop; 3052 end if; 3053 end if; 3054 end if; 3055 end Check_SPARK_Initialized_States; 3056 3057 -- Local variables 3058 3059 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); 3060 3061 -- Start of processing for Check_SPARK_Refined_State_Pragma 3062 3063 begin 3064 -- Pragma Refined_State must be associated with a package body 3065 3066 pragma Assert 3067 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 3068 3069 -- Verify that each external contitunent of an abstract state mentioned 3070 -- in pragma Initializes is properly elaborated. 3071 3072 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 3073 end Check_SPARK_Refined_State_Pragma; 3074 3075 ---------------------- 3076 -- Compilation_Unit -- 3077 ---------------------- 3078 3079 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is 3080 Comp_Unit : Node_Id; 3081 3082 begin 3083 Comp_Unit := Parent (Unit_Id); 3084 3085 -- Handle the case where a concurrent subunit is rewritten as a null 3086 -- statement due to expansion activities. 3087 3088 if Nkind (Comp_Unit) = N_Null_Statement 3089 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, 3090 N_Task_Body) 3091 then 3092 Comp_Unit := Parent (Comp_Unit); 3093 pragma Assert (Nkind (Comp_Unit) = N_Subunit); 3094 3095 -- Otherwise use the declaration node of the unit 3096 3097 else 3098 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); 3099 end if; 3100 3101 -- Handle the case where a subprogram instantiation which acts as a 3102 -- compilation unit is expanded into an anonymous package that wraps 3103 -- the instantiated subprogram. 3104 3105 if Nkind (Comp_Unit) = N_Package_Specification 3106 and then Nkind_In (Original_Node (Parent (Comp_Unit)), 3107 N_Function_Instantiation, 3108 N_Procedure_Instantiation) 3109 then 3110 Comp_Unit := Parent (Parent (Comp_Unit)); 3111 3112 -- Handle the case where the compilation unit is a subunit 3113 3114 elsif Nkind (Comp_Unit) = N_Subunit then 3115 Comp_Unit := Parent (Comp_Unit); 3116 end if; 3117 3118 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 3119 3120 return Comp_Unit; 3121 end Compilation_Unit; 3122 3123 ----------------------- 3124 -- Early_Call_Region -- 3125 ----------------------- 3126 3127 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 3128 begin 3129 pragma Assert (Ekind_In (Body_Id, E_Entry, 3130 E_Entry_Family, 3131 E_Function, 3132 E_Procedure, 3133 E_Subprogram_Body)); 3134 3135 if Early_Call_Regions_In_Use then 3136 return Early_Call_Regions.Get (Body_Id); 3137 end if; 3138 3139 return Early_Call_Regions_No_Element; 3140 end Early_Call_Region; 3141 3142 ----------------------------- 3143 -- Early_Call_Regions_Hash -- 3144 ----------------------------- 3145 3146 function Early_Call_Regions_Hash 3147 (Key : Entity_Id) return Early_Call_Regions_Index 3148 is 3149 begin 3150 return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); 3151 end Early_Call_Regions_Hash; 3152 3153 ----------------- 3154 -- Elab_Msg_NE -- 3155 ----------------- 3156 3157 procedure Elab_Msg_NE 3158 (Msg : String; 3159 N : Node_Id; 3160 Id : Entity_Id; 3161 Info_Msg : Boolean; 3162 In_SPARK : Boolean) 3163 is 3164 function Prefix return String; 3165 -- Obtain the prefix of the message 3166 3167 function Suffix return String; 3168 -- Obtain the suffix of the message 3169 3170 ------------ 3171 -- Prefix -- 3172 ------------ 3173 3174 function Prefix return String is 3175 begin 3176 if Info_Msg then 3177 return "info: "; 3178 else 3179 return ""; 3180 end if; 3181 end Prefix; 3182 3183 ------------ 3184 -- Suffix -- 3185 ------------ 3186 3187 function Suffix return String is 3188 begin 3189 if In_SPARK then 3190 return " in SPARK"; 3191 else 3192 return ""; 3193 end if; 3194 end Suffix; 3195 3196 -- Start of processing for Elab_Msg_NE 3197 3198 begin 3199 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 3200 end Elab_Msg_NE; 3201 3202 ------------------------ 3203 -- Elaboration_Status -- 3204 ------------------------ 3205 3206 function Elaboration_Status 3207 (Unit_Id : Entity_Id) return Elaboration_Attributes 3208 is 3209 begin 3210 if Elaboration_Statuses_In_Use then 3211 return Elaboration_Statuses.Get (Unit_Id); 3212 end if; 3213 3214 return Elaboration_Statuses_No_Element; 3215 end Elaboration_Status; 3216 3217 ------------------------------- 3218 -- Elaboration_Statuses_Hash -- 3219 ------------------------------- 3220 3221 function Elaboration_Statuses_Hash 3222 (Key : Entity_Id) return Elaboration_Statuses_Index 3223 is 3224 begin 3225 return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); 3226 end Elaboration_Statuses_Hash; 3227 3228 ------------------------------ 3229 -- Ensure_Prior_Elaboration -- 3230 ------------------------------ 3231 3232 procedure Ensure_Prior_Elaboration 3233 (N : Node_Id; 3234 Unit_Id : Entity_Id; 3235 Prag_Nam : Name_Id; 3236 State : Processing_Attributes) 3237 is 3238 begin 3239 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); 3240 3241 -- Nothing to do when the caller has suppressed the generation of 3242 -- implicit Elaborate[_All] pragmas. 3243 3244 if State.Suppress_Implicit_Pragmas then 3245 return; 3246 3247 -- Nothing to do when the need for prior elaboration came from a partial 3248 -- finalization routine which occurs in an initialization context. This 3249 -- behaviour parallels that of the old ABE mechanism. 3250 3251 elsif State.Within_Partial_Finalization then 3252 return; 3253 3254 -- Nothing to do when the need for prior elaboration came from a task 3255 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 3256 -- task bodies) is in effect. 3257 3258 elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then 3259 return; 3260 3261 -- Nothing to do when the unit is elaborated prior to the main unit. 3262 -- This check must also consider the following cases: 3263 3264 -- * No check is made against the context of the main unit because this 3265 -- is specific to the elaboration model in effect and requires custom 3266 -- handling (see Ensure_xxx_Prior_Elaboration). 3267 3268 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 3269 -- Elaborate[_All] MUST be generated even though Unit_Id is always 3270 -- elaborated prior to the main unit. This is a conservative strategy 3271 -- which ensures that other units withed by Unit_Id will not lead to 3272 -- an ABE. 3273 3274 -- package A is package body A is 3275 -- procedure ABE; procedure ABE is ... end ABE; 3276 -- end A; end A; 3277 3278 -- with A; 3279 -- package B is package body B is 3280 -- pragma Elaborate_Body; procedure Proc is 3281 -- begin 3282 -- procedure Proc; A.ABE; 3283 -- package B; end Proc; 3284 -- end B; 3285 3286 -- with B; 3287 -- package C is package body C is 3288 -- ... ... 3289 -- end C; begin 3290 -- B.Proc; 3291 -- end C; 3292 3293 -- In the example above, the elaboration of C invokes B.Proc. B is 3294 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is 3295 -- generated for B in C, then the following elaboratio order will lead 3296 -- to an ABE: 3297 3298 -- spec of A elaborated 3299 -- spec of B elaborated 3300 -- body of B elaborated 3301 -- spec of C elaborated 3302 -- body of C elaborated <-- calls B.Proc which calls A.ABE 3303 -- body of A elaborated <-- problem 3304 3305 -- The generation of an implicit pragma Elaborate_All (B) ensures that 3306 -- the elaboration order mechanism will not pick the above order. 3307 3308 -- An implicit Elaborate is NOT generated when the unit is subject to 3309 -- Elaborate_Body because both pragmas have the exact same effect. 3310 3311 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST 3312 -- NOT be generated in this case because a unit cannot depend on its 3313 -- own elaboration. This case is therefore treated as valid prior 3314 -- elaboration. 3315 3316 elsif Has_Prior_Elaboration 3317 (Unit_Id => Unit_Id, 3318 Same_Unit_OK => True, 3319 Elab_Body_OK => Prag_Nam = Name_Elaborate) 3320 then 3321 return; 3322 3323 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 3324 -- effect. 3325 3326 elsif Dynamic_Elaboration_Checks then 3327 Ensure_Prior_Elaboration_Dynamic 3328 (N => N, 3329 Unit_Id => Unit_Id, 3330 Prag_Nam => Prag_Nam); 3331 3332 -- Install an implicit pragma Prag_Nam when the static model is in 3333 -- effect. 3334 3335 else 3336 pragma Assert (Static_Elaboration_Checks); 3337 3338 Ensure_Prior_Elaboration_Static 3339 (N => N, 3340 Unit_Id => Unit_Id, 3341 Prag_Nam => Prag_Nam); 3342 end if; 3343 end Ensure_Prior_Elaboration; 3344 3345 -------------------------------------- 3346 -- Ensure_Prior_Elaboration_Dynamic -- 3347 -------------------------------------- 3348 3349 procedure Ensure_Prior_Elaboration_Dynamic 3350 (N : Node_Id; 3351 Unit_Id : Entity_Id; 3352 Prag_Nam : Name_Id) 3353 is 3354 procedure Info_Missing_Pragma; 3355 pragma Inline (Info_Missing_Pragma); 3356 -- Output information concerning missing Elaborate or Elaborate_All 3357 -- pragma with name Prag_Nam for scenario N, which would ensure the 3358 -- prior elaboration of Unit_Id. 3359 3360 ------------------------- 3361 -- Info_Missing_Pragma -- 3362 ------------------------- 3363 3364 procedure Info_Missing_Pragma is 3365 begin 3366 -- Internal units are ignored as they cause unnecessary noise 3367 3368 if not In_Internal_Unit (Unit_Id) then 3369 3370 -- The name of the unit subjected to the elaboration pragma is 3371 -- fully qualified to improve the clarity of the info message. 3372 3373 Error_Msg_Name_1 := Prag_Nam; 3374 Error_Msg_Qual_Level := Nat'Last; 3375 3376 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 3377 Error_Msg_Qual_Level := 0; 3378 end if; 3379 end Info_Missing_Pragma; 3380 3381 -- Local variables 3382 3383 Elab_Attrs : Elaboration_Attributes; 3384 Level : Enclosing_Level_Kind; 3385 3386 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 3387 3388 begin 3389 Elab_Attrs := Elaboration_Status (Unit_Id); 3390 3391 -- Nothing to do when the unit is guaranteed prior elaboration by means 3392 -- of a source Elaborate[_All] pragma. 3393 3394 if Present (Elab_Attrs.Source_Pragma) then 3395 return; 3396 end if; 3397 3398 -- Output extra information on a missing Elaborate[_All] pragma when 3399 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 3400 -- is in effect. 3401 3402 if Elab_Info_Messages then 3403 3404 -- Performance note: parent traversal 3405 3406 Level := Find_Enclosing_Level (N); 3407 3408 -- Declaration-level scenario 3409 3410 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 3411 and then Level = Declaration_Level 3412 then 3413 null; 3414 3415 -- Library-level scenario 3416 3417 elsif Level in Library_Level then 3418 null; 3419 3420 -- Instantiation library-level scenario 3421 3422 elsif Level = Instantiation then 3423 null; 3424 3425 -- Otherwise the scenario does not appear at the proper level and 3426 -- cannot possibly act as a top-level scenario. 3427 3428 else 3429 return; 3430 end if; 3431 3432 Info_Missing_Pragma; 3433 end if; 3434 end Ensure_Prior_Elaboration_Dynamic; 3435 3436 ------------------------------------- 3437 -- Ensure_Prior_Elaboration_Static -- 3438 ------------------------------------- 3439 3440 procedure Ensure_Prior_Elaboration_Static 3441 (N : Node_Id; 3442 Unit_Id : Entity_Id; 3443 Prag_Nam : Name_Id) 3444 is 3445 function Find_With_Clause 3446 (Items : List_Id; 3447 Withed_Id : Entity_Id) return Node_Id; 3448 pragma Inline (Find_With_Clause); 3449 -- Find a nonlimited with clause in the list of context items Items 3450 -- that withs unit Withed_Id. Return Empty if no such clause is found. 3451 3452 procedure Info_Implicit_Pragma; 3453 pragma Inline (Info_Implicit_Pragma); 3454 -- Output information concerning an implicitly generated Elaborate or 3455 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures 3456 -- the prior elaboration of unit Unit_Id. 3457 3458 ---------------------- 3459 -- Find_With_Clause -- 3460 ---------------------- 3461 3462 function Find_With_Clause 3463 (Items : List_Id; 3464 Withed_Id : Entity_Id) return Node_Id 3465 is 3466 Item : Node_Id; 3467 3468 begin 3469 -- Examine the context clauses looking for a suitable with. Note that 3470 -- limited clauses do not affect the elaboration order. 3471 3472 Item := First (Items); 3473 while Present (Item) loop 3474 if Nkind (Item) = N_With_Clause 3475 and then not Error_Posted (Item) 3476 and then not Limited_Present (Item) 3477 and then Entity (Name (Item)) = Withed_Id 3478 then 3479 return Item; 3480 end if; 3481 3482 Next (Item); 3483 end loop; 3484 3485 return Empty; 3486 end Find_With_Clause; 3487 3488 -------------------------- 3489 -- Info_Implicit_Pragma -- 3490 -------------------------- 3491 3492 procedure Info_Implicit_Pragma is 3493 begin 3494 -- Internal units are ignored as they cause unnecessary noise 3495 3496 if not In_Internal_Unit (Unit_Id) then 3497 3498 -- The name of the unit subjected to the elaboration pragma is 3499 -- fully qualified to improve the clarity of the info message. 3500 3501 Error_Msg_Name_1 := Prag_Nam; 3502 Error_Msg_Qual_Level := Nat'Last; 3503 3504 Error_Msg_NE 3505 ("info: implicit pragma % generated for unit &", N, Unit_Id); 3506 3507 Error_Msg_Qual_Level := 0; 3508 Output_Active_Scenarios (N); 3509 end if; 3510 end Info_Implicit_Pragma; 3511 3512 -- Local variables 3513 3514 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 3515 Loc : constant Source_Ptr := Sloc (Main_Cunit); 3516 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 3517 3518 Clause : Node_Id; 3519 Elab_Attrs : Elaboration_Attributes; 3520 Items : List_Id; 3521 3522 -- Start of processing for Ensure_Prior_Elaboration_Static 3523 3524 begin 3525 Elab_Attrs := Elaboration_Status (Unit_Id); 3526 3527 -- Nothing to do when the unit is guaranteed prior elaboration by means 3528 -- of a source Elaborate[_All] pragma. 3529 3530 if Present (Elab_Attrs.Source_Pragma) then 3531 return; 3532 3533 -- Nothing to do when the unit has an existing implicit Elaborate[_All] 3534 -- pragma installed by a previous scenario. 3535 3536 elsif Present (Elab_Attrs.With_Clause) then 3537 3538 -- The unit is already guaranteed prior elaboration by means of an 3539 -- implicit Elaborate pragma, however the current scenario imposes 3540 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 3541 -- pragma to match this new requirement. 3542 3543 if Elaborate_Desirable (Elab_Attrs.With_Clause) 3544 and then Prag_Nam = Name_Elaborate_All 3545 then 3546 Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); 3547 Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); 3548 end if; 3549 3550 return; 3551 end if; 3552 3553 -- At this point it is known that the unit has no prior elaboration 3554 -- according to pragmas and hierarchical relationships. 3555 3556 Items := Context_Items (Main_Cunit); 3557 3558 if No (Items) then 3559 Items := New_List; 3560 Set_Context_Items (Main_Cunit, Items); 3561 end if; 3562 3563 -- Locate the with clause for the unit. Note that there may not be a 3564 -- clause if the unit is visible through a subunit-body, body-spec, or 3565 -- spec-parent relationship. 3566 3567 Clause := 3568 Find_With_Clause 3569 (Items => Items, 3570 Withed_Id => Unit_Id); 3571 3572 -- Generate: 3573 -- with Id; 3574 3575 -- Note that adding implicit with clauses is safe because analysis, 3576 -- resolution, and expansion have already taken place and it is not 3577 -- possible to interfere with visibility. 3578 3579 if No (Clause) then 3580 Clause := 3581 Make_With_Clause (Loc, 3582 Name => New_Occurrence_Of (Unit_Id, Loc)); 3583 3584 Set_Implicit_With (Clause); 3585 Set_Library_Unit (Clause, Unit_Cunit); 3586 3587 Append_To (Items, Clause); 3588 end if; 3589 3590 -- Mark the with clause depending on the pragma required 3591 3592 if Prag_Nam = Name_Elaborate then 3593 Set_Elaborate_Desirable (Clause); 3594 else 3595 Set_Elaborate_All_Desirable (Clause); 3596 end if; 3597 3598 -- The implicit Elaborate[_All] ensures the prior elaboration of the 3599 -- unit. Include the unit in the elaboration context of the main unit. 3600 3601 Set_Elaboration_Status 3602 (Unit_Id => Unit_Id, 3603 Val => Elaboration_Attributes'(Source_Pragma => Empty, 3604 With_Clause => Clause)); 3605 3606 -- Output extra information on an implicit Elaborate[_All] pragma when 3607 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is 3608 -- in effect. 3609 3610 if Elab_Info_Messages then 3611 Info_Implicit_Pragma; 3612 end if; 3613 end Ensure_Prior_Elaboration_Static; 3614 3615 ----------------------------- 3616 -- Extract_Assignment_Name -- 3617 ----------------------------- 3618 3619 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is 3620 Nam : Node_Id; 3621 3622 begin 3623 Nam := Name (Asmt); 3624 3625 -- When the name denotes an array or record component, find the whole 3626 -- object. 3627 3628 while Nkind_In (Nam, N_Explicit_Dereference, 3629 N_Indexed_Component, 3630 N_Selected_Component, 3631 N_Slice) 3632 loop 3633 Nam := Prefix (Nam); 3634 end loop; 3635 3636 return Nam; 3637 end Extract_Assignment_Name; 3638 3639 ----------------------------- 3640 -- Extract_Call_Attributes -- 3641 ----------------------------- 3642 3643 procedure Extract_Call_Attributes 3644 (Call : Node_Id; 3645 Target_Id : out Entity_Id; 3646 Attrs : out Call_Attributes) 3647 is 3648 From_Source : Boolean; 3649 In_Declarations : Boolean; 3650 Is_Dispatching : Boolean; 3651 3652 begin 3653 -- Extraction for call markers 3654 3655 if Nkind (Call) = N_Call_Marker then 3656 Target_Id := Target (Call); 3657 From_Source := Is_Source_Call (Call); 3658 In_Declarations := Is_Declaration_Level_Node (Call); 3659 Is_Dispatching := Is_Dispatching_Call (Call); 3660 3661 -- Extraction for entry calls, requeue, and subprogram calls 3662 3663 else 3664 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, 3665 N_Function_Call, 3666 N_Procedure_Call_Statement, 3667 N_Requeue_Statement)); 3668 3669 Target_Id := Entity (Extract_Call_Name (Call)); 3670 From_Source := Comes_From_Source (Call); 3671 3672 -- Performance note: parent traversal 3673 3674 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; 3675 Is_Dispatching := 3676 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) 3677 and then Present (Controlling_Argument (Call)); 3678 end if; 3679 3680 -- Obtain the original entry or subprogram which the target may rename 3681 -- except when the target is an instantiation. In this case the alias 3682 -- is the internally generated subprogram which appears within the the 3683 -- anonymous package created for the instantiation. Such an alias is not 3684 -- a suitable target. 3685 3686 if not (Is_Subprogram (Target_Id) 3687 and then Is_Generic_Instance (Target_Id)) 3688 then 3689 Target_Id := Get_Renamed_Entity (Target_Id); 3690 end if; 3691 3692 -- Set all attributes 3693 3694 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 3695 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 3696 Attrs.From_Source := From_Source; 3697 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); 3698 Attrs.In_Declarations := In_Declarations; 3699 Attrs.Is_Dispatching := Is_Dispatching; 3700 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); 3701 end Extract_Call_Attributes; 3702 3703 ----------------------- 3704 -- Extract_Call_Name -- 3705 ----------------------- 3706 3707 function Extract_Call_Name (Call : Node_Id) return Node_Id is 3708 Nam : Node_Id; 3709 3710 begin 3711 Nam := Name (Call); 3712 3713 -- When the call invokes an entry family, the name appears as an indexed 3714 -- component. 3715 3716 if Nkind (Nam) = N_Indexed_Component then 3717 Nam := Prefix (Nam); 3718 end if; 3719 3720 -- When the call employs the object.operation form, the name appears as 3721 -- a selected component. 3722 3723 if Nkind (Nam) = N_Selected_Component then 3724 Nam := Selector_Name (Nam); 3725 end if; 3726 3727 return Nam; 3728 end Extract_Call_Name; 3729 3730 --------------------------------- 3731 -- Extract_Instance_Attributes -- 3732 --------------------------------- 3733 3734 procedure Extract_Instance_Attributes 3735 (Exp_Inst : Node_Id; 3736 Inst_Body : out Node_Id; 3737 Inst_Decl : out Node_Id) 3738 is 3739 Body_Id : Entity_Id; 3740 3741 begin 3742 -- Assume that the attributes are unavailable 3743 3744 Inst_Body := Empty; 3745 Inst_Decl := Empty; 3746 3747 -- Generic package or subprogram spec 3748 3749 if Nkind_In (Exp_Inst, N_Package_Declaration, 3750 N_Subprogram_Declaration) 3751 then 3752 Inst_Decl := Exp_Inst; 3753 Body_Id := Corresponding_Body (Inst_Decl); 3754 3755 if Present (Body_Id) then 3756 Inst_Body := Unit_Declaration_Node (Body_Id); 3757 end if; 3758 3759 -- Generic package or subprogram body 3760 3761 else 3762 pragma Assert 3763 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); 3764 3765 Inst_Body := Exp_Inst; 3766 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); 3767 end if; 3768 end Extract_Instance_Attributes; 3769 3770 -------------------------------------- 3771 -- Extract_Instantiation_Attributes -- 3772 -------------------------------------- 3773 3774 procedure Extract_Instantiation_Attributes 3775 (Exp_Inst : Node_Id; 3776 Inst : out Node_Id; 3777 Inst_Id : out Entity_Id; 3778 Gen_Id : out Entity_Id; 3779 Attrs : out Instantiation_Attributes) 3780 is 3781 begin 3782 Inst := Original_Node (Exp_Inst); 3783 Inst_Id := Defining_Entity (Inst); 3784 3785 -- Traverse a possible chain of renamings to obtain the original generic 3786 -- being instantiatied. 3787 3788 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); 3789 3790 -- Set all attributes 3791 3792 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 3793 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 3794 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); 3795 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); 3796 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); 3797 end Extract_Instantiation_Attributes; 3798 3799 ------------------------------- 3800 -- Extract_Target_Attributes -- 3801 ------------------------------- 3802 3803 procedure Extract_Target_Attributes 3804 (Target_Id : Entity_Id; 3805 Attrs : out Target_Attributes) 3806 is 3807 procedure Extract_Package_Or_Subprogram_Attributes 3808 (Spec_Id : out Entity_Id; 3809 Body_Decl : out Node_Id); 3810 -- Obtain the attributes associated with a package or a subprogram. 3811 -- Spec_Id is the package or subprogram. Body_Decl is the declaration 3812 -- of the corresponding package or subprogram body. 3813 3814 procedure Extract_Protected_Entry_Attributes 3815 (Spec_Id : out Entity_Id; 3816 Body_Decl : out Node_Id; 3817 Body_Barf : out Node_Id); 3818 -- Obtain the attributes associated with a protected entry [family]. 3819 -- Spec_Id is the entity of the protected body subprogram. Body_Decl 3820 -- is the declaration of Spec_Id's corresponding body. Body_Barf is 3821 -- the declaration of the barrier function body. 3822 3823 procedure Extract_Protected_Subprogram_Attributes 3824 (Spec_Id : out Entity_Id; 3825 Body_Decl : out Node_Id); 3826 -- Obtain the attributes associated with a protected subprogram. Formal 3827 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is 3828 -- the declaration of Spec_Id's corresponding body. 3829 3830 procedure Extract_Task_Entry_Attributes 3831 (Spec_Id : out Entity_Id; 3832 Body_Decl : out Node_Id); 3833 -- Obtain the attributes associated with a task entry [family]. Formal 3834 -- Spec_Id is the entity of the task body procedure. Body_Decl is the 3835 -- declaration of Spec_Id's corresponding body. 3836 3837 ---------------------------------------------- 3838 -- Extract_Package_Or_Subprogram_Attributes -- 3839 ---------------------------------------------- 3840 3841 procedure Extract_Package_Or_Subprogram_Attributes 3842 (Spec_Id : out Entity_Id; 3843 Body_Decl : out Node_Id) 3844 is 3845 Body_Id : Entity_Id; 3846 Init_Id : Entity_Id; 3847 Spec_Decl : Node_Id; 3848 3849 begin 3850 -- Assume that the body is not available 3851 3852 Body_Decl := Empty; 3853 Spec_Id := Target_Id; 3854 3855 -- For body retrieval purposes, the entity of the initial declaration 3856 -- is that of the spec. 3857 3858 Init_Id := Spec_Id; 3859 3860 -- The only exception to the above is a function which returns a 3861 -- constrained array type in a SPARK-to-C compilation. In this case 3862 -- the function receives a corresponding procedure which has an out 3863 -- parameter. The proper body for ABE checks and diagnostics is that 3864 -- of the procedure. 3865 3866 if Ekind (Init_Id) = E_Function 3867 and then Rewritten_For_C (Init_Id) 3868 then 3869 Init_Id := Corresponding_Procedure (Init_Id); 3870 end if; 3871 3872 -- Extract the attributes of the body 3873 3874 Spec_Decl := Unit_Declaration_Node (Init_Id); 3875 3876 -- The initial declaration is a stand alone subprogram body 3877 3878 if Nkind (Spec_Decl) = N_Subprogram_Body then 3879 Body_Decl := Spec_Decl; 3880 3881 -- Otherwise the package or subprogram has a spec and a completing 3882 -- body. 3883 3884 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 3885 N_Generic_Subprogram_Declaration, 3886 N_Package_Declaration, 3887 N_Subprogram_Body_Stub, 3888 N_Subprogram_Declaration) 3889 then 3890 Body_Id := Corresponding_Body (Spec_Decl); 3891 3892 if Present (Body_Id) then 3893 Body_Decl := Unit_Declaration_Node (Body_Id); 3894 end if; 3895 end if; 3896 end Extract_Package_Or_Subprogram_Attributes; 3897 3898 ---------------------------------------- 3899 -- Extract_Protected_Entry_Attributes -- 3900 ---------------------------------------- 3901 3902 procedure Extract_Protected_Entry_Attributes 3903 (Spec_Id : out Entity_Id; 3904 Body_Decl : out Node_Id; 3905 Body_Barf : out Node_Id) 3906 is 3907 Barf_Id : Entity_Id; 3908 Body_Id : Entity_Id; 3909 3910 begin 3911 -- Assume that the bodies are not available 3912 3913 Body_Barf := Empty; 3914 Body_Decl := Empty; 3915 3916 -- When the entry [family] has already been expanded, it carries both 3917 -- the procedure which emulates the behavior of the entry [family] as 3918 -- well as the barrier function. 3919 3920 if Present (Protected_Body_Subprogram (Target_Id)) then 3921 Spec_Id := Protected_Body_Subprogram (Target_Id); 3922 3923 -- Extract the attributes of the barrier function 3924 3925 Barf_Id := 3926 Corresponding_Body 3927 (Unit_Declaration_Node (Barrier_Function (Target_Id))); 3928 3929 if Present (Barf_Id) then 3930 Body_Barf := Unit_Declaration_Node (Barf_Id); 3931 end if; 3932 3933 -- Otherwise no expansion took place 3934 3935 else 3936 Spec_Id := Target_Id; 3937 end if; 3938 3939 -- Extract the attributes of the entry body 3940 3941 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3942 3943 if Present (Body_Id) then 3944 Body_Decl := Unit_Declaration_Node (Body_Id); 3945 end if; 3946 end Extract_Protected_Entry_Attributes; 3947 3948 --------------------------------------------- 3949 -- Extract_Protected_Subprogram_Attributes -- 3950 --------------------------------------------- 3951 3952 procedure Extract_Protected_Subprogram_Attributes 3953 (Spec_Id : out Entity_Id; 3954 Body_Decl : out Node_Id) 3955 is 3956 Body_Id : Entity_Id; 3957 3958 begin 3959 -- Assume that the body is not available 3960 3961 Body_Decl := Empty; 3962 3963 -- When the protected subprogram has already been expanded, it 3964 -- carries the subprogram which seizes the lock and invokes the 3965 -- original statements. 3966 3967 if Present (Protected_Subprogram (Target_Id)) then 3968 Spec_Id := 3969 Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); 3970 3971 -- Otherwise no expansion took place 3972 3973 else 3974 Spec_Id := Target_Id; 3975 end if; 3976 3977 -- Extract the attributes of the body 3978 3979 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3980 3981 if Present (Body_Id) then 3982 Body_Decl := Unit_Declaration_Node (Body_Id); 3983 end if; 3984 end Extract_Protected_Subprogram_Attributes; 3985 3986 ----------------------------------- 3987 -- Extract_Task_Entry_Attributes -- 3988 ----------------------------------- 3989 3990 procedure Extract_Task_Entry_Attributes 3991 (Spec_Id : out Entity_Id; 3992 Body_Decl : out Node_Id) 3993 is 3994 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); 3995 Body_Id : Entity_Id; 3996 3997 begin 3998 -- Assume that the body is not available 3999 4000 Body_Decl := Empty; 4001 4002 -- The the task type has already been expanded, it carries the 4003 -- procedure which emulates the behavior of the task body. 4004 4005 if Present (Task_Body_Procedure (Task_Typ)) then 4006 Spec_Id := Task_Body_Procedure (Task_Typ); 4007 4008 -- Otherwise no expansion took place 4009 4010 else 4011 Spec_Id := Task_Typ; 4012 end if; 4013 4014 -- Extract the attributes of the body 4015 4016 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 4017 4018 if Present (Body_Id) then 4019 Body_Decl := Unit_Declaration_Node (Body_Id); 4020 end if; 4021 end Extract_Task_Entry_Attributes; 4022 4023 -- Local variables 4024 4025 Prag : constant Node_Id := SPARK_Pragma (Target_Id); 4026 Body_Barf : Node_Id; 4027 Body_Decl : Node_Id; 4028 Spec_Id : Entity_Id; 4029 4030 -- Start of processing for Extract_Target_Attributes 4031 4032 begin 4033 -- Assume that the body of the barrier function is not available 4034 4035 Body_Barf := Empty; 4036 4037 -- The target is a protected entry [family] 4038 4039 if Is_Protected_Entry (Target_Id) then 4040 Extract_Protected_Entry_Attributes 4041 (Spec_Id => Spec_Id, 4042 Body_Decl => Body_Decl, 4043 Body_Barf => Body_Barf); 4044 4045 -- The target is a protected subprogram 4046 4047 elsif Is_Protected_Subp (Target_Id) 4048 or else Is_Protected_Body_Subp (Target_Id) 4049 then 4050 Extract_Protected_Subprogram_Attributes 4051 (Spec_Id => Spec_Id, 4052 Body_Decl => Body_Decl); 4053 4054 -- The target is a task entry [family] 4055 4056 elsif Is_Task_Entry (Target_Id) then 4057 Extract_Task_Entry_Attributes 4058 (Spec_Id => Spec_Id, 4059 Body_Decl => Body_Decl); 4060 4061 -- Otherwise the target is a package or a subprogram 4062 4063 else 4064 Extract_Package_Or_Subprogram_Attributes 4065 (Spec_Id => Spec_Id, 4066 Body_Decl => Body_Decl); 4067 end if; 4068 4069 -- Set all attributes 4070 4071 Attrs.Body_Barf := Body_Barf; 4072 Attrs.Body_Decl := Body_Decl; 4073 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); 4074 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id); 4075 Attrs.From_Source := Comes_From_Source (Target_Id); 4076 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); 4077 Attrs.SPARK_Mode_On := 4078 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; 4079 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id); 4080 Attrs.Spec_Id := Spec_Id; 4081 Attrs.Unit_Id := Find_Top_Unit (Target_Id); 4082 4083 -- At this point certain attributes should always be available 4084 4085 pragma Assert (Present (Attrs.Spec_Decl)); 4086 pragma Assert (Present (Attrs.Spec_Id)); 4087 pragma Assert (Present (Attrs.Unit_Id)); 4088 end Extract_Target_Attributes; 4089 4090 ----------------------------- 4091 -- Extract_Task_Attributes -- 4092 ----------------------------- 4093 4094 procedure Extract_Task_Attributes 4095 (Typ : Entity_Id; 4096 Attrs : out Task_Attributes) 4097 is 4098 Task_Typ : constant Entity_Id := Non_Private_View (Typ); 4099 4100 Body_Decl : Node_Id; 4101 Body_Id : Entity_Id; 4102 Prag : Node_Id; 4103 Spec_Id : Entity_Id; 4104 4105 begin 4106 -- Assume that the body of the task procedure is not available 4107 4108 Body_Decl := Empty; 4109 4110 -- The initial declaration is that of the task body procedure 4111 4112 Spec_Id := Get_Task_Body_Procedure (Task_Typ); 4113 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 4114 4115 if Present (Body_Id) then 4116 Body_Decl := Unit_Declaration_Node (Body_Id); 4117 end if; 4118 4119 Prag := SPARK_Pragma (Task_Typ); 4120 4121 -- Set all attributes 4122 4123 Attrs.Body_Decl := Body_Decl; 4124 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); 4125 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ); 4126 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); 4127 Attrs.SPARK_Mode_On := 4128 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; 4129 Attrs.Spec_Id := Spec_Id; 4130 Attrs.Task_Decl := Declaration_Node (Task_Typ); 4131 Attrs.Unit_Id := Find_Top_Unit (Task_Typ); 4132 4133 -- At this point certain attributes should always be available 4134 4135 pragma Assert (Present (Attrs.Spec_Id)); 4136 pragma Assert (Present (Attrs.Task_Decl)); 4137 pragma Assert (Present (Attrs.Unit_Id)); 4138 end Extract_Task_Attributes; 4139 4140 ------------------------------------------- 4141 -- Extract_Variable_Reference_Attributes -- 4142 ------------------------------------------- 4143 4144 procedure Extract_Variable_Reference_Attributes 4145 (Ref : Node_Id; 4146 Var_Id : out Entity_Id; 4147 Attrs : out Variable_Attributes) 4148 is 4149 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; 4150 -- Obtain the ultimate renamed variable of variable Id 4151 4152 -------------------------- 4153 -- Get_Renamed_Variable -- 4154 -------------------------- 4155 4156 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is 4157 Ren_Id : Entity_Id; 4158 4159 begin 4160 Ren_Id := Id; 4161 while Present (Renamed_Entity (Ren_Id)) 4162 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity 4163 loop 4164 Ren_Id := Renamed_Entity (Ren_Id); 4165 end loop; 4166 4167 return Ren_Id; 4168 end Get_Renamed_Variable; 4169 4170 -- Start of processing for Extract_Variable_Reference_Attributes 4171 4172 begin 4173 -- Extraction for variable reference markers 4174 4175 if Nkind (Ref) = N_Variable_Reference_Marker then 4176 Var_Id := Target (Ref); 4177 4178 -- Extraction for expanded names and identifiers 4179 4180 else 4181 Var_Id := Entity (Ref); 4182 end if; 4183 4184 -- Obtain the original variable which the reference mentions 4185 4186 Var_Id := Get_Renamed_Variable (Var_Id); 4187 Attrs.Unit_Id := Find_Top_Unit (Var_Id); 4188 4189 -- At this point certain attributes should always be available 4190 4191 pragma Assert (Present (Attrs.Unit_Id)); 4192 end Extract_Variable_Reference_Attributes; 4193 4194 -------------------- 4195 -- Find_Code_Unit -- 4196 -------------------- 4197 4198 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is 4199 begin 4200 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); 4201 end Find_Code_Unit; 4202 4203 ---------------------------- 4204 -- Find_Early_Call_Region -- 4205 ---------------------------- 4206 4207 function Find_Early_Call_Region 4208 (Body_Decl : Node_Id; 4209 Assume_Elab_Body : Boolean := False; 4210 Skip_Memoization : Boolean := False) return Node_Id 4211 is 4212 -- NOTE: The routines within Find_Early_Call_Region are intentionally 4213 -- unnested to avoid deep indentation of code. 4214 4215 ECR_Found : exception; 4216 -- This exception is raised when the early call region has been found 4217 4218 Start : Node_Id := Empty; 4219 -- The start of the early call region. This variable is updated by the 4220 -- various nested routines. Due to the use of exceptions, the variable 4221 -- must be global to the nested routines. 4222 4223 -- The algorithm implemented in this routine attempts to find the early 4224 -- call region of a subprogram body by inspecting constructs in reverse 4225 -- declarative order, while navigating the tree. The algorithm consists 4226 -- of an Inspection phase and an Advancement phase. The pseudocode is as 4227 -- follows: 4228 -- 4229 -- loop 4230 -- inspection phase 4231 -- advancement phase 4232 -- end loop 4233 -- 4234 -- The infinite loop is terminated by raising exception ECR_Found. The 4235 -- algorithm utilizes two pointers, Curr and Start, to represent the 4236 -- current construct to inspect and the start of the early call region. 4237 -- 4238 -- IMPORTANT: The algorithm must maintain the following invariant at all 4239 -- time for it to function properly - a nested construct is entered only 4240 -- when it contains suitable constructs. This guarantees that leaving a 4241 -- nested or encapsulating construct functions properly. 4242 -- 4243 -- The Inspection phase determines whether the current construct is non- 4244 -- preelaborable, and if it is, the algorithm terminates. 4245 -- 4246 -- The Advancement phase walks the tree in reverse declarative order, 4247 -- while entering and leaving nested and encapsulating constructs. It 4248 -- may also terminate the elaborithm. There are several special cases 4249 -- of advancement. 4250 -- 4251 -- 1) General case: 4252 -- 4253 -- <construct 1> 4254 -- ... 4255 -- <construct N-1> <- Curr 4256 -- <construct N> <- Start 4257 -- <subprogram body> 4258 -- 4259 -- In the general case, a declarative or statement list is traversed in 4260 -- reverse order where Curr is the lead pointer, and Start indicates the 4261 -- last preelaborable construct. 4262 -- 4263 -- 2) Entering handled bodies 4264 -- 4265 -- package body Nested is <- Curr (2.3) 4266 -- <declarations> <- Curr (2.2) 4267 -- begin 4268 -- <statements> <- Curr (2.1) 4269 -- end Nested; 4270 -- <construct> <- Start 4271 -- 4272 -- In this case, the algorithm enters a handled body by starting from 4273 -- the last statement (2.1), or the last declaration (2.2), or the body 4274 -- is consumed (2.3) because it is empty and thus preelaborable. 4275 -- 4276 -- 3) Entering package declarations 4277 -- 4278 -- package Nested is <- Curr (2.3) 4279 -- <visible declarations> <- Curr (2.2) 4280 -- private 4281 -- <private declarations> <- Curr (2.1) 4282 -- end Nested; 4283 -- <construct> <- Start 4284 -- 4285 -- In this case, the algorithm enters a package declaration by starting 4286 -- from the last private declaration (2.1), the last visible declaration 4287 -- (2.2), or the package is consumed (2.3) because it is empty and thus 4288 -- preelaborable. 4289 -- 4290 -- 4) Transitioning from list to list of the same construct 4291 -- 4292 -- Certain constructs have two eligible lists. The algorithm must thus 4293 -- transition from the second to the first list when the second list is 4294 -- exhausted. 4295 -- 4296 -- declare <- Curr (4.2) 4297 -- <declarations> <- Curr (4.1) 4298 -- begin 4299 -- <statements> <- Start 4300 -- end; 4301 -- 4302 -- In this case, the algorithm has exhausted the second list (statements 4303 -- in the example), and continues with the last declaration (4.1) or the 4304 -- construct is consumed (4.2) because it contains only preelaborable 4305 -- code. 4306 -- 4307 -- 5) Transitioning from list to construct 4308 -- 4309 -- tack body Task is <- Curr (5.1) 4310 -- <- Curr (Empty) 4311 -- <construct 1> <- Start 4312 -- 4313 -- In this case, the algorithm has exhausted a list, Curr is Empty, and 4314 -- the owner of the list is consumed (5.1). 4315 -- 4316 -- 6) Transitioning from unit to unit 4317 -- 4318 -- A package body with a spec subject to pragma Elaborate_Body extends 4319 -- the possible range of the early call region to the package spec. 4320 -- 4321 -- package Pack is <- Curr (6.3) 4322 -- pragma Elaborate_Body; <- Curr (6.2) 4323 -- <visible declarations> <- Curr (6.2) 4324 -- private 4325 -- <private declarations> <- Curr (6.1) 4326 -- end Pack; 4327 -- 4328 -- package body Pack is <- Curr, Start 4329 -- 4330 -- In this case, the algorithm has reached a package body compilation 4331 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 4332 -- of the algorithm has specified this behavior. This transition is 4333 -- equivalent to 3). 4334 -- 4335 -- 7) Transitioning from unit to termination 4336 -- 4337 -- Reaching a compilation unit always terminates the algorithm as there 4338 -- are no more lists to examine. This must take 6) into account. 4339 -- 4340 -- 8) Transitioning from subunit to stub 4341 -- 4342 -- package body Pack is separate; <- Curr (8.1) 4343 -- 4344 -- separate (...) 4345 -- package body Pack is <- Curr, Start 4346 -- 4347 -- Reaching a subunit continues the search from the corresponding stub 4348 -- (8.1). 4349 4350 procedure Advance (Curr : in out Node_Id); 4351 pragma Inline (Advance); 4352 -- Update the Curr and Start pointers depending on their location in the 4353 -- tree to the next eligible construct. This routine raises ECR_Found. 4354 4355 procedure Enter_Handled_Body (Curr : in out Node_Id); 4356 pragma Inline (Enter_Handled_Body); 4357 -- Update the Curr and Start pointers to enter a nested handled body if 4358 -- applicable. This routine raises ECR_Found. 4359 4360 procedure Enter_Package_Declaration (Curr : in out Node_Id); 4361 pragma Inline (Enter_Package_Declaration); 4362 -- Update the Curr and Start pointers to enter a nested package spec if 4363 -- applicable. This routine raises ECR_Found. 4364 4365 function Find_ECR (N : Node_Id) return Node_Id; 4366 pragma Inline (Find_ECR); 4367 -- Find an early call region starting from arbitrary node N 4368 4369 function Has_Suitable_Construct (List : List_Id) return Boolean; 4370 pragma Inline (Has_Suitable_Construct); 4371 -- Determine whether list List contains at least one suitable construct 4372 -- for inclusion into an early call region. 4373 4374 procedure Include (N : Node_Id; Curr : out Node_Id); 4375 pragma Inline (Include); 4376 -- Update the Curr and Start pointers to include arbitrary construct N 4377 -- in the early call region. This routine raises ECR_Found. 4378 4379 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 4380 pragma Inline (Is_OK_Preelaborable_Construct); 4381 -- Determine whether arbitrary node N denotes a preelaboration-safe 4382 -- construct. 4383 4384 function Is_Suitable_Construct (N : Node_Id) return Boolean; 4385 pragma Inline (Is_Suitable_Construct); 4386 -- Determine whether arbitrary node N denotes a suitable construct for 4387 -- inclusion into the early call region. 4388 4389 procedure Transition_Body_Declarations 4390 (Bod : Node_Id; 4391 Curr : out Node_Id); 4392 pragma Inline (Transition_Body_Declarations); 4393 -- Update the Curr and Start pointers when construct Bod denotes a block 4394 -- statement or a suitable body. This routine raises ECR_Found. 4395 4396 procedure Transition_Handled_Statements 4397 (HSS : Node_Id; 4398 Curr : out Node_Id); 4399 pragma Inline (Transition_Handled_Statements); 4400 -- Update the Curr and Start pointers when node HSS denotes a handled 4401 -- sequence of statements. This routine raises ECR_Found. 4402 4403 procedure Transition_Spec_Declarations 4404 (Spec : Node_Id; 4405 Curr : out Node_Id); 4406 pragma Inline (Transition_Spec_Declarations); 4407 -- Update the Curr and Start pointers when construct Spec denotes 4408 -- a concurrent definition or a package spec. This routine raises 4409 -- ECR_Found. 4410 4411 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); 4412 pragma Inline (Transition_Unit); 4413 -- Update the Curr and Start pointers when node Unit denotes a potential 4414 -- compilation unit. This routine raises ECR_Found. 4415 4416 ------------- 4417 -- Advance -- 4418 ------------- 4419 4420 procedure Advance (Curr : in out Node_Id) is 4421 Context : Node_Id; 4422 4423 begin 4424 -- Curr denotes one of the following cases upon entry into this 4425 -- routine: 4426 -- 4427 -- * Empty - There is no current construct when a declarative or a 4428 -- statement list has been exhausted. This does not necessarily 4429 -- indicate that the early call region has been computed as it 4430 -- may still be possible to transition to another list. 4431 -- 4432 -- * Encapsulator - The current construct encapsulates declarations 4433 -- and/or statements. This indicates that the early call region 4434 -- may extend within the nested construct. 4435 -- 4436 -- * Preelaborable - The current construct is always preelaborable 4437 -- because Find_ECR would not invoke Advance if this was not the 4438 -- case. 4439 4440 -- The current construct is an encapsulator or is preelaborable 4441 4442 if Present (Curr) then 4443 4444 -- Enter encapsulators by inspecting their declarations and/or 4445 -- statements. 4446 4447 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then 4448 Enter_Handled_Body (Curr); 4449 4450 elsif Nkind (Curr) = N_Package_Declaration then 4451 Enter_Package_Declaration (Curr); 4452 4453 -- Early call regions have a property which can be exploited to 4454 -- optimize the algorithm. 4455 -- 4456 -- <preceding subprogram body> 4457 -- <preelaborable construct 1> 4458 -- ... 4459 -- <preelaborable construct N> 4460 -- <initiating subprogram body> 4461 -- 4462 -- If a traversal initiated from a subprogram body reaches a 4463 -- preceding subprogram body, then both bodies share the same 4464 -- early call region. 4465 -- 4466 -- The property results in the following desirable effects: 4467 -- 4468 -- * If the preceding body already has an early call region, then 4469 -- the initiating body can reuse it. This minimizes the amount 4470 -- of processing performed by the algorithm. 4471 -- 4472 -- * If the preceding body lack an early call region, then the 4473 -- algorithm can compute the early call region, and reuse it 4474 -- for the initiating body. This processing performs the same 4475 -- amount of work, but has the beneficial effect of computing 4476 -- the early call regions of all preceding bodies. 4477 4478 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then 4479 Start := 4480 Find_Early_Call_Region 4481 (Body_Decl => Curr, 4482 Assume_Elab_Body => Assume_Elab_Body, 4483 Skip_Memoization => Skip_Memoization); 4484 4485 raise ECR_Found; 4486 4487 -- Otherwise current construct is preelaborable. Unpdate the early 4488 -- call region to include it. 4489 4490 else 4491 Include (Curr, Curr); 4492 end if; 4493 4494 -- Otherwise the current construct is missing, indicating that the 4495 -- current list has been exhausted. Depending on the context of the 4496 -- list, several transitions are possible. 4497 4498 else 4499 -- The invariant of the algorithm ensures that Curr and Start are 4500 -- at the same level of nesting at the point of a transition. The 4501 -- algorithm can determine which list the traversal came from by 4502 -- examining Start. 4503 4504 Context := Parent (Start); 4505 4506 -- Attempt the following transitions: 4507 -- 4508 -- private declarations -> visible declarations 4509 -- private declarations -> upper level 4510 -- private declarations -> terminate 4511 -- visible declarations -> upper level 4512 -- visible declarations -> terminate 4513 4514 if Nkind_In (Context, N_Package_Specification, 4515 N_Protected_Definition, 4516 N_Task_Definition) 4517 then 4518 Transition_Spec_Declarations (Context, Curr); 4519 4520 -- Attempt the following transitions: 4521 -- 4522 -- statements -> declarations 4523 -- statements -> upper level 4524 -- statements -> corresponding package spec (Elab_Body) 4525 -- statements -> terminate 4526 4527 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 4528 Transition_Handled_Statements (Context, Curr); 4529 4530 -- Attempt the following transitions: 4531 -- 4532 -- declarations -> upper level 4533 -- declarations -> corresponding package spec (Elab_Body) 4534 -- declarations -> terminate 4535 4536 elsif Nkind_In (Context, N_Block_Statement, 4537 N_Entry_Body, 4538 N_Package_Body, 4539 N_Protected_Body, 4540 N_Subprogram_Body, 4541 N_Task_Body) 4542 then 4543 Transition_Body_Declarations (Context, Curr); 4544 4545 -- Otherwise it is not possible to transition. Stop the search 4546 -- because there are no more declarations or statements to check. 4547 4548 else 4549 raise ECR_Found; 4550 end if; 4551 end if; 4552 end Advance; 4553 4554 -------------------------- 4555 -- Enter_Handled_Body -- 4556 -------------------------- 4557 4558 procedure Enter_Handled_Body (Curr : in out Node_Id) is 4559 Decls : constant List_Id := Declarations (Curr); 4560 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 4561 Stmts : List_Id := No_List; 4562 4563 begin 4564 if Present (HSS) then 4565 Stmts := Statements (HSS); 4566 end if; 4567 4568 -- The handled body has a non-empty statement sequence. The construct 4569 -- to inspect is the last statement. 4570 4571 if Has_Suitable_Construct (Stmts) then 4572 Curr := Last (Stmts); 4573 4574 -- The handled body lacks statements, but has non-empty declarations. 4575 -- The construct to inspect is the last declaration. 4576 4577 elsif Has_Suitable_Construct (Decls) then 4578 Curr := Last (Decls); 4579 4580 -- Otherwise the handled body lacks both declarations and statements. 4581 -- The construct to inspect is the node which precedes the handled 4582 -- body. Update the early call region to include the handled body. 4583 4584 else 4585 Include (Curr, Curr); 4586 end if; 4587 end Enter_Handled_Body; 4588 4589 ------------------------------- 4590 -- Enter_Package_Declaration -- 4591 ------------------------------- 4592 4593 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 4594 Pack_Spec : constant Node_Id := Specification (Curr); 4595 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 4596 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 4597 4598 begin 4599 -- The package has a non-empty private declarations. The construct to 4600 -- inspect is the last private declaration. 4601 4602 if Has_Suitable_Construct (Prv_Decls) then 4603 Curr := Last (Prv_Decls); 4604 4605 -- The package lacks private declarations, but has non-empty visible 4606 -- declarations. In this case the construct to inspect is the last 4607 -- visible declaration. 4608 4609 elsif Has_Suitable_Construct (Vis_Decls) then 4610 Curr := Last (Vis_Decls); 4611 4612 -- Otherwise the package lacks any declarations. The construct to 4613 -- inspect is the node which precedes the package. Update the early 4614 -- call region to include the package declaration. 4615 4616 else 4617 Include (Curr, Curr); 4618 end if; 4619 end Enter_Package_Declaration; 4620 4621 -------------- 4622 -- Find_ECR -- 4623 -------------- 4624 4625 function Find_ECR (N : Node_Id) return Node_Id is 4626 Curr : Node_Id; 4627 4628 begin 4629 -- The early call region starts at N 4630 4631 Curr := Prev (N); 4632 Start := N; 4633 4634 -- Inspect each node in reverse declarative order while going in and 4635 -- out of nested and enclosing constructs. Note that the only way to 4636 -- terminate this infinite loop is to raise exception ECR_Found. 4637 4638 loop 4639 -- The current construct is not preelaboration-safe. Terminate the 4640 -- traversal. 4641 4642 if Present (Curr) 4643 and then not Is_OK_Preelaborable_Construct (Curr) 4644 then 4645 raise ECR_Found; 4646 end if; 4647 4648 -- Advance to the next suitable construct. This may terminate the 4649 -- traversal by raising ECR_Found. 4650 4651 Advance (Curr); 4652 end loop; 4653 4654 exception 4655 when ECR_Found => 4656 return Start; 4657 end Find_ECR; 4658 4659 ---------------------------- 4660 -- Has_Suitable_Construct -- 4661 ---------------------------- 4662 4663 function Has_Suitable_Construct (List : List_Id) return Boolean is 4664 Item : Node_Id; 4665 4666 begin 4667 -- Examine the list in reverse declarative order, looking for a 4668 -- suitable construct. 4669 4670 if Present (List) then 4671 Item := Last (List); 4672 while Present (Item) loop 4673 if Is_Suitable_Construct (Item) then 4674 return True; 4675 end if; 4676 4677 Prev (Item); 4678 end loop; 4679 end if; 4680 4681 return False; 4682 end Has_Suitable_Construct; 4683 4684 ------------- 4685 -- Include -- 4686 ------------- 4687 4688 procedure Include (N : Node_Id; Curr : out Node_Id) is 4689 begin 4690 Start := N; 4691 4692 -- The input node is a compilation unit. This terminates the search 4693 -- because there are no more lists to inspect and there are no more 4694 -- enclosing constructs to climb up to. The transitions are: 4695 -- 4696 -- private declarations -> terminate 4697 -- visible declarations -> terminate 4698 -- statements -> terminate 4699 -- declarations -> terminate 4700 4701 if Nkind (Parent (Start)) = N_Compilation_Unit then 4702 raise ECR_Found; 4703 4704 -- Otherwise the input node is still within some list 4705 4706 else 4707 Curr := Prev (Start); 4708 end if; 4709 end Include; 4710 4711 ----------------------------------- 4712 -- Is_OK_Preelaborable_Construct -- 4713 ----------------------------------- 4714 4715 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 4716 begin 4717 -- Assignment statements are acceptable as long as they were produced 4718 -- by the ABE mechanism to update elaboration flags. 4719 4720 if Nkind (N) = N_Assignment_Statement then 4721 return Is_Elaboration_Code (N); 4722 4723 -- Block statements are acceptable even though they directly violate 4724 -- preelaborability. The intention is not to penalize the early call 4725 -- region when a block contains only preelaborable constructs. 4726 -- 4727 -- declare 4728 -- Val : constant Integer := 1; 4729 -- begin 4730 -- pragma Assert (Val = 1); 4731 -- null; 4732 -- end; 4733 -- 4734 -- Note that the Advancement phase does enter blocks, and will detect 4735 -- any non-preelaborable declarations or statements within. 4736 4737 elsif Nkind (N) = N_Block_Statement then 4738 return True; 4739 end if; 4740 4741 -- Otherwise the construct must be preelaborable. The check must take 4742 -- the syntactic and semantic structure of the construct. DO NOT use 4743 -- Is_Preelaborable_Construct here. 4744 4745 return not Is_Non_Preelaborable_Construct (N); 4746 end Is_OK_Preelaborable_Construct; 4747 4748 --------------------------- 4749 -- Is_Suitable_Construct -- 4750 --------------------------- 4751 4752 function Is_Suitable_Construct (N : Node_Id) return Boolean is 4753 Context : constant Node_Id := Parent (N); 4754 4755 begin 4756 -- An internally-generated statement sequence which contains only a 4757 -- single null statement is not a suitable construct because it is a 4758 -- byproduct of the parser. Such a null statement should be excluded 4759 -- from the early call region because it carries the source location 4760 -- of the "end" keyword, and may lead to confusing diagnistics. 4761 4762 if Nkind (N) = N_Null_Statement 4763 and then not Comes_From_Source (N) 4764 and then Present (Context) 4765 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 4766 then 4767 return False; 4768 end if; 4769 4770 -- Otherwise only constructs which correspond to pure Ada constructs 4771 -- are considered suitable. 4772 4773 case Nkind (N) is 4774 when N_Call_Marker 4775 | N_Freeze_Entity 4776 | N_Freeze_Generic_Entity 4777 | N_Implicit_Label_Declaration 4778 | N_Itype_Reference 4779 | N_Pop_Constraint_Error_Label 4780 | N_Pop_Program_Error_Label 4781 | N_Pop_Storage_Error_Label 4782 | N_Push_Constraint_Error_Label 4783 | N_Push_Program_Error_Label 4784 | N_Push_Storage_Error_Label 4785 | N_SCIL_Dispatch_Table_Tag_Init 4786 | N_SCIL_Dispatching_Call 4787 | N_SCIL_Membership_Test 4788 | N_Variable_Reference_Marker 4789 => 4790 return False; 4791 4792 when others => 4793 return True; 4794 end case; 4795 end Is_Suitable_Construct; 4796 4797 ---------------------------------- 4798 -- Transition_Body_Declarations -- 4799 ---------------------------------- 4800 4801 procedure Transition_Body_Declarations 4802 (Bod : Node_Id; 4803 Curr : out Node_Id) 4804 is 4805 Decls : constant List_Id := Declarations (Bod); 4806 4807 begin 4808 -- The search must come from the declarations of the body 4809 4810 pragma Assert 4811 (Is_Non_Empty_List (Decls) 4812 and then List_Containing (Start) = Decls); 4813 4814 -- The search finished inspecting the declarations. The construct 4815 -- to inspect is the node which precedes the handled body, unless 4816 -- the body is a compilation unit. The transitions are: 4817 -- 4818 -- declarations -> upper level 4819 -- declarations -> corresponding package spec (Elab_Body) 4820 -- declarations -> terminate 4821 4822 Transition_Unit (Bod, Curr); 4823 end Transition_Body_Declarations; 4824 4825 ----------------------------------- 4826 -- Transition_Handled_Statements -- 4827 ----------------------------------- 4828 4829 procedure Transition_Handled_Statements 4830 (HSS : Node_Id; 4831 Curr : out Node_Id) 4832 is 4833 Bod : constant Node_Id := Parent (HSS); 4834 Decls : constant List_Id := Declarations (Bod); 4835 Stmts : constant List_Id := Statements (HSS); 4836 4837 begin 4838 -- The search must come from the statements of certain bodies or 4839 -- statements. 4840 4841 pragma Assert (Nkind_In (Bod, N_Block_Statement, 4842 N_Entry_Body, 4843 N_Package_Body, 4844 N_Protected_Body, 4845 N_Subprogram_Body, 4846 N_Task_Body)); 4847 4848 -- The search must come from the statements of the handled sequence 4849 4850 pragma Assert 4851 (Is_Non_Empty_List (Stmts) 4852 and then List_Containing (Start) = Stmts); 4853 4854 -- The search finished inspecting the statements. The handled body 4855 -- has non-empty declarations. The construct to inspect is the last 4856 -- declaration. The transitions are: 4857 -- 4858 -- statements -> declarations 4859 4860 if Has_Suitable_Construct (Decls) then 4861 Curr := Last (Decls); 4862 4863 -- Otherwise the handled body lacks declarations. The construct to 4864 -- inspect is the node which precedes the handled body, unless the 4865 -- body is a compilation unit. The transitions are: 4866 -- 4867 -- statements -> upper level 4868 -- statements -> corresponding package spec (Elab_Body) 4869 -- statements -> terminate 4870 4871 else 4872 Transition_Unit (Bod, Curr); 4873 end if; 4874 end Transition_Handled_Statements; 4875 4876 ---------------------------------- 4877 -- Transition_Spec_Declarations -- 4878 ---------------------------------- 4879 4880 procedure Transition_Spec_Declarations 4881 (Spec : Node_Id; 4882 Curr : out Node_Id) 4883 is 4884 Prv_Decls : constant List_Id := Private_Declarations (Spec); 4885 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 4886 4887 begin 4888 pragma Assert (Present (Start) and then Is_List_Member (Start)); 4889 4890 -- The search came from the private declarations and finished their 4891 -- inspection. 4892 4893 if Has_Suitable_Construct (Prv_Decls) 4894 and then List_Containing (Start) = Prv_Decls 4895 then 4896 -- The context has non-empty visible declarations. The node to 4897 -- inspect is the last visible declaration. The transitions are: 4898 -- 4899 -- private declarations -> visible declarations 4900 4901 if Has_Suitable_Construct (Vis_Decls) then 4902 Curr := Last (Vis_Decls); 4903 4904 -- Otherwise the context lacks visible declarations. The construct 4905 -- to inspect is the node which precedes the context unless the 4906 -- context is a compilation unit. The transitions are: 4907 -- 4908 -- private declarations -> upper level 4909 -- private declarations -> terminate 4910 4911 else 4912 Transition_Unit (Parent (Spec), Curr); 4913 end if; 4914 4915 -- The search came from the visible declarations and finished their 4916 -- inspections. The construct to inspect is the node which precedes 4917 -- the context, unless the context is a compilaton unit. The 4918 -- transitions are: 4919 -- 4920 -- visible declarations -> upper level 4921 -- visible declarations -> terminate 4922 4923 elsif Has_Suitable_Construct (Vis_Decls) 4924 and then List_Containing (Start) = Vis_Decls 4925 then 4926 Transition_Unit (Parent (Spec), Curr); 4927 4928 -- At this point both declarative lists are empty, but the traversal 4929 -- still came from within the spec. This indicates that the invariant 4930 -- of the algorithm has been violated. 4931 4932 else 4933 pragma Assert (False); 4934 raise ECR_Found; 4935 end if; 4936 end Transition_Spec_Declarations; 4937 4938 --------------------- 4939 -- Transition_Unit -- 4940 --------------------- 4941 4942 procedure Transition_Unit 4943 (Unit : Node_Id; 4944 Curr : out Node_Id) 4945 is 4946 Context : constant Node_Id := Parent (Unit); 4947 4948 begin 4949 -- The unit is a compilation unit. This terminates the search because 4950 -- there are no more lists to inspect and there are no more enclosing 4951 -- constructs to climb up to. 4952 4953 if Nkind (Context) = N_Compilation_Unit then 4954 4955 -- A package body with a corresponding spec subject to pragma 4956 -- Elaborate_Body is an exception to the above. The annotation 4957 -- allows the search to continue into the package declaration. 4958 -- The transitions are: 4959 -- 4960 -- statements -> corresponding package spec (Elab_Body) 4961 -- declarations -> corresponding package spec (Elab_Body) 4962 4963 if Nkind (Unit) = N_Package_Body 4964 and then (Assume_Elab_Body 4965 or else Has_Pragma_Elaborate_Body 4966 (Corresponding_Spec (Unit))) 4967 then 4968 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); 4969 Enter_Package_Declaration (Curr); 4970 4971 -- Otherwise terminate the search. The transitions are: 4972 -- 4973 -- private declarations -> terminate 4974 -- visible declarations -> terminate 4975 -- statements -> terminate 4976 -- declarations -> terminate 4977 4978 else 4979 raise ECR_Found; 4980 end if; 4981 4982 -- The unit is a subunit. The construct to inspect is the node which 4983 -- precedes the corresponding stub. Update the early call region to 4984 -- include the unit. 4985 4986 elsif Nkind (Context) = N_Subunit then 4987 Start := Unit; 4988 Curr := Corresponding_Stub (Context); 4989 4990 -- Otherwise the unit is nested. The construct to inspect is the node 4991 -- which precedes the unit. Update the early call region to include 4992 -- the unit. 4993 4994 else 4995 Include (Unit, Curr); 4996 end if; 4997 end Transition_Unit; 4998 4999 -- Local variables 5000 5001 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 5002 Region : Node_Id; 5003 5004 -- Start of processing for Find_Early_Call_Region 5005 5006 begin 5007 -- The caller demands the start of the early call region without saving 5008 -- or retrieving it to/from internal data structures. 5009 5010 if Skip_Memoization then 5011 Region := Find_ECR (Body_Decl); 5012 5013 -- Default behavior 5014 5015 else 5016 -- Check whether the early call region of the subprogram body is 5017 -- available. 5018 5019 Region := Early_Call_Region (Body_Id); 5020 5021 if No (Region) then 5022 5023 -- Traverse the declarations in reverse order, starting from the 5024 -- subprogram body, searching for the nearest non-preelaborable 5025 -- construct. The early call region starts after this construct 5026 -- and ends at the subprogram body. 5027 5028 Region := Find_ECR (Body_Decl); 5029 5030 -- Associate the early call region with the subprogram body in 5031 -- case other scenarios need it. 5032 5033 Set_Early_Call_Region (Body_Id, Region); 5034 end if; 5035 end if; 5036 5037 -- A subprogram body must always have an early call region 5038 5039 pragma Assert (Present (Region)); 5040 5041 return Region; 5042 end Find_Early_Call_Region; 5043 5044 --------------------------- 5045 -- Find_Elaborated_Units -- 5046 --------------------------- 5047 5048 procedure Find_Elaborated_Units is 5049 procedure Add_Pragma (Prag : Node_Id); 5050 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma. 5051 -- If this is the case, add the related unit to the elaboration context. 5052 -- For pragma Elaborate_All, include recursively all units withed by the 5053 -- related unit. 5054 5055 procedure Add_Unit 5056 (Unit_Id : Entity_Id; 5057 Prag : Node_Id; 5058 Full_Context : Boolean); 5059 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma 5060 -- which prompted the inclusion of the unit to the elaboration context. 5061 -- If flag Full_Context is set, examine the nonlimited clauses of unit 5062 -- Unit_Id and add each withed unit to the context. 5063 5064 procedure Find_Elaboration_Context (Comp_Unit : Node_Id); 5065 -- Examine the context items of compilation unit Comp_Unit for suitable 5066 -- elaboration-related pragmas and add all related units to the context. 5067 5068 ---------------- 5069 -- Add_Pragma -- 5070 ---------------- 5071 5072 procedure Add_Pragma (Prag : Node_Id) is 5073 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag); 5074 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 5075 Unit_Arg : Node_Id; 5076 5077 begin 5078 -- Nothing to do if the pragma is not related to elaboration 5079 5080 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then 5081 return; 5082 5083 -- Nothing to do when the pragma is illegal 5084 5085 elsif Error_Posted (Prag) then 5086 return; 5087 end if; 5088 5089 Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); 5090 5091 -- The argument of the pragma may appear in package.package form 5092 5093 if Nkind (Unit_Arg) = N_Selected_Component then 5094 Unit_Arg := Selector_Name (Unit_Arg); 5095 end if; 5096 5097 Add_Unit 5098 (Unit_Id => Entity (Unit_Arg), 5099 Prag => Prag, 5100 Full_Context => Prag_Nam = Name_Elaborate_All); 5101 end Add_Pragma; 5102 5103 -------------- 5104 -- Add_Unit -- 5105 -------------- 5106 5107 procedure Add_Unit 5108 (Unit_Id : Entity_Id; 5109 Prag : Node_Id; 5110 Full_Context : Boolean) 5111 is 5112 Clause : Node_Id; 5113 Elab_Attrs : Elaboration_Attributes; 5114 5115 begin 5116 -- Nothing to do when some previous error left a with clause or a 5117 -- pragma in a bad state. 5118 5119 if No (Unit_Id) then 5120 return; 5121 end if; 5122 5123 Elab_Attrs := Elaboration_Status (Unit_Id); 5124 5125 -- The unit is already included in the context by means of pragma 5126 -- Elaborate[_All]. 5127 5128 if Present (Elab_Attrs.Source_Pragma) then 5129 5130 -- Upgrade an existing pragma Elaborate when the unit is subject 5131 -- to Elaborate_All because the new pragma covers a larger set of 5132 -- units. 5133 5134 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate 5135 and then Pragma_Name (Prag) = Name_Elaborate_All 5136 then 5137 Elab_Attrs.Source_Pragma := Prag; 5138 5139 -- Otherwise the unit retains its existing pragma and does not 5140 -- need to be included in the context again. 5141 5142 else 5143 return; 5144 end if; 5145 5146 -- The current unit is not part of the context. Prepare a new set of 5147 -- attributes. 5148 5149 else 5150 Elab_Attrs := 5151 Elaboration_Attributes'(Source_Pragma => Prag, 5152 With_Clause => Empty); 5153 end if; 5154 5155 -- Add or update the attributes of the unit 5156 5157 Set_Elaboration_Status (Unit_Id, Elab_Attrs); 5158 5159 -- Includes all units withed by the current one when computing the 5160 -- full context. 5161 5162 if Full_Context then 5163 5164 -- Process all nonlimited with clauses found in the context of 5165 -- the current unit. Note that limited clauses do not impose an 5166 -- elaboration order. 5167 5168 Clause := First (Context_Items (Compilation_Unit (Unit_Id))); 5169 while Present (Clause) loop 5170 if Nkind (Clause) = N_With_Clause 5171 and then not Error_Posted (Clause) 5172 and then not Limited_Present (Clause) 5173 then 5174 Add_Unit 5175 (Unit_Id => Entity (Name (Clause)), 5176 Prag => Prag, 5177 Full_Context => Full_Context); 5178 end if; 5179 5180 Next (Clause); 5181 end loop; 5182 end if; 5183 end Add_Unit; 5184 5185 ------------------------------ 5186 -- Find_Elaboration_Context -- 5187 ------------------------------ 5188 5189 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is 5190 Prag : Node_Id; 5191 5192 begin 5193 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 5194 5195 -- Process all elaboration-related pragmas found in the context of 5196 -- the compilation unit. 5197 5198 Prag := First (Context_Items (Comp_Unit)); 5199 while Present (Prag) loop 5200 if Nkind (Prag) = N_Pragma then 5201 Add_Pragma (Prag); 5202 end if; 5203 5204 Next (Prag); 5205 end loop; 5206 end Find_Elaboration_Context; 5207 5208 -- Local variables 5209 5210 Par_Id : Entity_Id; 5211 Unt : Node_Id; 5212 5213 -- Start of processing for Find_Elaborated_Units 5214 5215 begin 5216 -- Perform a traversal which examines the context of the main unit and 5217 -- populates the Elaboration_Context table with all units elaborated 5218 -- prior to the main unit. The traversal performs the following jumps: 5219 5220 -- subunit -> parent subunit 5221 -- parent subunit -> body 5222 -- body -> spec 5223 -- spec -> parent spec 5224 -- parent spec -> grandparent spec and so on 5225 5226 -- The traversal relies on units rather than scopes because the scope of 5227 -- a subunit is some spec, while this traversal must process the body as 5228 -- well. Given that protected and task bodies can also be subunits, this 5229 -- complicates the scope approach even further. 5230 5231 Unt := Unit (Cunit (Main_Unit)); 5232 5233 -- Perform the following traversals when the main unit is a subunit 5234 5235 -- subunit -> parent subunit 5236 -- parent subunit -> body 5237 5238 while Present (Unt) and then Nkind (Unt) = N_Subunit loop 5239 Find_Elaboration_Context (Parent (Unt)); 5240 5241 -- Continue the traversal by going to the unit which contains the 5242 -- corresponding stub. 5243 5244 if Present (Corresponding_Stub (Unt)) then 5245 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt)))); 5246 5247 -- Otherwise the subunit may be erroneous or left in a bad state 5248 5249 else 5250 exit; 5251 end if; 5252 end loop; 5253 5254 -- Perform the following traversal now that subunits have been taken 5255 -- care of, or the main unit is a body. 5256 5257 -- body -> spec 5258 5259 if Present (Unt) 5260 and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) 5261 then 5262 Find_Elaboration_Context (Parent (Unt)); 5263 5264 -- Continue the traversal by going to the unit which contains the 5265 -- corresponding spec. 5266 5267 if Present (Corresponding_Spec (Unt)) then 5268 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt)))); 5269 end if; 5270 end if; 5271 5272 -- Perform the following traversals now that the body has been taken 5273 -- care of, or the main unit is a spec. 5274 5275 -- spec -> parent spec 5276 -- parent spec -> grandparent spec and so on 5277 5278 if Present (Unt) 5279 and then Nkind_In (Unt, N_Generic_Package_Declaration, 5280 N_Generic_Subprogram_Declaration, 5281 N_Package_Declaration, 5282 N_Subprogram_Declaration) 5283 then 5284 Find_Elaboration_Context (Parent (Unt)); 5285 5286 -- Process a potential chain of parent units which ends with the 5287 -- main unit spec. The traversal can now safely rely on the scope 5288 -- chain. 5289 5290 Par_Id := Scope (Defining_Entity (Unt)); 5291 while Present (Par_Id) and then Par_Id /= Standard_Standard loop 5292 Find_Elaboration_Context (Compilation_Unit (Par_Id)); 5293 5294 Par_Id := Scope (Par_Id); 5295 end loop; 5296 end if; 5297 end Find_Elaborated_Units; 5298 5299 ----------------------------- 5300 -- Find_Enclosing_Instance -- 5301 ----------------------------- 5302 5303 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is 5304 Par : Node_Id; 5305 Spec_Id : Entity_Id; 5306 5307 begin 5308 -- Climb the parent chain looking for an enclosing instance spec or body 5309 5310 Par := N; 5311 while Present (Par) loop 5312 5313 -- Generic package or subprogram spec 5314 5315 if Nkind_In (Par, N_Package_Declaration, 5316 N_Subprogram_Declaration) 5317 and then Is_Generic_Instance (Defining_Entity (Par)) 5318 then 5319 return Par; 5320 5321 -- Generic package or subprogram body 5322 5323 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then 5324 Spec_Id := Corresponding_Spec (Par); 5325 5326 if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then 5327 return Par; 5328 end if; 5329 end if; 5330 5331 Par := Parent (Par); 5332 end loop; 5333 5334 return Empty; 5335 end Find_Enclosing_Instance; 5336 5337 -------------------------- 5338 -- Find_Enclosing_Level -- 5339 -------------------------- 5340 5341 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is 5342 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; 5343 -- Obtain the corresponding level of unit Unit 5344 5345 -------------- 5346 -- Level_Of -- 5347 -------------- 5348 5349 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is 5350 Spec_Id : Entity_Id; 5351 5352 begin 5353 if Nkind (Unit) in N_Generic_Instantiation then 5354 return Instantiation; 5355 5356 elsif Nkind (Unit) = N_Generic_Package_Declaration then 5357 return Generic_Package_Spec; 5358 5359 elsif Nkind (Unit) = N_Package_Declaration then 5360 return Package_Spec; 5361 5362 elsif Nkind (Unit) = N_Package_Body then 5363 Spec_Id := Corresponding_Spec (Unit); 5364 5365 -- The body belongs to a generic package 5366 5367 if Present (Spec_Id) 5368 and then Ekind (Spec_Id) = E_Generic_Package 5369 then 5370 return Generic_Package_Body; 5371 5372 -- Otherwise the body belongs to a non-generic package. This also 5373 -- treats an illegal package body without a corresponding spec as 5374 -- a non-generic package body. 5375 5376 else 5377 return Package_Body; 5378 end if; 5379 end if; 5380 5381 return No_Level; 5382 end Level_Of; 5383 5384 -- Local variables 5385 5386 Context : Node_Id; 5387 Curr : Node_Id; 5388 Prev : Node_Id; 5389 5390 -- Start of processing for Find_Enclosing_Level 5391 5392 begin 5393 -- Call markers and instantiations which appear at the declaration level 5394 -- but are later relocated in a different context retain their original 5395 -- declaration level. 5396 5397 if Nkind_In (N, N_Call_Marker, 5398 N_Function_Instantiation, 5399 N_Package_Instantiation, 5400 N_Procedure_Instantiation) 5401 and then Is_Declaration_Level_Node (N) 5402 then 5403 return Declaration_Level; 5404 end if; 5405 5406 -- Climb the parent chain looking at the enclosing levels 5407 5408 Prev := N; 5409 Curr := Parent (Prev); 5410 while Present (Curr) loop 5411 5412 -- A traversal from a subunit continues via the corresponding stub 5413 5414 if Nkind (Curr) = N_Subunit then 5415 Curr := Corresponding_Stub (Curr); 5416 5417 -- The current construct is a package. Packages are ignored because 5418 -- they are always elaborated when the enclosing context is invoked 5419 -- or elaborated. 5420 5421 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then 5422 null; 5423 5424 -- The current construct is a block statement 5425 5426 elsif Nkind (Curr) = N_Block_Statement then 5427 5428 -- Ignore internally generated blocks created by the expander for 5429 -- various purposes such as abort defer/undefer. 5430 5431 if not Comes_From_Source (Curr) then 5432 null; 5433 5434 -- If the traversal came from the handled sequence of statments, 5435 -- then the node appears at the level of the enclosing construct. 5436 -- This is a more reliable test because transients scopes within 5437 -- the declarative region of the encapsulator are hard to detect. 5438 5439 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements 5440 and then Handled_Statement_Sequence (Curr) = Prev 5441 then 5442 return Find_Enclosing_Level (Parent (Curr)); 5443 5444 -- Otherwise the traversal came from the declarations, the node is 5445 -- at the declaration level. 5446 5447 else 5448 return Declaration_Level; 5449 end if; 5450 5451 -- The current construct is a declaration-level encapsulator 5452 5453 elsif Nkind_In (Curr, N_Entry_Body, 5454 N_Subprogram_Body, 5455 N_Task_Body) 5456 then 5457 -- If the traversal came from the handled sequence of statments, 5458 -- then the node cannot possibly appear at any level. This is 5459 -- a more reliable test because transients scopes within the 5460 -- declarative region of the encapsulator are hard to detect. 5461 5462 if Nkind (Prev) = N_Handled_Sequence_Of_Statements 5463 and then Handled_Statement_Sequence (Curr) = Prev 5464 then 5465 return No_Level; 5466 5467 -- Otherwise the traversal came from the declarations, the node is 5468 -- at the declaration level. 5469 5470 else 5471 return Declaration_Level; 5472 end if; 5473 5474 -- The current construct is a non-library-level encapsulator which 5475 -- indicates that the node cannot possibly appear at any level. 5476 -- Note that this check must come after the declaration-level check 5477 -- because both predicates share certain nodes. 5478 5479 elsif Is_Non_Library_Level_Encapsulator (Curr) then 5480 Context := Parent (Curr); 5481 5482 -- The sole exception is when the encapsulator is the compilation 5483 -- utit itself because the compilation unit node requires special 5484 -- processing (see below). 5485 5486 if Present (Context) 5487 and then Nkind (Context) = N_Compilation_Unit 5488 then 5489 null; 5490 5491 -- Otherwise the node is not at any level 5492 5493 else 5494 return No_Level; 5495 end if; 5496 5497 -- The current construct is a compilation unit. The node appears at 5498 -- the [generic] library level when the unit is a [generic] package. 5499 5500 elsif Nkind (Curr) = N_Compilation_Unit then 5501 return Level_Of (Unit (Curr)); 5502 end if; 5503 5504 Prev := Curr; 5505 Curr := Parent (Prev); 5506 end loop; 5507 5508 return No_Level; 5509 end Find_Enclosing_Level; 5510 5511 ------------------- 5512 -- Find_Top_Unit -- 5513 ------------------- 5514 5515 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is 5516 begin 5517 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); 5518 end Find_Top_Unit; 5519 5520 ---------------------- 5521 -- Find_Unit_Entity -- 5522 ---------------------- 5523 5524 function Find_Unit_Entity (N : Node_Id) return Entity_Id is 5525 Context : constant Node_Id := Parent (N); 5526 Orig_N : constant Node_Id := Original_Node (N); 5527 5528 begin 5529 -- The unit denotes a package body of an instantiation which acts as 5530 -- a compilation unit. The proper entity is that of the package spec. 5531 5532 if Nkind (N) = N_Package_Body 5533 and then Nkind (Orig_N) = N_Package_Instantiation 5534 and then Nkind (Context) = N_Compilation_Unit 5535 then 5536 return Corresponding_Spec (N); 5537 5538 -- The unit denotes an anonymous package created to wrap a subprogram 5539 -- instantiation which acts as a compilation unit. The proper entity is 5540 -- that of the "related instance". 5541 5542 elsif Nkind (N) = N_Package_Declaration 5543 and then Nkind_In (Orig_N, N_Function_Instantiation, 5544 N_Procedure_Instantiation) 5545 and then Nkind (Context) = N_Compilation_Unit 5546 then 5547 return 5548 Related_Instance (Defining_Entity (N, Concurrent_Subunit => True)); 5549 5550 -- Otherwise the proper entity is the defining entity 5551 5552 else 5553 return Defining_Entity (N, Concurrent_Subunit => True); 5554 end if; 5555 end Find_Unit_Entity; 5556 5557 ----------------------- 5558 -- First_Formal_Type -- 5559 ----------------------- 5560 5561 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is 5562 Formal_Id : constant Entity_Id := First_Formal (Subp_Id); 5563 Typ : Entity_Id; 5564 5565 begin 5566 if Present (Formal_Id) then 5567 Typ := Etype (Formal_Id); 5568 5569 -- Handle various combinations of concurrent and private types 5570 5571 loop 5572 if Ekind_In (Typ, E_Protected_Type, E_Task_Type) 5573 and then Present (Anonymous_Object (Typ)) 5574 then 5575 Typ := Anonymous_Object (Typ); 5576 5577 elsif Is_Concurrent_Record_Type (Typ) then 5578 Typ := Corresponding_Concurrent_Type (Typ); 5579 5580 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 5581 Typ := Full_View (Typ); 5582 5583 else 5584 exit; 5585 end if; 5586 end loop; 5587 5588 return Typ; 5589 end if; 5590 5591 return Empty; 5592 end First_Formal_Type; 5593 5594 -------------- 5595 -- Has_Body -- 5596 -------------- 5597 5598 function Has_Body (Pack_Decl : Node_Id) return Boolean is 5599 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; 5600 -- Try to locate the corresponding body of spec Spec_Id. If no body is 5601 -- found, return Empty. 5602 5603 function Find_Body 5604 (Spec_Id : Entity_Id; 5605 From : Node_Id) return Node_Id; 5606 -- Try to locate the corresponding body of spec Spec_Id in the node list 5607 -- which follows arbitrary node From. If no body is found, return Empty. 5608 5609 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; 5610 -- Attempt to load the body of unit Unit_Nam. If the load failed, return 5611 -- Empty. If the compilation will not generate code, return Empty. 5612 5613 ----------------------------- 5614 -- Find_Corresponding_Body -- 5615 ----------------------------- 5616 5617 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is 5618 Context : constant Entity_Id := Scope (Spec_Id); 5619 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 5620 Body_Decl : Node_Id; 5621 Body_Id : Entity_Id; 5622 5623 begin 5624 if Is_Compilation_Unit (Spec_Id) then 5625 Body_Id := Corresponding_Body (Spec_Decl); 5626 5627 if Present (Body_Id) then 5628 return Unit_Declaration_Node (Body_Id); 5629 5630 -- The package is at the library and requires a body. Load the 5631 -- corresponding body because the optional body may be declared 5632 -- there. 5633 5634 elsif Unit_Requires_Body (Spec_Id) then 5635 return 5636 Load_Package_Body 5637 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); 5638 5639 -- Otherwise there is no optional body 5640 5641 else 5642 return Empty; 5643 end if; 5644 5645 -- The immediate context is a package. The optional body may be 5646 -- within the body of that package. 5647 5648 -- procedure Proc is 5649 -- package Nested_1 is 5650 -- package Nested_2 is 5651 -- generic 5652 -- package Pack is 5653 -- end Pack; 5654 -- end Nested_2; 5655 -- end Nested_1; 5656 5657 -- package body Nested_1 is 5658 -- package body Nested_2 is separate; 5659 -- end Nested_1; 5660 5661 -- separate (Proc.Nested_1.Nested_2) 5662 -- package body Nested_2 is 5663 -- package body Pack is -- optional body 5664 -- ... 5665 -- end Pack; 5666 -- end Nested_2; 5667 5668 elsif Is_Package_Or_Generic_Package (Context) then 5669 Body_Decl := Find_Corresponding_Body (Context); 5670 5671 -- The optional body is within the body of the enclosing package 5672 5673 if Present (Body_Decl) then 5674 return 5675 Find_Body 5676 (Spec_Id => Spec_Id, 5677 From => First (Declarations (Body_Decl))); 5678 5679 -- Otherwise the enclosing package does not have a body. This may 5680 -- be the result of an error or a genuine lack of a body. 5681 5682 else 5683 return Empty; 5684 end if; 5685 5686 -- Otherwise the immediate context is a body. The optional body may 5687 -- be within the same list as the spec. 5688 5689 -- procedure Proc is 5690 -- generic 5691 -- package Pack is 5692 -- end Pack; 5693 5694 -- package body Pack is -- optional body 5695 -- ... 5696 -- end Pack; 5697 5698 else 5699 return 5700 Find_Body 5701 (Spec_Id => Spec_Id, 5702 From => Next (Spec_Decl)); 5703 end if; 5704 end Find_Corresponding_Body; 5705 5706 --------------- 5707 -- Find_Body -- 5708 --------------- 5709 5710 function Find_Body 5711 (Spec_Id : Entity_Id; 5712 From : Node_Id) return Node_Id 5713 is 5714 Spec_Nam : constant Name_Id := Chars (Spec_Id); 5715 Item : Node_Id; 5716 Lib_Unit : Node_Id; 5717 5718 begin 5719 Item := From; 5720 while Present (Item) loop 5721 5722 -- The current item denotes the optional body 5723 5724 if Nkind (Item) = N_Package_Body 5725 and then Chars (Defining_Entity (Item)) = Spec_Nam 5726 then 5727 return Item; 5728 5729 -- The current item denotes a stub, the optional body may be in 5730 -- the subunit. 5731 5732 elsif Nkind (Item) = N_Package_Body_Stub 5733 and then Chars (Defining_Entity (Item)) = Spec_Nam 5734 then 5735 Lib_Unit := Library_Unit (Item); 5736 5737 -- The corresponding subunit was previously loaded 5738 5739 if Present (Lib_Unit) then 5740 return Lib_Unit; 5741 5742 -- Otherwise attempt to load the corresponding subunit 5743 5744 else 5745 return Load_Package_Body (Get_Unit_Name (Item)); 5746 end if; 5747 end if; 5748 5749 Next (Item); 5750 end loop; 5751 5752 return Empty; 5753 end Find_Body; 5754 5755 ----------------------- 5756 -- Load_Package_Body -- 5757 ----------------------- 5758 5759 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is 5760 Body_Decl : Node_Id; 5761 Unit_Num : Unit_Number_Type; 5762 5763 begin 5764 -- The load is performed only when the compilation will generate code 5765 5766 if Operating_Mode = Generate_Code then 5767 Unit_Num := 5768 Load_Unit 5769 (Load_Name => Unit_Nam, 5770 Required => False, 5771 Subunit => False, 5772 Error_Node => Pack_Decl); 5773 5774 -- The load failed most likely because the physical file is 5775 -- missing. 5776 5777 if Unit_Num = No_Unit then 5778 return Empty; 5779 5780 -- Otherwise the load was successful, return the body of the unit 5781 5782 else 5783 Body_Decl := Unit (Cunit (Unit_Num)); 5784 5785 -- If the unit is a subunit with an available proper body, 5786 -- return the proper body. 5787 5788 if Nkind (Body_Decl) = N_Subunit 5789 and then Present (Proper_Body (Body_Decl)) 5790 then 5791 Body_Decl := Proper_Body (Body_Decl); 5792 end if; 5793 5794 return Body_Decl; 5795 end if; 5796 end if; 5797 5798 return Empty; 5799 end Load_Package_Body; 5800 5801 -- Local variables 5802 5803 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 5804 5805 -- Start of processing for Has_Body 5806 5807 begin 5808 -- The body is available 5809 5810 if Present (Corresponding_Body (Pack_Decl)) then 5811 return True; 5812 5813 -- The body is required if the package spec contains a construct which 5814 -- requires a completion in a body. 5815 5816 elsif Unit_Requires_Body (Pack_Id) then 5817 return True; 5818 5819 -- The body may be optional 5820 5821 else 5822 return Present (Find_Corresponding_Body (Pack_Id)); 5823 end if; 5824 end Has_Body; 5825 5826 --------------------------- 5827 -- Has_Prior_Elaboration -- 5828 --------------------------- 5829 5830 function Has_Prior_Elaboration 5831 (Unit_Id : Entity_Id; 5832 Context_OK : Boolean := False; 5833 Elab_Body_OK : Boolean := False; 5834 Same_Unit_OK : Boolean := False) return Boolean 5835 is 5836 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); 5837 5838 begin 5839 -- A preelaborated unit is always elaborated prior to the main unit 5840 5841 if Is_Preelaborated_Unit (Unit_Id) then 5842 return True; 5843 5844 -- An internal unit is always elaborated prior to a non-internal main 5845 -- unit. 5846 5847 elsif In_Internal_Unit (Unit_Id) 5848 and then not In_Internal_Unit (Main_Id) 5849 then 5850 return True; 5851 5852 -- A unit has prior elaboration if it appears within the context of the 5853 -- main unit. Consider this case only when requested by the caller. 5854 5855 elsif Context_OK 5856 and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes 5857 then 5858 return True; 5859 5860 -- A unit whose body is elaborated together with its spec has prior 5861 -- elaboration except with respect to itself. Consider this case only 5862 -- when requested by the caller. 5863 5864 elsif Elab_Body_OK 5865 and then Has_Pragma_Elaborate_Body (Unit_Id) 5866 and then not Is_Same_Unit (Unit_Id, Main_Id) 5867 then 5868 return True; 5869 5870 -- A unit has no prior elaboration with respect to itself, but does not 5871 -- require any means of ensuring its own elaboration either. Treat this 5872 -- case as valid prior elaboration only when requested by the caller. 5873 5874 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then 5875 return True; 5876 end if; 5877 5878 return False; 5879 end Has_Prior_Elaboration; 5880 5881 -------------------------- 5882 -- In_External_Instance -- 5883 -------------------------- 5884 5885 function In_External_Instance 5886 (N : Node_Id; 5887 Target_Decl : Node_Id) return Boolean 5888 is 5889 Dummy : Node_Id; 5890 Inst_Body : Node_Id; 5891 Inst_Decl : Node_Id; 5892 5893 begin 5894 -- Performance note: parent traversal 5895 5896 Inst_Decl := Find_Enclosing_Instance (Target_Decl); 5897 5898 -- The target declaration appears within an instance spec. Visibility is 5899 -- ignored because internally generated primitives for private types may 5900 -- reside in the private declarations and still be invoked from outside. 5901 5902 if Present (Inst_Decl) 5903 and then Nkind (Inst_Decl) = N_Package_Declaration 5904 then 5905 -- The scenario comes from the main unit and the instance does not 5906 5907 if In_Extended_Main_Code_Unit (N) 5908 and then not In_Extended_Main_Code_Unit (Inst_Decl) 5909 then 5910 return True; 5911 5912 -- Otherwise the scenario must not appear within the instance spec or 5913 -- body. 5914 5915 else 5916 Extract_Instance_Attributes 5917 (Exp_Inst => Inst_Decl, 5918 Inst_Body => Inst_Body, 5919 Inst_Decl => Dummy); 5920 5921 -- Performance note: parent traversal 5922 5923 return not In_Subtree 5924 (N => N, 5925 Root1 => Inst_Decl, 5926 Root2 => Inst_Body); 5927 end if; 5928 end if; 5929 5930 return False; 5931 end In_External_Instance; 5932 5933 --------------------- 5934 -- In_Main_Context -- 5935 --------------------- 5936 5937 function In_Main_Context (N : Node_Id) return Boolean is 5938 begin 5939 -- Scenarios outside the main unit are not considered because the ALI 5940 -- information supplied to binde is for the main unit only. 5941 5942 if not In_Extended_Main_Code_Unit (N) then 5943 return False; 5944 5945 -- Scenarios within internal units are not considered unless switch 5946 -- -gnatdE (elaboration checks on predefined units) is in effect. 5947 5948 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then 5949 return False; 5950 end if; 5951 5952 return True; 5953 end In_Main_Context; 5954 5955 --------------------- 5956 -- In_Same_Context -- 5957 --------------------- 5958 5959 function In_Same_Context 5960 (N1 : Node_Id; 5961 N2 : Node_Id; 5962 Nested_OK : Boolean := False) return Boolean 5963 is 5964 function Find_Enclosing_Context (N : Node_Id) return Node_Id; 5965 -- Return the nearest enclosing non-library-level or compilation unit 5966 -- node which which encapsulates arbitrary node N. Return Empty is no 5967 -- such context is available. 5968 5969 function In_Nested_Context 5970 (Outer : Node_Id; 5971 Inner : Node_Id) return Boolean; 5972 -- Determine whether arbitrary node Outer encapsulates arbitrary node 5973 -- Inner. 5974 5975 ---------------------------- 5976 -- Find_Enclosing_Context -- 5977 ---------------------------- 5978 5979 function Find_Enclosing_Context (N : Node_Id) return Node_Id is 5980 Context : Node_Id; 5981 Par : Node_Id; 5982 5983 begin 5984 Par := Parent (N); 5985 while Present (Par) loop 5986 5987 -- A traversal from a subunit continues via the corresponding stub 5988 5989 if Nkind (Par) = N_Subunit then 5990 Par := Corresponding_Stub (Par); 5991 5992 -- Stop the traversal when the nearest enclosing non-library-level 5993 -- encapsulator has been reached. 5994 5995 elsif Is_Non_Library_Level_Encapsulator (Par) then 5996 Context := Parent (Par); 5997 5998 -- The sole exception is when the encapsulator is the unit of 5999 -- compilation because this case requires special processing 6000 -- (see below). 6001 6002 if Present (Context) 6003 and then Nkind (Context) = N_Compilation_Unit 6004 then 6005 null; 6006 6007 else 6008 return Par; 6009 end if; 6010 6011 -- Reaching a compilation unit node without hitting a non-library- 6012 -- level encapsulator indicates that N is at the library level in 6013 -- which case the compilation unit is the context. 6014 6015 elsif Nkind (Par) = N_Compilation_Unit then 6016 return Par; 6017 end if; 6018 6019 Par := Parent (Par); 6020 end loop; 6021 6022 return Empty; 6023 end Find_Enclosing_Context; 6024 6025 ----------------------- 6026 -- In_Nested_Context -- 6027 ----------------------- 6028 6029 function In_Nested_Context 6030 (Outer : Node_Id; 6031 Inner : Node_Id) return Boolean 6032 is 6033 Par : Node_Id; 6034 6035 begin 6036 Par := Inner; 6037 while Present (Par) loop 6038 6039 -- A traversal from a subunit continues via the corresponding stub 6040 6041 if Nkind (Par) = N_Subunit then 6042 Par := Corresponding_Stub (Par); 6043 6044 elsif Par = Outer then 6045 return True; 6046 end if; 6047 6048 Par := Parent (Par); 6049 end loop; 6050 6051 return False; 6052 end In_Nested_Context; 6053 6054 -- Local variables 6055 6056 Context_1 : constant Node_Id := Find_Enclosing_Context (N1); 6057 Context_2 : constant Node_Id := Find_Enclosing_Context (N2); 6058 6059 -- Start of processing for In_Same_Context 6060 6061 begin 6062 -- Both nodes appear within the same context 6063 6064 if Context_1 = Context_2 then 6065 return True; 6066 6067 -- Both nodes appear in compilation units. Determine whether one unit 6068 -- is the body of the other. 6069 6070 elsif Nkind (Context_1) = N_Compilation_Unit 6071 and then Nkind (Context_2) = N_Compilation_Unit 6072 then 6073 return 6074 Is_Same_Unit 6075 (Unit_1 => Defining_Entity (Unit (Context_1)), 6076 Unit_2 => Defining_Entity (Unit (Context_2))); 6077 6078 -- The context of N1 encloses the context of N2 6079 6080 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then 6081 return True; 6082 end if; 6083 6084 return False; 6085 end In_Same_Context; 6086 6087 ------------------ 6088 -- In_Task_Body -- 6089 ------------------ 6090 6091 function In_Task_Body (N : Node_Id) return Boolean is 6092 Par : Node_Id; 6093 6094 begin 6095 -- Climb the parent chain looking for a task body [procedure] 6096 6097 Par := N; 6098 while Present (Par) loop 6099 if Nkind (Par) = N_Task_Body then 6100 return True; 6101 6102 elsif Nkind (Par) = N_Subprogram_Body 6103 and then Is_Task_Body_Procedure (Par) 6104 then 6105 return True; 6106 6107 -- Prevent the search from going too far. Note that this predicate 6108 -- shares nodes with the two cases above, and must come last. 6109 6110 elsif Is_Body_Or_Package_Declaration (Par) then 6111 return False; 6112 end if; 6113 6114 Par := Parent (Par); 6115 end loop; 6116 6117 return False; 6118 end In_Task_Body; 6119 6120 ---------------- 6121 -- Initialize -- 6122 ---------------- 6123 6124 procedure Initialize is 6125 begin 6126 -- Set the soft link which enables Atree.Rewrite to update a top-level 6127 -- scenario each time it is transformed into another node. 6128 6129 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 6130 end Initialize; 6131 6132 --------------- 6133 -- Info_Call -- 6134 --------------- 6135 6136 procedure Info_Call 6137 (Call : Node_Id; 6138 Target_Id : Entity_Id; 6139 Info_Msg : Boolean; 6140 In_SPARK : Boolean) 6141 is 6142 procedure Info_Accept_Alternative; 6143 pragma Inline (Info_Accept_Alternative); 6144 -- Output information concerning an accept alternative 6145 6146 procedure Info_Simple_Call; 6147 pragma Inline (Info_Simple_Call); 6148 -- Output information concerning the call 6149 6150 procedure Info_Type_Actions (Action : String); 6151 pragma Inline (Info_Type_Actions); 6152 -- Output information concerning action Action of a type 6153 6154 procedure Info_Verification_Call 6155 (Pred : String; 6156 Id : Entity_Id; 6157 Id_Kind : String); 6158 pragma Inline (Info_Verification_Call); 6159 -- Output information concerning the verification of predicate Pred 6160 -- applied to related entity Id with kind Id_Kind. 6161 6162 ----------------------------- 6163 -- Info_Accept_Alternative -- 6164 ----------------------------- 6165 6166 procedure Info_Accept_Alternative is 6167 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 6168 6169 begin 6170 pragma Assert (Present (Entry_Id)); 6171 6172 Elab_Msg_NE 6173 (Msg => "accept for entry & during elaboration", 6174 N => Call, 6175 Id => Entry_Id, 6176 Info_Msg => Info_Msg, 6177 In_SPARK => In_SPARK); 6178 end Info_Accept_Alternative; 6179 6180 ---------------------- 6181 -- Info_Simple_Call -- 6182 ---------------------- 6183 6184 procedure Info_Simple_Call is 6185 begin 6186 Elab_Msg_NE 6187 (Msg => "call to & during elaboration", 6188 N => Call, 6189 Id => Target_Id, 6190 Info_Msg => Info_Msg, 6191 In_SPARK => In_SPARK); 6192 end Info_Simple_Call; 6193 6194 ----------------------- 6195 -- Info_Type_Actions -- 6196 ----------------------- 6197 6198 procedure Info_Type_Actions (Action : String) is 6199 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 6200 6201 begin 6202 pragma Assert (Present (Typ)); 6203 6204 Elab_Msg_NE 6205 (Msg => Action & " actions for type & during elaboration", 6206 N => Call, 6207 Id => Typ, 6208 Info_Msg => Info_Msg, 6209 In_SPARK => In_SPARK); 6210 end Info_Type_Actions; 6211 6212 ---------------------------- 6213 -- Info_Verification_Call -- 6214 ---------------------------- 6215 6216 procedure Info_Verification_Call 6217 (Pred : String; 6218 Id : Entity_Id; 6219 Id_Kind : String) 6220 is 6221 begin 6222 pragma Assert (Present (Id)); 6223 6224 Elab_Msg_NE 6225 (Msg => 6226 "verification of " & Pred & " of " & Id_Kind & " & during " 6227 & "elaboration", 6228 N => Call, 6229 Id => Id, 6230 Info_Msg => Info_Msg, 6231 In_SPARK => In_SPARK); 6232 end Info_Verification_Call; 6233 6234 -- Start of processing for Info_Call 6235 6236 begin 6237 -- Do not output anything for targets defined in internal units because 6238 -- this creates noise. 6239 6240 if not In_Internal_Unit (Target_Id) then 6241 6242 -- Accept alternative 6243 6244 if Is_Accept_Alternative_Proc (Target_Id) then 6245 Info_Accept_Alternative; 6246 6247 -- Adjustment 6248 6249 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 6250 Info_Type_Actions ("adjustment"); 6251 6252 -- Default_Initial_Condition 6253 6254 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 6255 Info_Verification_Call 6256 (Pred => "Default_Initial_Condition", 6257 Id => First_Formal_Type (Target_Id), 6258 Id_Kind => "type"); 6259 6260 -- Entries 6261 6262 elsif Is_Protected_Entry (Target_Id) then 6263 Info_Simple_Call; 6264 6265 -- Task entry calls are never processed because the entry being 6266 -- invoked does not have a corresponding "body", it has a select. 6267 6268 elsif Is_Task_Entry (Target_Id) then 6269 null; 6270 6271 -- Finalization 6272 6273 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 6274 Info_Type_Actions ("finalization"); 6275 6276 -- Calls to _Finalizer procedures must not appear in the output 6277 -- because this creates confusing noise. 6278 6279 elsif Is_Finalizer_Proc (Target_Id) then 6280 null; 6281 6282 -- Initial_Condition 6283 6284 elsif Is_Initial_Condition_Proc (Target_Id) then 6285 Info_Verification_Call 6286 (Pred => "Initial_Condition", 6287 Id => Find_Enclosing_Scope (Call), 6288 Id_Kind => "package"); 6289 6290 -- Initialization 6291 6292 elsif Is_Init_Proc (Target_Id) 6293 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 6294 then 6295 Info_Type_Actions ("initialization"); 6296 6297 -- Invariant 6298 6299 elsif Is_Invariant_Proc (Target_Id) then 6300 Info_Verification_Call 6301 (Pred => "invariants", 6302 Id => First_Formal_Type (Target_Id), 6303 Id_Kind => "type"); 6304 6305 -- Partial invariant calls must not appear in the output because this 6306 -- creates confusing noise. 6307 6308 elsif Is_Partial_Invariant_Proc (Target_Id) then 6309 null; 6310 6311 -- _Postconditions 6312 6313 elsif Is_Postconditions_Proc (Target_Id) then 6314 Info_Verification_Call 6315 (Pred => "postconditions", 6316 Id => Find_Enclosing_Scope (Call), 6317 Id_Kind => "subprogram"); 6318 6319 -- Subprograms must come last because some of the previous cases fall 6320 -- under this category. 6321 6322 elsif Ekind (Target_Id) = E_Function then 6323 Info_Simple_Call; 6324 6325 elsif Ekind (Target_Id) = E_Procedure then 6326 Info_Simple_Call; 6327 6328 else 6329 pragma Assert (False); 6330 null; 6331 end if; 6332 end if; 6333 end Info_Call; 6334 6335 ------------------------ 6336 -- Info_Instantiation -- 6337 ------------------------ 6338 6339 procedure Info_Instantiation 6340 (Inst : Node_Id; 6341 Gen_Id : Entity_Id; 6342 Info_Msg : Boolean; 6343 In_SPARK : Boolean) 6344 is 6345 begin 6346 Elab_Msg_NE 6347 (Msg => "instantiation of & during elaboration", 6348 N => Inst, 6349 Id => Gen_Id, 6350 Info_Msg => Info_Msg, 6351 In_SPARK => In_SPARK); 6352 end Info_Instantiation; 6353 6354 ----------------------------- 6355 -- Info_Variable_Reference -- 6356 ----------------------------- 6357 6358 procedure Info_Variable_Reference 6359 (Ref : Node_Id; 6360 Var_Id : Entity_Id; 6361 Info_Msg : Boolean; 6362 In_SPARK : Boolean) 6363 is 6364 begin 6365 if Is_Read (Ref) then 6366 Elab_Msg_NE 6367 (Msg => "read of variable & during elaboration", 6368 N => Ref, 6369 Id => Var_Id, 6370 Info_Msg => Info_Msg, 6371 In_SPARK => In_SPARK); 6372 end if; 6373 end Info_Variable_Reference; 6374 6375 -------------------- 6376 -- Insertion_Node -- 6377 -------------------- 6378 6379 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is 6380 begin 6381 -- When the scenario denotes an instantiation, the proper insertion node 6382 -- is the instance spec. This ensures that the generic actuals will not 6383 -- be evaluated prior to a potential ABE. 6384 6385 if Nkind (N) in N_Generic_Instantiation 6386 and then Present (Instance_Spec (N)) 6387 then 6388 return Instance_Spec (N); 6389 6390 -- Otherwise the proper insertion node is the candidate insertion node 6391 6392 else 6393 return Ins_Nod; 6394 end if; 6395 end Insertion_Node; 6396 6397 ----------------------- 6398 -- Install_ABE_Check -- 6399 ----------------------- 6400 6401 procedure Install_ABE_Check 6402 (N : Node_Id; 6403 Id : Entity_Id; 6404 Ins_Nod : Node_Id) 6405 is 6406 Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6407 -- Insert the check prior to this node 6408 6409 Loc : constant Source_Ptr := Sloc (N); 6410 Spec_Id : constant Entity_Id := Unique_Entity (Id); 6411 Unit_Id : constant Entity_Id := Find_Top_Unit (Id); 6412 Scop_Id : Entity_Id; 6413 6414 begin 6415 -- Nothing to do when compiling for GNATprove because raise statements 6416 -- are not supported. 6417 6418 if GNATprove_Mode then 6419 return; 6420 6421 -- Nothing to do when the compilation will not produce an executable 6422 6423 elsif Serious_Errors_Detected > 0 then 6424 return; 6425 6426 -- Nothing to do for a compilation unit because there is no executable 6427 -- environment at that level. 6428 6429 elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then 6430 return; 6431 6432 -- Nothing to do when the unit is elaborated prior to the main unit. 6433 -- This check must also consider the following cases: 6434 6435 -- * Id's unit appears in the context of the main unit 6436 6437 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST 6438 -- NOT be generated because Id's unit is always elaborated prior to 6439 -- the main unit. 6440 6441 -- * Id's unit is the main unit. An ABE check MUST be generated in this 6442 -- case because a conditional ABE may be raised depending on the flow 6443 -- of execution within the main unit (flag Same_Unit_OK is False). 6444 6445 elsif Has_Prior_Elaboration 6446 (Unit_Id => Unit_Id, 6447 Context_OK => True, 6448 Elab_Body_OK => True) 6449 then 6450 return; 6451 end if; 6452 6453 -- Prevent multiple scenarios from installing the same ABE check 6454 6455 Set_Is_Elaboration_Checks_OK_Node (N, False); 6456 6457 -- Install the nearest enclosing scope of the scenario as there must be 6458 -- something on the scope stack. 6459 6460 -- Performance note: parent traversal 6461 6462 Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); 6463 pragma Assert (Present (Scop_Id)); 6464 6465 Push_Scope (Scop_Id); 6466 6467 -- Generate: 6468 -- if not Spec_Id'Elaborated then 6469 -- raise Program_Error with "access before elaboration"; 6470 -- end if; 6471 6472 Insert_Action (Check_Ins_Nod, 6473 Make_Raise_Program_Error (Loc, 6474 Condition => 6475 Make_Op_Not (Loc, 6476 Right_Opnd => 6477 Make_Attribute_Reference (Loc, 6478 Prefix => New_Occurrence_Of (Spec_Id, Loc), 6479 Attribute_Name => Name_Elaborated)), 6480 Reason => PE_Access_Before_Elaboration)); 6481 6482 Pop_Scope; 6483 end Install_ABE_Check; 6484 6485 ----------------------- 6486 -- Install_ABE_Check -- 6487 ----------------------- 6488 6489 procedure Install_ABE_Check 6490 (N : Node_Id; 6491 Target_Id : Entity_Id; 6492 Target_Decl : Node_Id; 6493 Target_Body : Node_Id; 6494 Ins_Nod : Node_Id) 6495 is 6496 procedure Build_Elaboration_Entity; 6497 pragma Inline (Build_Elaboration_Entity); 6498 -- Create a new elaboration flag for Target_Id, insert it prior to 6499 -- Target_Decl, and set it after Body_Decl. 6500 6501 ------------------------------ 6502 -- Build_Elaboration_Entity -- 6503 ------------------------------ 6504 6505 procedure Build_Elaboration_Entity is 6506 Loc : constant Source_Ptr := Sloc (Target_Id); 6507 Flag_Id : Entity_Id; 6508 6509 begin 6510 -- Create the declaration of the elaboration flag. The name carries a 6511 -- unique counter in case of name overloading. 6512 6513 Flag_Id := 6514 Make_Defining_Identifier (Loc, 6515 Chars => New_External_Name (Chars (Target_Id), 'E', -1)); 6516 6517 Set_Elaboration_Entity (Target_Id, Flag_Id); 6518 Set_Elaboration_Entity_Required (Target_Id); 6519 6520 Push_Scope (Scope (Target_Id)); 6521 6522 -- Generate: 6523 -- Enn : Short_Integer := 0; 6524 6525 Insert_Action (Target_Decl, 6526 Make_Object_Declaration (Loc, 6527 Defining_Identifier => Flag_Id, 6528 Object_Definition => 6529 New_Occurrence_Of (Standard_Short_Integer, Loc), 6530 Expression => Make_Integer_Literal (Loc, Uint_0))); 6531 6532 -- Generate: 6533 -- Enn := 1; 6534 6535 Set_Elaboration_Flag (Target_Body, Target_Id); 6536 6537 Pop_Scope; 6538 end Build_Elaboration_Entity; 6539 6540 -- Local variables 6541 6542 Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 6543 6544 -- Start for processing for Install_ABE_Check 6545 6546 begin 6547 -- Nothing to do when compiling for GNATprove because raise statements 6548 -- are not supported. 6549 6550 if GNATprove_Mode then 6551 return; 6552 6553 -- Nothing to do when the compilation will not produce an executable 6554 6555 elsif Serious_Errors_Detected > 0 then 6556 return; 6557 6558 -- Nothing to do when the target is a protected subprogram because the 6559 -- check is associated with the protected body subprogram. 6560 6561 elsif Is_Protected_Subp (Target_Id) then 6562 return; 6563 6564 -- Nothing to do when the target is elaborated prior to the main unit. 6565 -- This check must also consider the following cases: 6566 6567 -- * The unit of the target appears in the context of the main unit 6568 6569 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE 6570 -- check MUST NOT be generated because the unit is always elaborated 6571 -- prior to the main unit. 6572 6573 -- * The unit of the target is the main unit. An ABE check MUST be added 6574 -- in this case because a conditional ABE may be raised depending on 6575 -- the flow of execution within the main unit (flag Same_Unit_OK is 6576 -- False). 6577 6578 elsif Has_Prior_Elaboration 6579 (Unit_Id => Target_Unit_Id, 6580 Context_OK => True, 6581 Elab_Body_OK => True) 6582 then 6583 return; 6584 6585 -- Create an elaboration flag for the target when it does not have one 6586 6587 elsif No (Elaboration_Entity (Target_Id)) then 6588 Build_Elaboration_Entity; 6589 end if; 6590 6591 Install_ABE_Check 6592 (N => N, 6593 Ins_Nod => Ins_Nod, 6594 Id => Target_Id); 6595 end Install_ABE_Check; 6596 6597 ------------------------- 6598 -- Install_ABE_Failure -- 6599 ------------------------- 6600 6601 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is 6602 Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6603 -- Insert the failure prior to this node 6604 6605 Loc : constant Source_Ptr := Sloc (N); 6606 Scop_Id : Entity_Id; 6607 6608 begin 6609 -- Nothing to do when compiling for GNATprove because raise statements 6610 -- are not supported. 6611 6612 if GNATprove_Mode then 6613 return; 6614 6615 -- Nothing to do when the compilation will not produce an executable 6616 6617 elsif Serious_Errors_Detected > 0 then 6618 return; 6619 6620 -- Do not install an ABE check for a compilation unit because there is 6621 -- no executable environment at that level. 6622 6623 elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then 6624 return; 6625 end if; 6626 6627 -- Prevent multiple scenarios from installing the same ABE failure 6628 6629 Set_Is_Elaboration_Checks_OK_Node (N, False); 6630 6631 -- Install the nearest enclosing scope of the scenario as there must be 6632 -- something on the scope stack. 6633 6634 -- Performance note: parent traversal 6635 6636 Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); 6637 pragma Assert (Present (Scop_Id)); 6638 6639 Push_Scope (Scop_Id); 6640 6641 -- Generate: 6642 -- raise Program_Error with "access before elaboration"; 6643 6644 Insert_Action (Fail_Ins_Nod, 6645 Make_Raise_Program_Error (Loc, 6646 Reason => PE_Access_Before_Elaboration)); 6647 6648 Pop_Scope; 6649 end Install_ABE_Failure; 6650 6651 -------------------------------- 6652 -- Is_Accept_Alternative_Proc -- 6653 -------------------------------- 6654 6655 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 6656 begin 6657 -- To qualify, the entity must denote a procedure with a receiving entry 6658 6659 return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 6660 end Is_Accept_Alternative_Proc; 6661 6662 ------------------------ 6663 -- Is_Activation_Proc -- 6664 ------------------------ 6665 6666 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 6667 begin 6668 -- To qualify, the entity must denote one of the runtime procedures in 6669 -- charge of task activation. 6670 6671 if Ekind (Id) = E_Procedure then 6672 if Restricted_Profile then 6673 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 6674 else 6675 return Is_RTE (Id, RE_Activate_Tasks); 6676 end if; 6677 end if; 6678 6679 return False; 6680 end Is_Activation_Proc; 6681 6682 ---------------------------- 6683 -- Is_Ada_Semantic_Target -- 6684 ---------------------------- 6685 6686 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 6687 begin 6688 return 6689 Is_Activation_Proc (Id) 6690 or else Is_Controlled_Proc (Id, Name_Adjust) 6691 or else Is_Controlled_Proc (Id, Name_Finalize) 6692 or else Is_Controlled_Proc (Id, Name_Initialize) 6693 or else Is_Init_Proc (Id) 6694 or else Is_Invariant_Proc (Id) 6695 or else Is_Protected_Entry (Id) 6696 or else Is_Protected_Subp (Id) 6697 or else Is_Protected_Body_Subp (Id) 6698 or else Is_Task_Entry (Id); 6699 end Is_Ada_Semantic_Target; 6700 6701 -------------------------------- 6702 -- Is_Assertion_Pragma_Target -- 6703 -------------------------------- 6704 6705 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 6706 begin 6707 return 6708 Is_Default_Initial_Condition_Proc (Id) 6709 or else Is_Initial_Condition_Proc (Id) 6710 or else Is_Invariant_Proc (Id) 6711 or else Is_Partial_Invariant_Proc (Id) 6712 or else Is_Postconditions_Proc (Id); 6713 end Is_Assertion_Pragma_Target; 6714 6715 ---------------------------- 6716 -- Is_Bodiless_Subprogram -- 6717 ---------------------------- 6718 6719 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 6720 begin 6721 -- An abstract subprogram does not have a body 6722 6723 if Ekind_In (Subp_Id, E_Function, 6724 E_Operator, 6725 E_Procedure) 6726 and then Is_Abstract_Subprogram (Subp_Id) 6727 then 6728 return True; 6729 6730 -- A formal subprogram does not have a body 6731 6732 elsif Is_Formal_Subprogram (Subp_Id) then 6733 return True; 6734 6735 -- An imported subprogram may have a body, however it is not known at 6736 -- compile or bind time where the body resides and whether it will be 6737 -- elaborated on time. 6738 6739 elsif Is_Imported (Subp_Id) then 6740 return True; 6741 end if; 6742 6743 return False; 6744 end Is_Bodiless_Subprogram; 6745 6746 ------------------------ 6747 -- Is_Controlled_Proc -- 6748 ------------------------ 6749 6750 function Is_Controlled_Proc 6751 (Subp_Id : Entity_Id; 6752 Subp_Nam : Name_Id) return Boolean 6753 is 6754 Formal_Id : Entity_Id; 6755 6756 begin 6757 pragma Assert (Nam_In (Subp_Nam, Name_Adjust, 6758 Name_Finalize, 6759 Name_Initialize)); 6760 6761 -- To qualify, the subprogram must denote a source procedure with name 6762 -- Adjust, Finalize, or Initialize where the sole formal is controlled. 6763 6764 if Comes_From_Source (Subp_Id) 6765 and then Ekind (Subp_Id) = E_Procedure 6766 and then Chars (Subp_Id) = Subp_Nam 6767 then 6768 Formal_Id := First_Formal (Subp_Id); 6769 6770 return 6771 Present (Formal_Id) 6772 and then Is_Controlled (Etype (Formal_Id)) 6773 and then No (Next_Formal (Formal_Id)); 6774 end if; 6775 6776 return False; 6777 end Is_Controlled_Proc; 6778 6779 --------------------------------------- 6780 -- Is_Default_Initial_Condition_Proc -- 6781 --------------------------------------- 6782 6783 function Is_Default_Initial_Condition_Proc 6784 (Id : Entity_Id) return Boolean 6785 is 6786 begin 6787 -- To qualify, the entity must denote a Default_Initial_Condition 6788 -- procedure. 6789 6790 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 6791 end Is_Default_Initial_Condition_Proc; 6792 6793 ----------------------- 6794 -- Is_Finalizer_Proc -- 6795 ----------------------- 6796 6797 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 6798 begin 6799 -- To qualify, the entity must denote a _Finalizer procedure 6800 6801 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 6802 end Is_Finalizer_Proc; 6803 6804 ----------------------- 6805 -- Is_Guaranteed_ABE -- 6806 ----------------------- 6807 6808 function Is_Guaranteed_ABE 6809 (N : Node_Id; 6810 Target_Decl : Node_Id; 6811 Target_Body : Node_Id) return Boolean 6812 is 6813 begin 6814 -- Avoid cascaded errors if there were previous serious infractions. 6815 -- As a result the scenario will not be treated as a guaranteed ABE. 6816 -- This behaviour parallels that of the old ABE mechanism. 6817 6818 if Serious_Errors_Detected > 0 then 6819 return False; 6820 6821 -- The scenario and the target appear within the same context ignoring 6822 -- enclosing library levels. 6823 6824 -- Performance note: parent traversal 6825 6826 elsif In_Same_Context (N, Target_Decl) then 6827 6828 -- The target body has already been encountered. The scenario results 6829 -- in a guaranteed ABE if it appears prior to the body. 6830 6831 if Present (Target_Body) then 6832 return Earlier_In_Extended_Unit (N, Target_Body); 6833 6834 -- Otherwise the body has not been encountered yet. The scenario is 6835 -- a guaranteed ABE since the body will appear later. It is assumed 6836 -- that the caller has already checked whether the scenario is ABE- 6837 -- safe as optional bodies are not considered here. 6838 6839 else 6840 return True; 6841 end if; 6842 end if; 6843 6844 return False; 6845 end Is_Guaranteed_ABE; 6846 6847 ------------------------------- 6848 -- Is_Initial_Condition_Proc -- 6849 ------------------------------- 6850 6851 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 6852 begin 6853 -- To qualify, the entity must denote an Initial_Condition procedure 6854 6855 return 6856 Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); 6857 end Is_Initial_Condition_Proc; 6858 6859 -------------------- 6860 -- Is_Initialized -- 6861 -------------------- 6862 6863 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 6864 begin 6865 -- To qualify, the object declaration must have an expression 6866 6867 return 6868 Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); 6869 end Is_Initialized; 6870 6871 ----------------------- 6872 -- Is_Invariant_Proc -- 6873 ----------------------- 6874 6875 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 6876 begin 6877 -- To qualify, the entity must denote the "full" invariant procedure 6878 6879 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 6880 end Is_Invariant_Proc; 6881 6882 --------------------------------------- 6883 -- Is_Non_Library_Level_Encapsulator -- 6884 --------------------------------------- 6885 6886 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is 6887 begin 6888 case Nkind (N) is 6889 when N_Abstract_Subprogram_Declaration 6890 | N_Aspect_Specification 6891 | N_Component_Declaration 6892 | N_Entry_Body 6893 | N_Entry_Declaration 6894 | N_Expression_Function 6895 | N_Formal_Abstract_Subprogram_Declaration 6896 | N_Formal_Concrete_Subprogram_Declaration 6897 | N_Formal_Object_Declaration 6898 | N_Formal_Package_Declaration 6899 | N_Formal_Type_Declaration 6900 | N_Generic_Association 6901 | N_Implicit_Label_Declaration 6902 | N_Incomplete_Type_Declaration 6903 | N_Private_Extension_Declaration 6904 | N_Private_Type_Declaration 6905 | N_Protected_Body 6906 | N_Protected_Type_Declaration 6907 | N_Single_Protected_Declaration 6908 | N_Single_Task_Declaration 6909 | N_Subprogram_Body 6910 | N_Subprogram_Declaration 6911 | N_Task_Body 6912 | N_Task_Type_Declaration 6913 => 6914 return True; 6915 6916 when others => 6917 return Is_Generic_Declaration_Or_Body (N); 6918 end case; 6919 end Is_Non_Library_Level_Encapsulator; 6920 6921 ------------------------------- 6922 -- Is_Partial_Invariant_Proc -- 6923 ------------------------------- 6924 6925 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 6926 begin 6927 -- To qualify, the entity must denote the "partial" invariant procedure 6928 6929 return 6930 Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); 6931 end Is_Partial_Invariant_Proc; 6932 6933 ---------------------------- 6934 -- Is_Postconditions_Proc -- 6935 ---------------------------- 6936 6937 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 6938 begin 6939 -- To qualify, the entity must denote a _Postconditions procedure 6940 6941 return 6942 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 6943 end Is_Postconditions_Proc; 6944 6945 --------------------------- 6946 -- Is_Preelaborated_Unit -- 6947 --------------------------- 6948 6949 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 6950 begin 6951 return 6952 Is_Preelaborated (Id) 6953 or else Is_Pure (Id) 6954 or else Is_Remote_Call_Interface (Id) 6955 or else Is_Remote_Types (Id) 6956 or else Is_Shared_Passive (Id); 6957 end Is_Preelaborated_Unit; 6958 6959 ------------------------ 6960 -- Is_Protected_Entry -- 6961 ------------------------ 6962 6963 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 6964 begin 6965 -- To qualify, the entity must denote an entry defined in a protected 6966 -- type. 6967 6968 return 6969 Is_Entry (Id) 6970 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6971 end Is_Protected_Entry; 6972 6973 ----------------------- 6974 -- Is_Protected_Subp -- 6975 ----------------------- 6976 6977 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 6978 begin 6979 -- To qualify, the entity must denote a subprogram defined within a 6980 -- protected type. 6981 6982 return 6983 Ekind_In (Id, E_Function, E_Procedure) 6984 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6985 end Is_Protected_Subp; 6986 6987 ---------------------------- 6988 -- Is_Protected_Body_Subp -- 6989 ---------------------------- 6990 6991 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 6992 begin 6993 -- To qualify, the entity must denote a subprogram with attribute 6994 -- Protected_Subprogram set. 6995 6996 return 6997 Ekind_In (Id, E_Function, E_Procedure) 6998 and then Present (Protected_Subprogram (Id)); 6999 end Is_Protected_Body_Subp; 7000 7001 -------------------------------- 7002 -- Is_Recorded_SPARK_Scenario -- 7003 -------------------------------- 7004 7005 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is 7006 begin 7007 if Recorded_SPARK_Scenarios_In_Use then 7008 return Recorded_SPARK_Scenarios.Get (N); 7009 end if; 7010 7011 return Recorded_SPARK_Scenarios_No_Element; 7012 end Is_Recorded_SPARK_Scenario; 7013 7014 ------------------------------------ 7015 -- Is_Recorded_Top_Level_Scenario -- 7016 ------------------------------------ 7017 7018 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is 7019 begin 7020 if Recorded_Top_Level_Scenarios_In_Use then 7021 return Recorded_Top_Level_Scenarios.Get (N); 7022 end if; 7023 7024 return Recorded_Top_Level_Scenarios_No_Element; 7025 end Is_Recorded_Top_Level_Scenario; 7026 7027 ------------------------ 7028 -- Is_Safe_Activation -- 7029 ------------------------ 7030 7031 function Is_Safe_Activation 7032 (Call : Node_Id; 7033 Task_Decl : Node_Id) return Boolean 7034 is 7035 begin 7036 -- The activation of a task coming from an external instance cannot 7037 -- cause an ABE because the generic was already instantiated. Note 7038 -- that the instantiation itself may lead to an ABE. 7039 7040 return 7041 In_External_Instance 7042 (N => Call, 7043 Target_Decl => Task_Decl); 7044 end Is_Safe_Activation; 7045 7046 ------------------ 7047 -- Is_Safe_Call -- 7048 ------------------ 7049 7050 function Is_Safe_Call 7051 (Call : Node_Id; 7052 Target_Attrs : Target_Attributes) return Boolean 7053 is 7054 begin 7055 -- The target is either an abstract subprogram, formal subprogram, or 7056 -- imported, in which case it does not have a body at compile or bind 7057 -- time. Assume that the call is ABE-safe. 7058 7059 if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then 7060 return True; 7061 7062 -- The target is an instantiation of a generic subprogram. The call 7063 -- cannot cause an ABE because the generic was already instantiated. 7064 -- Note that the instantiation itself may lead to an ABE. 7065 7066 elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then 7067 return True; 7068 7069 -- The invocation of a target coming from an external instance cannot 7070 -- cause an ABE because the generic was already instantiated. Note that 7071 -- the instantiation itself may lead to an ABE. 7072 7073 elsif In_External_Instance 7074 (N => Call, 7075 Target_Decl => Target_Attrs.Spec_Decl) 7076 then 7077 return True; 7078 7079 -- The target is a subprogram body without a previous declaration. The 7080 -- call cannot cause an ABE because the body has already been seen. 7081 7082 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body 7083 and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) 7084 then 7085 return True; 7086 7087 -- The target is a subprogram body stub without a prior declaration. 7088 -- The call cannot cause an ABE because the proper body substitutes 7089 -- the stub. 7090 7091 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub 7092 and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) 7093 then 7094 return True; 7095 7096 -- Subprogram bodies which wrap attribute references used as actuals 7097 -- in instantiations are always ABE-safe. These bodies are artifacts 7098 -- of expansion. 7099 7100 elsif Present (Target_Attrs.Body_Decl) 7101 and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body 7102 and then Was_Attribute_Reference (Target_Attrs.Body_Decl) 7103 then 7104 return True; 7105 end if; 7106 7107 return False; 7108 end Is_Safe_Call; 7109 7110 --------------------------- 7111 -- Is_Safe_Instantiation -- 7112 --------------------------- 7113 7114 function Is_Safe_Instantiation 7115 (Inst : Node_Id; 7116 Gen_Attrs : Target_Attributes) return Boolean 7117 is 7118 begin 7119 -- The generic is an intrinsic subprogram in which case it does not 7120 -- have a body at compile or bind time. Assume that the instantiation 7121 -- is ABE-safe. 7122 7123 if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then 7124 return True; 7125 7126 -- The instantiation of an external nested generic cannot cause an ABE 7127 -- if the outer generic was already instantiated. Note that the instance 7128 -- of the outer generic may lead to an ABE. 7129 7130 elsif In_External_Instance 7131 (N => Inst, 7132 Target_Decl => Gen_Attrs.Spec_Decl) 7133 then 7134 return True; 7135 7136 -- The generic is a package. The instantiation cannot cause an ABE when 7137 -- the package has no body. 7138 7139 elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package 7140 and then not Has_Body (Gen_Attrs.Spec_Decl) 7141 then 7142 return True; 7143 end if; 7144 7145 return False; 7146 end Is_Safe_Instantiation; 7147 7148 ------------------ 7149 -- Is_Same_Unit -- 7150 ------------------ 7151 7152 function Is_Same_Unit 7153 (Unit_1 : Entity_Id; 7154 Unit_2 : Entity_Id) return Boolean 7155 is 7156 begin 7157 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); 7158 end Is_Same_Unit; 7159 7160 ----------------- 7161 -- Is_Scenario -- 7162 ----------------- 7163 7164 function Is_Scenario (N : Node_Id) return Boolean is 7165 begin 7166 case Nkind (N) is 7167 when N_Assignment_Statement 7168 | N_Attribute_Reference 7169 | N_Call_Marker 7170 | N_Entry_Call_Statement 7171 | N_Expanded_Name 7172 | N_Function_Call 7173 | N_Function_Instantiation 7174 | N_Identifier 7175 | N_Package_Instantiation 7176 | N_Procedure_Call_Statement 7177 | N_Procedure_Instantiation 7178 | N_Requeue_Statement 7179 => 7180 return True; 7181 7182 when others => 7183 return False; 7184 end case; 7185 end Is_Scenario; 7186 7187 ------------------------------ 7188 -- Is_SPARK_Semantic_Target -- 7189 ------------------------------ 7190 7191 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 7192 begin 7193 return 7194 Is_Default_Initial_Condition_Proc (Id) 7195 or else Is_Initial_Condition_Proc (Id); 7196 end Is_SPARK_Semantic_Target; 7197 7198 ------------------------ 7199 -- Is_Suitable_Access -- 7200 ------------------------ 7201 7202 function Is_Suitable_Access (N : Node_Id) return Boolean is 7203 Nam : Name_Id; 7204 Pref : Node_Id; 7205 Subp_Id : Entity_Id; 7206 7207 begin 7208 -- This scenario is relevant only when the static model is in effect 7209 -- because it is graph-dependent and does not involve any run-time 7210 -- checks. Allowing it in the dynamic model would create confusing 7211 -- noise. 7212 7213 if not Static_Elaboration_Checks then 7214 return False; 7215 7216 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 7217 7218 elsif Debug_Flag_Dot_UU then 7219 return False; 7220 7221 -- Nothing to do when the scenario is not an attribute reference 7222 7223 elsif Nkind (N) /= N_Attribute_Reference then 7224 return False; 7225 7226 -- Nothing to do for internally-generated attributes because they are 7227 -- assumed to be ABE safe. 7228 7229 elsif not Comes_From_Source (N) then 7230 return False; 7231 end if; 7232 7233 Nam := Attribute_Name (N); 7234 Pref := Prefix (N); 7235 7236 -- Sanitize the prefix of the attribute 7237 7238 if not Is_Entity_Name (Pref) then 7239 return False; 7240 7241 elsif No (Entity (Pref)) then 7242 return False; 7243 end if; 7244 7245 Subp_Id := Entity (Pref); 7246 7247 if not Is_Subprogram_Or_Entry (Subp_Id) then 7248 return False; 7249 end if; 7250 7251 -- Traverse a possible chain of renamings to obtain the original entry 7252 -- or subprogram which the prefix may rename. 7253 7254 Subp_Id := Get_Renamed_Entity (Subp_Id); 7255 7256 -- To qualify, the attribute must meet the following prerequisites: 7257 7258 return 7259 7260 -- The prefix must denote a source entry, operator, or subprogram 7261 -- which is not imported. 7262 7263 Comes_From_Source (Subp_Id) 7264 and then Is_Subprogram_Or_Entry (Subp_Id) 7265 and then not Is_Bodiless_Subprogram (Subp_Id) 7266 7267 -- The attribute name must be one of the 'Access forms. Note that 7268 -- 'Unchecked_Access cannot apply to a subprogram. 7269 7270 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); 7271 end Is_Suitable_Access; 7272 7273 ---------------------- 7274 -- Is_Suitable_Call -- 7275 ---------------------- 7276 7277 function Is_Suitable_Call (N : Node_Id) return Boolean is 7278 begin 7279 -- Entry and subprogram calls are intentionally ignored because they 7280 -- may undergo expansion depending on the compilation mode, previous 7281 -- errors, generic context, etc. Call markers play the role of calls 7282 -- and provide a uniform foundation for ABE processing. 7283 7284 return Nkind (N) = N_Call_Marker; 7285 end Is_Suitable_Call; 7286 7287 ------------------------------- 7288 -- Is_Suitable_Instantiation -- 7289 ------------------------------- 7290 7291 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 7292 Orig_N : constant Node_Id := Original_Node (N); 7293 -- Use the original node in case an instantiation library unit is 7294 -- rewritten as a package or subprogram. 7295 7296 begin 7297 -- To qualify, the instantiation must come from source 7298 7299 return 7300 Comes_From_Source (Orig_N) 7301 and then Nkind (Orig_N) in N_Generic_Instantiation; 7302 end Is_Suitable_Instantiation; 7303 7304 -------------------------- 7305 -- Is_Suitable_Scenario -- 7306 -------------------------- 7307 7308 function Is_Suitable_Scenario (N : Node_Id) return Boolean is 7309 begin 7310 -- NOTE: Derived types and pragma Refined_State are intentionally left 7311 -- out because they are not executable during elaboration. 7312 7313 return 7314 Is_Suitable_Access (N) 7315 or else Is_Suitable_Call (N) 7316 or else Is_Suitable_Instantiation (N) 7317 or else Is_Suitable_Variable_Assignment (N) 7318 or else Is_Suitable_Variable_Reference (N); 7319 end Is_Suitable_Scenario; 7320 7321 ------------------------------------ 7322 -- Is_Suitable_SPARK_Derived_Type -- 7323 ------------------------------------ 7324 7325 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 7326 Prag : Node_Id; 7327 Typ : Entity_Id; 7328 7329 begin 7330 -- To qualify, the type declaration must denote a derived tagged type 7331 -- with primitive operations, subject to pragma SPARK_Mode On. 7332 7333 if Nkind (N) = N_Full_Type_Declaration 7334 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 7335 then 7336 Typ := Defining_Entity (N); 7337 Prag := SPARK_Pragma (Typ); 7338 7339 return 7340 Is_Tagged_Type (Typ) 7341 and then Has_Primitive_Operations (Typ) 7342 and then Present (Prag) 7343 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 7344 end if; 7345 7346 return False; 7347 end Is_Suitable_SPARK_Derived_Type; 7348 7349 ------------------------------------- 7350 -- Is_Suitable_SPARK_Instantiation -- 7351 ------------------------------------- 7352 7353 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 7354 Gen_Attrs : Target_Attributes; 7355 Gen_Id : Entity_Id; 7356 Inst : Node_Id; 7357 Inst_Attrs : Instantiation_Attributes; 7358 Inst_Id : Entity_Id; 7359 7360 begin 7361 -- To qualify, both the instantiation and the generic must be subject to 7362 -- SPARK_Mode On. 7363 7364 if Is_Suitable_Instantiation (N) then 7365 Extract_Instantiation_Attributes 7366 (Exp_Inst => N, 7367 Inst => Inst, 7368 Inst_Id => Inst_Id, 7369 Gen_Id => Gen_Id, 7370 Attrs => Inst_Attrs); 7371 7372 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 7373 7374 return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 7375 end if; 7376 7377 return False; 7378 end Is_Suitable_SPARK_Instantiation; 7379 7380 -------------------------------------------- 7381 -- Is_Suitable_SPARK_Refined_State_Pragma -- 7382 -------------------------------------------- 7383 7384 function Is_Suitable_SPARK_Refined_State_Pragma 7385 (N : Node_Id) return Boolean 7386 is 7387 begin 7388 -- To qualfy, the pragma must denote Refined_State 7389 7390 return 7391 Nkind (N) = N_Pragma 7392 and then Pragma_Name (N) = Name_Refined_State; 7393 end Is_Suitable_SPARK_Refined_State_Pragma; 7394 7395 ------------------------------------- 7396 -- Is_Suitable_Variable_Assignment -- 7397 ------------------------------------- 7398 7399 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 7400 N_Unit : Node_Id; 7401 N_Unit_Id : Entity_Id; 7402 Nam : Node_Id; 7403 Var_Decl : Node_Id; 7404 Var_Id : Entity_Id; 7405 Var_Unit : Node_Id; 7406 Var_Unit_Id : Entity_Id; 7407 7408 begin 7409 -- This scenario is relevant only when the static model is in effect 7410 -- because it is graph-dependent and does not involve any run-time 7411 -- checks. Allowing it in the dynamic model would create confusing 7412 -- noise. 7413 7414 if not Static_Elaboration_Checks then 7415 return False; 7416 7417 -- Nothing to do when the scenario is not an assignment 7418 7419 elsif Nkind (N) /= N_Assignment_Statement then 7420 return False; 7421 7422 -- Nothing to do for internally-generated assignments because they are 7423 -- assumed to be ABE safe. 7424 7425 elsif not Comes_From_Source (N) then 7426 return False; 7427 7428 -- Assignments are ignored in GNAT mode on the assumption that they are 7429 -- ABE-safe. This behaviour parallels that of the old ABE mechanism. 7430 7431 elsif GNAT_Mode then 7432 return False; 7433 end if; 7434 7435 Nam := Extract_Assignment_Name (N); 7436 7437 -- Sanitize the left hand side of the assignment 7438 7439 if not Is_Entity_Name (Nam) then 7440 return False; 7441 7442 elsif No (Entity (Nam)) then 7443 return False; 7444 end if; 7445 7446 Var_Id := Entity (Nam); 7447 7448 -- Sanitize the variable 7449 7450 if Var_Id = Any_Id then 7451 return False; 7452 7453 elsif Ekind (Var_Id) /= E_Variable then 7454 return False; 7455 end if; 7456 7457 Var_Decl := Declaration_Node (Var_Id); 7458 7459 if Nkind (Var_Decl) /= N_Object_Declaration then 7460 return False; 7461 end if; 7462 7463 N_Unit_Id := Find_Top_Unit (N); 7464 N_Unit := Unit_Declaration_Node (N_Unit_Id); 7465 7466 Var_Unit_Id := Find_Top_Unit (Var_Decl); 7467 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 7468 7469 -- To qualify, the assignment must meet the following prerequisites: 7470 7471 return 7472 Comes_From_Source (Var_Id) 7473 7474 -- The variable must be declared in the spec of compilation unit U 7475 7476 and then Nkind (Var_Unit) = N_Package_Declaration 7477 7478 -- Performance note: parent traversal 7479 7480 and then Find_Enclosing_Level (Var_Decl) = Package_Spec 7481 7482 -- The assignment must occur in the body of compilation unit U 7483 7484 and then Nkind (N_Unit) = N_Package_Body 7485 and then Present (Corresponding_Body (Var_Unit)) 7486 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 7487 end Is_Suitable_Variable_Assignment; 7488 7489 ------------------------------------ 7490 -- Is_Suitable_Variable_Reference -- 7491 ------------------------------------ 7492 7493 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 7494 begin 7495 -- Expanded names and identifiers are intentionally ignored because they 7496 -- be folded, optimized away, etc. Variable references markers play the 7497 -- role of variable references and provide a uniform foundation for ABE 7498 -- processing. 7499 7500 return Nkind (N) = N_Variable_Reference_Marker; 7501 end Is_Suitable_Variable_Reference; 7502 7503 ------------------------------------ 7504 -- Is_Synchronous_Suspension_Call -- 7505 ------------------------------------ 7506 7507 function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is 7508 Call_Attrs : Call_Attributes; 7509 Target_Id : Entity_Id; 7510 7511 begin 7512 -- To qualify, the call must invoke one of the runtime routines which 7513 -- perform synchronous suspension. 7514 7515 if Is_Suitable_Call (N) then 7516 Extract_Call_Attributes 7517 (Call => N, 7518 Target_Id => Target_Id, 7519 Attrs => Call_Attrs); 7520 7521 return 7522 Is_RTE (Target_Id, RE_Suspend_Until_True) 7523 or else 7524 Is_RTE (Target_Id, RE_Wait_For_Release); 7525 end if; 7526 7527 return False; 7528 end Is_Synchronous_Suspension_Call; 7529 7530 ------------------- 7531 -- Is_Task_Entry -- 7532 ------------------- 7533 7534 function Is_Task_Entry (Id : Entity_Id) return Boolean is 7535 begin 7536 -- To qualify, the entity must denote an entry defined in a task type 7537 7538 return 7539 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 7540 end Is_Task_Entry; 7541 7542 ------------------------ 7543 -- Is_Up_Level_Target -- 7544 ------------------------ 7545 7546 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is 7547 Root : constant Node_Id := Root_Scenario; 7548 7549 begin 7550 -- The root appears within the declaratons of a block statement, entry 7551 -- body, subprogram body, or task body ignoring enclosing packages. The 7552 -- root is always within the main unit. An up-level target is a notion 7553 -- applicable only to the static model because scenarios are reached by 7554 -- means of graph traversal started from a fixed declarative or library 7555 -- level. 7556 7557 -- Performance note: parent traversal 7558 7559 if Static_Elaboration_Checks 7560 and then Find_Enclosing_Level (Root) = Declaration_Level 7561 then 7562 -- The target is within the main unit. It acts as an up-level target 7563 -- when it appears within a context which encloses the root. 7564 7565 -- package body Main_Unit is 7566 -- function Func ...; -- target 7567 7568 -- procedure Proc is 7569 -- X : ... := Func; -- root scenario 7570 7571 if In_Extended_Main_Code_Unit (Target_Decl) then 7572 7573 -- Performance note: parent traversal 7574 7575 return not In_Same_Context (Root, Target_Decl, Nested_OK => True); 7576 7577 -- Otherwise the target is external to the main unit which makes it 7578 -- an up-level target. 7579 7580 else 7581 return True; 7582 end if; 7583 end if; 7584 7585 return False; 7586 end Is_Up_Level_Target; 7587 7588 --------------------- 7589 -- Is_Visited_Body -- 7590 --------------------- 7591 7592 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is 7593 begin 7594 if Visited_Bodies_In_Use then 7595 return Visited_Bodies.Get (Body_Decl); 7596 end if; 7597 7598 return Visited_Bodies_No_Element; 7599 end Is_Visited_Body; 7600 7601 ------------------------------- 7602 -- Kill_Elaboration_Scenario -- 7603 ------------------------------- 7604 7605 procedure Kill_Elaboration_Scenario (N : Node_Id) is 7606 procedure Kill_SPARK_Scenario; 7607 pragma Inline (Kill_SPARK_Scenario); 7608 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded 7609 -- there. 7610 7611 procedure Kill_Top_Level_Scenario; 7612 pragma Inline (Kill_Top_Level_Scenario); 7613 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded 7614 -- there. 7615 7616 ------------------------- 7617 -- Kill_SPARK_Scenario -- 7618 ------------------------- 7619 7620 procedure Kill_SPARK_Scenario is 7621 package Scenarios renames SPARK_Scenarios; 7622 7623 begin 7624 if Is_Recorded_SPARK_Scenario (N) then 7625 7626 -- Performance note: list traversal 7627 7628 for Index in Scenarios.First .. Scenarios.Last loop 7629 if Scenarios.Table (Index) = N then 7630 Scenarios.Table (Index) := Empty; 7631 7632 -- The SPARK scenario is no longer recorded 7633 7634 Set_Is_Recorded_SPARK_Scenario (N, False); 7635 return; 7636 end if; 7637 end loop; 7638 7639 -- A recorded SPARK scenario must be in the table of recorded 7640 -- SPARK scenarios. 7641 7642 pragma Assert (False); 7643 end if; 7644 end Kill_SPARK_Scenario; 7645 7646 ----------------------------- 7647 -- Kill_Top_Level_Scenario -- 7648 ----------------------------- 7649 7650 procedure Kill_Top_Level_Scenario is 7651 package Scenarios renames Top_Level_Scenarios; 7652 7653 begin 7654 if Is_Recorded_Top_Level_Scenario (N) then 7655 7656 -- Performance node: list traversal 7657 7658 for Index in Scenarios.First .. Scenarios.Last loop 7659 if Scenarios.Table (Index) = N then 7660 Scenarios.Table (Index) := Empty; 7661 7662 -- The top-level scenario is no longer recorded 7663 7664 Set_Is_Recorded_Top_Level_Scenario (N, False); 7665 return; 7666 end if; 7667 end loop; 7668 7669 -- A recorded top-level scenario must be in the table of recorded 7670 -- top-level scenarios. 7671 7672 pragma Assert (False); 7673 end if; 7674 end Kill_Top_Level_Scenario; 7675 7676 -- Start of processing for Kill_Elaboration_Scenario 7677 7678 begin 7679 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 7680 -- enabled) is in effect because the legacy ABE lechanism does not need 7681 -- to carry out this action. 7682 7683 if Legacy_Elaboration_Checks then 7684 return; 7685 end if; 7686 7687 -- Eliminate a recorded scenario when it appears within dead code 7688 -- because it will not be executed at elaboration time. 7689 7690 if Is_Scenario (N) then 7691 Kill_SPARK_Scenario; 7692 Kill_Top_Level_Scenario; 7693 end if; 7694 end Kill_Elaboration_Scenario; 7695 7696 ---------------------------------- 7697 -- Meet_Elaboration_Requirement -- 7698 ---------------------------------- 7699 7700 procedure Meet_Elaboration_Requirement 7701 (N : Node_Id; 7702 Target_Id : Entity_Id; 7703 Req_Nam : Name_Id) 7704 is 7705 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); 7706 Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 7707 7708 function Find_Preelaboration_Pragma 7709 (Prag_Nam : Name_Id) return Node_Id; 7710 pragma Inline (Find_Preelaboration_Pragma); 7711 -- Traverse the visible declarations of unit Unit_Id and locate a source 7712 -- preelaboration-related pragma with name Prag_Nam. 7713 7714 procedure Info_Requirement_Met (Prag : Node_Id); 7715 pragma Inline (Info_Requirement_Met); 7716 -- Output information concerning pragma Prag which meets requirement 7717 -- Req_Nam. 7718 7719 procedure Info_Scenario; 7720 pragma Inline (Info_Scenario); 7721 -- Output information concerning scenario N 7722 7723 -------------------------------- 7724 -- Find_Preelaboration_Pragma -- 7725 -------------------------------- 7726 7727 function Find_Preelaboration_Pragma 7728 (Prag_Nam : Name_Id) return Node_Id 7729 is 7730 Spec : constant Node_Id := Parent (Unit_Id); 7731 Decl : Node_Id; 7732 7733 begin 7734 -- A preelaboration-related pragma comes from source and appears at 7735 -- the top of the visible declarations of a package. 7736 7737 if Nkind (Spec) = N_Package_Specification then 7738 Decl := First (Visible_Declarations (Spec)); 7739 while Present (Decl) loop 7740 if Comes_From_Source (Decl) then 7741 if Nkind (Decl) = N_Pragma 7742 and then Pragma_Name (Decl) = Prag_Nam 7743 then 7744 return Decl; 7745 7746 -- Otherwise the construct terminates the region where the 7747 -- preelaboration-related pragma may appear. 7748 7749 else 7750 exit; 7751 end if; 7752 end if; 7753 7754 Next (Decl); 7755 end loop; 7756 end if; 7757 7758 return Empty; 7759 end Find_Preelaboration_Pragma; 7760 7761 -------------------------- 7762 -- Info_Requirement_Met -- 7763 -------------------------- 7764 7765 procedure Info_Requirement_Met (Prag : Node_Id) is 7766 begin 7767 pragma Assert (Present (Prag)); 7768 7769 Error_Msg_Name_1 := Req_Nam; 7770 Error_Msg_Sloc := Sloc (Prag); 7771 Error_Msg_NE 7772 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 7773 end Info_Requirement_Met; 7774 7775 ------------------- 7776 -- Info_Scenario -- 7777 ------------------- 7778 7779 procedure Info_Scenario is 7780 begin 7781 if Is_Suitable_Call (N) then 7782 Info_Call 7783 (Call => N, 7784 Target_Id => Target_Id, 7785 Info_Msg => False, 7786 In_SPARK => True); 7787 7788 elsif Is_Suitable_Instantiation (N) then 7789 Info_Instantiation 7790 (Inst => N, 7791 Gen_Id => Target_Id, 7792 Info_Msg => False, 7793 In_SPARK => True); 7794 7795 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 7796 Error_Msg_N 7797 ("read of refinement constituents during elaboration in SPARK", 7798 N); 7799 7800 elsif Is_Suitable_Variable_Reference (N) then 7801 Info_Variable_Reference 7802 (Ref => N, 7803 Var_Id => Target_Id, 7804 Info_Msg => False, 7805 In_SPARK => True); 7806 7807 -- No other scenario may impose a requirement on the context of the 7808 -- main unit. 7809 7810 else 7811 pragma Assert (False); 7812 null; 7813 end if; 7814 end Info_Scenario; 7815 7816 -- Local variables 7817 7818 Elab_Attrs : Elaboration_Attributes; 7819 Elab_Nam : Name_Id; 7820 Req_Met : Boolean; 7821 7822 -- Start of processing for Meet_Elaboration_Requirement 7823 7824 begin 7825 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); 7826 7827 -- Assume that the requirement has not been met 7828 7829 Req_Met := False; 7830 7831 -- Elaboration requirements are verified only when the static model is 7832 -- in effect because this diagnostic is graph-dependent. 7833 7834 if not Static_Elaboration_Checks then 7835 return; 7836 7837 -- If the target is within the main unit, either at the source level or 7838 -- through an instantiation, then there is no real requirement to meet 7839 -- because the main unit cannot force its own elaboration by means of an 7840 -- Elaborate[_All] pragma. Treat this case as valid coverage. 7841 7842 elsif In_Extended_Main_Code_Unit (Target_Id) then 7843 Req_Met := True; 7844 7845 -- Otherwise the target resides in an external unit 7846 7847 -- The requirement is met when the target comes from an internal unit 7848 -- because such a unit is elaborated prior to a non-internal unit. 7849 7850 elsif In_Internal_Unit (Unit_Id) 7851 and then not In_Internal_Unit (Main_Id) 7852 then 7853 Req_Met := True; 7854 7855 -- The requirement is met when the target comes from a preelaborated 7856 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 7857 7858 elsif Is_Preelaborated_Unit (Unit_Id) then 7859 Req_Met := True; 7860 7861 -- Output extra information when switch -gnatel (info messages on 7862 -- implicit Elaborate[_All] pragmas. 7863 7864 if Elab_Info_Messages then 7865 if Is_Preelaborated (Unit_Id) then 7866 Elab_Nam := Name_Preelaborate; 7867 7868 elsif Is_Pure (Unit_Id) then 7869 Elab_Nam := Name_Pure; 7870 7871 elsif Is_Remote_Call_Interface (Unit_Id) then 7872 Elab_Nam := Name_Remote_Call_Interface; 7873 7874 elsif Is_Remote_Types (Unit_Id) then 7875 Elab_Nam := Name_Remote_Types; 7876 7877 else 7878 pragma Assert (Is_Shared_Passive (Unit_Id)); 7879 Elab_Nam := Name_Shared_Passive; 7880 end if; 7881 7882 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 7883 end if; 7884 7885 -- Determine whether the context of the main unit has a pragma strong 7886 -- enough to meet the requirement. 7887 7888 else 7889 Elab_Attrs := Elaboration_Status (Unit_Id); 7890 7891 -- The pragma must be either Elaborate_All or be as strong as the 7892 -- requirement. 7893 7894 if Present (Elab_Attrs.Source_Pragma) 7895 and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), 7896 Name_Elaborate_All, 7897 Req_Nam) 7898 then 7899 Req_Met := True; 7900 7901 -- Output extra information when switch -gnatel (info messages on 7902 -- implicit Elaborate[_All] pragmas. 7903 7904 if Elab_Info_Messages then 7905 Info_Requirement_Met (Elab_Attrs.Source_Pragma); 7906 end if; 7907 end if; 7908 end if; 7909 7910 -- The requirement was not met by the context of the main unit, issue an 7911 -- error. 7912 7913 if not Req_Met then 7914 Info_Scenario; 7915 7916 Error_Msg_Name_1 := Req_Nam; 7917 Error_Msg_Node_2 := Unit_Id; 7918 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 7919 7920 Output_Active_Scenarios (N); 7921 end if; 7922 end Meet_Elaboration_Requirement; 7923 7924 ---------------------- 7925 -- Non_Private_View -- 7926 ---------------------- 7927 7928 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 7929 begin 7930 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 7931 return Full_View (Typ); 7932 else 7933 return Typ; 7934 end if; 7935 end Non_Private_View; 7936 7937 ----------------------------- 7938 -- Output_Active_Scenarios -- 7939 ----------------------------- 7940 7941 procedure Output_Active_Scenarios (Error_Nod : Node_Id) is 7942 procedure Output_Access (N : Node_Id); 7943 -- Emit a specific diagnostic message for 'Access denote by N 7944 7945 procedure Output_Activation_Call (N : Node_Id); 7946 -- Emit a specific diagnostic message for task activation N 7947 7948 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); 7949 -- Emit a specific diagnostic message for call N which invokes target 7950 -- Target_Id. 7951 7952 procedure Output_Header; 7953 -- Emit a specific diagnostic message for the unit of the root scenario 7954 7955 procedure Output_Instantiation (N : Node_Id); 7956 -- Emit a specific diagnostic message for instantiation N 7957 7958 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); 7959 -- Emit a specific diagnostic message for Refined_State pragma N 7960 7961 procedure Output_Variable_Assignment (N : Node_Id); 7962 -- Emit a specific diagnostic message for assignment statement N 7963 7964 procedure Output_Variable_Reference (N : Node_Id); 7965 -- Emit a specific diagnostic message for reference N which mentions a 7966 -- variable. 7967 7968 ------------------- 7969 -- Output_Access -- 7970 ------------------- 7971 7972 procedure Output_Access (N : Node_Id) is 7973 Subp_Id : constant Entity_Id := Entity (Prefix (N)); 7974 7975 begin 7976 Error_Msg_Name_1 := Attribute_Name (N); 7977 Error_Msg_Sloc := Sloc (N); 7978 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); 7979 end Output_Access; 7980 7981 ---------------------------- 7982 -- Output_Activation_Call -- 7983 ---------------------------- 7984 7985 procedure Output_Activation_Call (N : Node_Id) is 7986 function Find_Activator (Call : Node_Id) return Entity_Id; 7987 -- Find the nearest enclosing construct which houses call Call 7988 7989 -------------------- 7990 -- Find_Activator -- 7991 -------------------- 7992 7993 function Find_Activator (Call : Node_Id) return Entity_Id is 7994 Par : Node_Id; 7995 7996 begin 7997 -- Climb the parent chain looking for a package [body] or a 7998 -- construct with a statement sequence. 7999 8000 Par := Parent (Call); 8001 while Present (Par) loop 8002 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then 8003 return Defining_Entity (Par); 8004 8005 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then 8006 return Defining_Entity (Parent (Par)); 8007 end if; 8008 8009 Par := Parent (Par); 8010 end loop; 8011 8012 return Empty; 8013 end Find_Activator; 8014 8015 -- Local variables 8016 8017 Activator : constant Entity_Id := Find_Activator (N); 8018 8019 -- Start of processing for Output_Activation_Call 8020 8021 begin 8022 pragma Assert (Present (Activator)); 8023 8024 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); 8025 end Output_Activation_Call; 8026 8027 ----------------- 8028 -- Output_Call -- 8029 ----------------- 8030 8031 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is 8032 procedure Output_Accept_Alternative; 8033 pragma Inline (Output_Accept_Alternative); 8034 -- Emit a specific diagnostic message concerning an accept 8035 -- alternative. 8036 8037 procedure Output_Call (Kind : String); 8038 pragma Inline (Output_Call); 8039 -- Emit a specific diagnostic message concerning a call of kind Kind 8040 8041 procedure Output_Type_Actions (Action : String); 8042 pragma Inline (Output_Type_Actions); 8043 -- Emit a specific diagnostic message concerning action Action of a 8044 -- type. 8045 8046 procedure Output_Verification_Call 8047 (Pred : String; 8048 Id : Entity_Id; 8049 Id_Kind : String); 8050 pragma Inline (Output_Verification_Call); 8051 -- Emit a specific diagnostic message concerning the verification of 8052 -- predicate Pred applied to related entity Id with kind Id_Kind. 8053 8054 ------------------------------- 8055 -- Output_Accept_Alternative -- 8056 ------------------------------- 8057 8058 procedure Output_Accept_Alternative is 8059 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 8060 8061 begin 8062 pragma Assert (Present (Entry_Id)); 8063 8064 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); 8065 end Output_Accept_Alternative; 8066 8067 ----------------- 8068 -- Output_Call -- 8069 ----------------- 8070 8071 procedure Output_Call (Kind : String) is 8072 begin 8073 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); 8074 end Output_Call; 8075 8076 ------------------------- 8077 -- Output_Type_Actions -- 8078 ------------------------- 8079 8080 procedure Output_Type_Actions (Action : String) is 8081 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 8082 8083 begin 8084 pragma Assert (Present (Typ)); 8085 8086 Error_Msg_NE 8087 ("\\ " & Action & " actions for type & #", Error_Nod, Typ); 8088 end Output_Type_Actions; 8089 8090 ------------------------------ 8091 -- Output_Verification_Call -- 8092 ------------------------------ 8093 8094 procedure Output_Verification_Call 8095 (Pred : String; 8096 Id : Entity_Id; 8097 Id_Kind : String) 8098 is 8099 begin 8100 pragma Assert (Present (Id)); 8101 8102 Error_Msg_NE 8103 ("\\ " & Pred & " of " & Id_Kind & " & verified #", 8104 Error_Nod, Id); 8105 end Output_Verification_Call; 8106 8107 -- Start of processing for Output_Call 8108 8109 begin 8110 Error_Msg_Sloc := Sloc (N); 8111 8112 -- Accept alternative 8113 8114 if Is_Accept_Alternative_Proc (Target_Id) then 8115 Output_Accept_Alternative; 8116 8117 -- Adjustment 8118 8119 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 8120 Output_Type_Actions ("adjustment"); 8121 8122 -- Default_Initial_Condition 8123 8124 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 8125 Output_Verification_Call 8126 (Pred => "Default_Initial_Condition", 8127 Id => First_Formal_Type (Target_Id), 8128 Id_Kind => "type"); 8129 8130 -- Entries 8131 8132 elsif Is_Protected_Entry (Target_Id) then 8133 Output_Call ("entry"); 8134 8135 -- Task entry calls are never processed because the entry being 8136 -- invoked does not have a corresponding "body", it has a select. A 8137 -- task entry call appears in the stack of active scenarios for the 8138 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and 8139 -- nothing more. 8140 8141 elsif Is_Task_Entry (Target_Id) then 8142 null; 8143 8144 -- Finalization 8145 8146 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 8147 Output_Type_Actions ("finalization"); 8148 8149 -- Calls to _Finalizer procedures must not appear in the output 8150 -- because this creates confusing noise. 8151 8152 elsif Is_Finalizer_Proc (Target_Id) then 8153 null; 8154 8155 -- Initial_Condition 8156 8157 elsif Is_Initial_Condition_Proc (Target_Id) then 8158 Output_Verification_Call 8159 (Pred => "Initial_Condition", 8160 Id => Find_Enclosing_Scope (N), 8161 Id_Kind => "package"); 8162 8163 -- Initialization 8164 8165 elsif Is_Init_Proc (Target_Id) 8166 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 8167 then 8168 Output_Type_Actions ("initialization"); 8169 8170 -- Invariant 8171 8172 elsif Is_Invariant_Proc (Target_Id) then 8173 Output_Verification_Call 8174 (Pred => "invariants", 8175 Id => First_Formal_Type (Target_Id), 8176 Id_Kind => "type"); 8177 8178 -- Partial invariant calls must not appear in the output because this 8179 -- creates confusing noise. Note that a partial invariant is always 8180 -- invoked by the "full" invariant which is already placed on the 8181 -- stack. 8182 8183 elsif Is_Partial_Invariant_Proc (Target_Id) then 8184 null; 8185 8186 -- _Postconditions 8187 8188 elsif Is_Postconditions_Proc (Target_Id) then 8189 Output_Verification_Call 8190 (Pred => "postconditions", 8191 Id => Find_Enclosing_Scope (N), 8192 Id_Kind => "subprogram"); 8193 8194 -- Subprograms must come last because some of the previous cases fall 8195 -- under this category. 8196 8197 elsif Ekind (Target_Id) = E_Function then 8198 Output_Call ("function"); 8199 8200 elsif Ekind (Target_Id) = E_Procedure then 8201 Output_Call ("procedure"); 8202 8203 else 8204 pragma Assert (False); 8205 null; 8206 end if; 8207 end Output_Call; 8208 8209 ------------------- 8210 -- Output_Header -- 8211 ------------------- 8212 8213 procedure Output_Header is 8214 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); 8215 8216 begin 8217 if Ekind (Unit_Id) = E_Package then 8218 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); 8219 8220 elsif Ekind (Unit_Id) = E_Package_Body then 8221 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); 8222 8223 else 8224 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); 8225 end if; 8226 end Output_Header; 8227 8228 -------------------------- 8229 -- Output_Instantiation -- 8230 -------------------------- 8231 8232 procedure Output_Instantiation (N : Node_Id) is 8233 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); 8234 pragma Inline (Output_Instantiation); 8235 -- Emit a specific diagnostic message concerning an instantiation of 8236 -- generic unit Gen_Id. Kind denotes the kind of the instantiation. 8237 8238 -------------------------- 8239 -- Output_Instantiation -- 8240 -------------------------- 8241 8242 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is 8243 begin 8244 Error_Msg_NE 8245 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); 8246 end Output_Instantiation; 8247 8248 -- Local variables 8249 8250 Inst : Node_Id; 8251 Inst_Attrs : Instantiation_Attributes; 8252 Inst_Id : Entity_Id; 8253 Gen_Id : Entity_Id; 8254 8255 -- Start of processing for Output_Instantiation 8256 8257 begin 8258 Extract_Instantiation_Attributes 8259 (Exp_Inst => N, 8260 Inst => Inst, 8261 Inst_Id => Inst_Id, 8262 Gen_Id => Gen_Id, 8263 Attrs => Inst_Attrs); 8264 8265 Error_Msg_Node_2 := Inst_Id; 8266 Error_Msg_Sloc := Sloc (Inst); 8267 8268 if Nkind (Inst) = N_Function_Instantiation then 8269 Output_Instantiation (Gen_Id, "function"); 8270 8271 elsif Nkind (Inst) = N_Package_Instantiation then 8272 Output_Instantiation (Gen_Id, "package"); 8273 8274 elsif Nkind (Inst) = N_Procedure_Instantiation then 8275 Output_Instantiation (Gen_Id, "procedure"); 8276 8277 else 8278 pragma Assert (False); 8279 null; 8280 end if; 8281 end Output_Instantiation; 8282 8283 --------------------------------------- 8284 -- Output_SPARK_Refined_State_Pragma -- 8285 --------------------------------------- 8286 8287 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is 8288 begin 8289 Error_Msg_Sloc := Sloc (N); 8290 Error_Msg_N ("\\ refinement constituents read #", Error_Nod); 8291 end Output_SPARK_Refined_State_Pragma; 8292 8293 -------------------------------- 8294 -- Output_Variable_Assignment -- 8295 -------------------------------- 8296 8297 procedure Output_Variable_Assignment (N : Node_Id) is 8298 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); 8299 8300 begin 8301 Error_Msg_Sloc := Sloc (N); 8302 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); 8303 end Output_Variable_Assignment; 8304 8305 ------------------------------- 8306 -- Output_Variable_Reference -- 8307 ------------------------------- 8308 8309 procedure Output_Variable_Reference (N : Node_Id) is 8310 Dummy : Variable_Attributes; 8311 Var_Id : Entity_Id; 8312 8313 begin 8314 Extract_Variable_Reference_Attributes 8315 (Ref => N, 8316 Var_Id => Var_Id, 8317 Attrs => Dummy); 8318 8319 Error_Msg_Sloc := Sloc (N); 8320 8321 if Is_Read (N) then 8322 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); 8323 8324 else 8325 pragma Assert (False); 8326 null; 8327 end if; 8328 end Output_Variable_Reference; 8329 8330 -- Local variables 8331 8332 package Stack renames Scenario_Stack; 8333 8334 Dummy : Call_Attributes; 8335 N : Node_Id; 8336 Posted : Boolean; 8337 Target_Id : Entity_Id; 8338 8339 -- Start of processing for Output_Active_Scenarios 8340 8341 begin 8342 -- Active scenarios are emitted only when the static model is in effect 8343 -- because there is an inherent order by which all these scenarios were 8344 -- reached from the declaration or library level. 8345 8346 if not Static_Elaboration_Checks then 8347 return; 8348 end if; 8349 8350 Posted := False; 8351 8352 for Index in Stack.First .. Stack.Last loop 8353 N := Stack.Table (Index); 8354 8355 if not Posted then 8356 Posted := True; 8357 Output_Header; 8358 end if; 8359 8360 -- 'Access 8361 8362 if Nkind (N) = N_Attribute_Reference then 8363 Output_Access (N); 8364 8365 -- Calls 8366 8367 elsif Is_Suitable_Call (N) then 8368 Extract_Call_Attributes 8369 (Call => N, 8370 Target_Id => Target_Id, 8371 Attrs => Dummy); 8372 8373 if Is_Activation_Proc (Target_Id) then 8374 Output_Activation_Call (N); 8375 else 8376 Output_Call (N, Target_Id); 8377 end if; 8378 8379 -- Instantiations 8380 8381 elsif Is_Suitable_Instantiation (N) then 8382 Output_Instantiation (N); 8383 8384 -- Pragma Refined_State 8385 8386 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8387 Output_SPARK_Refined_State_Pragma (N); 8388 8389 -- Variable assignments 8390 8391 elsif Nkind (N) = N_Assignment_Statement then 8392 Output_Variable_Assignment (N); 8393 8394 -- Variable references 8395 8396 elsif Is_Suitable_Variable_Reference (N) then 8397 Output_Variable_Reference (N); 8398 8399 else 8400 pragma Assert (False); 8401 null; 8402 end if; 8403 end loop; 8404 end Output_Active_Scenarios; 8405 8406 ------------------------- 8407 -- Pop_Active_Scenario -- 8408 ------------------------- 8409 8410 procedure Pop_Active_Scenario (N : Node_Id) is 8411 Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); 8412 8413 begin 8414 pragma Assert (Top = N); 8415 Scenario_Stack.Decrement_Last; 8416 end Pop_Active_Scenario; 8417 8418 -------------------------------- 8419 -- Process_Activation_Generic -- 8420 -------------------------------- 8421 8422 procedure Process_Activation_Generic 8423 (Call : Node_Id; 8424 Call_Attrs : Call_Attributes; 8425 State : Processing_Attributes) 8426 is 8427 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); 8428 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. 8429 -- Typ may be a task type or a composite type with at least one task 8430 -- component. 8431 8432 procedure Process_Task_Objects (List : List_Id); 8433 -- Perform ABE checks and diagnostics for all task objects found in the 8434 -- list List. 8435 8436 ------------------------- 8437 -- Process_Task_Object -- 8438 ------------------------- 8439 8440 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is 8441 Base_Typ : constant Entity_Id := Base_Type (Typ); 8442 8443 Comp_Id : Entity_Id; 8444 Task_Attrs : Task_Attributes; 8445 8446 New_State : Processing_Attributes := State; 8447 -- Each step of the Processing phase constitutes a new state 8448 8449 begin 8450 if Is_Task_Type (Typ) then 8451 Extract_Task_Attributes 8452 (Typ => Base_Typ, 8453 Attrs => Task_Attrs); 8454 8455 -- Warnings are suppressed when a prior scenario is already in 8456 -- that mode, or when the object, activation call, or task type 8457 -- have warnings suppressed. Update the state of the Processing 8458 -- phase to reflect this. 8459 8460 New_State.Suppress_Warnings := 8461 New_State.Suppress_Warnings 8462 or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) 8463 or else not Call_Attrs.Elab_Warnings_OK 8464 or else not Task_Attrs.Elab_Warnings_OK; 8465 8466 -- Update the state of the Processing phase to indicate that any 8467 -- further traversal is now within a task body. 8468 8469 New_State.Within_Task_Body := True; 8470 8471 Process_Single_Activation 8472 (Call => Call, 8473 Call_Attrs => Call_Attrs, 8474 Obj_Id => Obj_Id, 8475 Task_Attrs => Task_Attrs, 8476 State => New_State); 8477 8478 -- Examine the component type when the object is an array 8479 8480 elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then 8481 Process_Task_Object 8482 (Obj_Id => Obj_Id, 8483 Typ => Component_Type (Typ)); 8484 8485 -- Examine individual component types when the object is a record 8486 8487 elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then 8488 Comp_Id := First_Component (Typ); 8489 while Present (Comp_Id) loop 8490 Process_Task_Object 8491 (Obj_Id => Obj_Id, 8492 Typ => Etype (Comp_Id)); 8493 8494 Next_Component (Comp_Id); 8495 end loop; 8496 end if; 8497 end Process_Task_Object; 8498 8499 -------------------------- 8500 -- Process_Task_Objects -- 8501 -------------------------- 8502 8503 procedure Process_Task_Objects (List : List_Id) is 8504 Item : Node_Id; 8505 Item_Id : Entity_Id; 8506 Item_Typ : Entity_Id; 8507 8508 begin 8509 -- Examine the contents of the list looking for an object declaration 8510 -- of a task type or one that contains a task within. 8511 8512 Item := First (List); 8513 while Present (Item) loop 8514 if Nkind (Item) = N_Object_Declaration then 8515 Item_Id := Defining_Entity (Item); 8516 Item_Typ := Etype (Item_Id); 8517 8518 if Has_Task (Item_Typ) then 8519 Process_Task_Object 8520 (Obj_Id => Item_Id, 8521 Typ => Item_Typ); 8522 end if; 8523 end if; 8524 8525 Next (Item); 8526 end loop; 8527 end Process_Task_Objects; 8528 8529 -- Local variables 8530 8531 Context : Node_Id; 8532 Spec : Node_Id; 8533 8534 -- Start of processing for Process_Activation_Generic 8535 8536 begin 8537 -- Nothing to do when the activation is a guaranteed ABE 8538 8539 if Is_Known_Guaranteed_ABE (Call) then 8540 return; 8541 end if; 8542 8543 -- Find the proper context of the activation call where all task objects 8544 -- being activated are declared. This is usually the immediate parent of 8545 -- the call. 8546 8547 Context := Parent (Call); 8548 8549 -- In the case of package bodies, the activation call is in the handled 8550 -- sequence of statements, but the task objects are in the declaration 8551 -- list of the body. 8552 8553 if Nkind (Context) = N_Handled_Sequence_Of_Statements 8554 and then Nkind (Parent (Context)) = N_Package_Body 8555 then 8556 Context := Parent (Context); 8557 end if; 8558 8559 -- Process all task objects defined in both the spec and body when the 8560 -- activation call precedes the "begin" of a package body. 8561 8562 if Nkind (Context) = N_Package_Body then 8563 Spec := 8564 Specification 8565 (Unit_Declaration_Node (Corresponding_Spec (Context))); 8566 8567 Process_Task_Objects (Visible_Declarations (Spec)); 8568 Process_Task_Objects (Private_Declarations (Spec)); 8569 Process_Task_Objects (Declarations (Context)); 8570 8571 -- Process all task objects defined in the spec when the activation call 8572 -- appears at the end of a package spec. 8573 8574 elsif Nkind (Context) = N_Package_Specification then 8575 Process_Task_Objects (Visible_Declarations (Context)); 8576 Process_Task_Objects (Private_Declarations (Context)); 8577 8578 -- Otherwise the context of the activation is some construct with a 8579 -- declarative part. Note that the corresponding record type of a task 8580 -- type is controlled. Because of this, the finalization machinery must 8581 -- relocate the task object to the handled statements of the construct 8582 -- to perform proper finalization in case of an exception. Examine the 8583 -- statements of the construct rather than the declarations. 8584 8585 else 8586 pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); 8587 8588 Process_Task_Objects (Statements (Context)); 8589 end if; 8590 end Process_Activation_Generic; 8591 8592 ------------------------------------ 8593 -- Process_Conditional_ABE_Access -- 8594 ------------------------------------ 8595 8596 procedure Process_Conditional_ABE_Access 8597 (Attr : Node_Id; 8598 State : Processing_Attributes) 8599 is 8600 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; 8601 pragma Inline (Build_Access_Marker); 8602 -- Create a suitable call marker which invokes target Target_Id 8603 8604 ------------------------- 8605 -- Build_Access_Marker -- 8606 ------------------------- 8607 8608 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is 8609 Marker : Node_Id; 8610 8611 begin 8612 Marker := Make_Call_Marker (Sloc (Attr)); 8613 8614 -- Inherit relevant attributes from the attribute 8615 8616 -- Performance note: parent traversal 8617 8618 Set_Target (Marker, Target_Id); 8619 Set_Is_Declaration_Level_Node 8620 (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); 8621 Set_Is_Dispatching_Call 8622 (Marker, False); 8623 Set_Is_Elaboration_Checks_OK_Node 8624 (Marker, Is_Elaboration_Checks_OK_Node (Attr)); 8625 Set_Is_Elaboration_Warnings_OK_Node 8626 (Marker, Is_Elaboration_Warnings_OK_Node (Attr)); 8627 Set_Is_Source_Call 8628 (Marker, Comes_From_Source (Attr)); 8629 Set_Is_SPARK_Mode_On_Node 8630 (Marker, Is_SPARK_Mode_On_Node (Attr)); 8631 8632 -- Partially insert the call marker into the tree by setting its 8633 -- parent pointer. 8634 8635 Set_Parent (Marker, Attr); 8636 8637 return Marker; 8638 end Build_Access_Marker; 8639 8640 -- Local variables 8641 8642 Root : constant Node_Id := Root_Scenario; 8643 Target_Id : constant Entity_Id := Entity (Prefix (Attr)); 8644 8645 Target_Attrs : Target_Attributes; 8646 8647 New_State : Processing_Attributes := State; 8648 -- Each step of the Processing phase constitutes a new state 8649 8650 -- Start of processing for Process_Conditional_ABE_Access 8651 8652 begin 8653 -- Output relevant information when switch -gnatel (info messages on 8654 -- implicit Elaborate[_All] pragmas) is in effect. 8655 8656 if Elab_Info_Messages then 8657 Error_Msg_NE 8658 ("info: access to & during elaboration", Attr, Target_Id); 8659 end if; 8660 8661 Extract_Target_Attributes 8662 (Target_Id => Target_Id, 8663 Attrs => Target_Attrs); 8664 8665 -- Warnings are suppressed when a prior scenario is already in that 8666 -- mode, or when the attribute or the target have warnings suppressed. 8667 -- Update the state of the Processing phase to reflect this. 8668 8669 New_State.Suppress_Warnings := 8670 New_State.Suppress_Warnings 8671 or else not Is_Elaboration_Warnings_OK_Node (Attr) 8672 or else not Target_Attrs.Elab_Warnings_OK; 8673 8674 -- Do not emit any ABE diagnostics when the current or previous scenario 8675 -- in this traversal has suppressed elaboration warnings. 8676 8677 if New_State.Suppress_Warnings then 8678 null; 8679 8680 -- Both the attribute and the corresponding body are in the same unit. 8681 -- The corresponding body must appear prior to the root scenario which 8682 -- started the recursive search. If this is not the case, then there is 8683 -- a potential ABE if the access value is used to call the subprogram. 8684 -- Emit a warning only when switch -gnatw.f (warnings on suspucious 8685 -- 'Access) is in effect. 8686 8687 elsif Warn_On_Elab_Access 8688 and then Present (Target_Attrs.Body_Decl) 8689 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 8690 and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) 8691 then 8692 Error_Msg_Name_1 := Attribute_Name (Attr); 8693 Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); 8694 Error_Msg_N ("\possible Program_Error on later references", Attr); 8695 8696 Output_Active_Scenarios (Attr); 8697 end if; 8698 8699 -- Treat the attribute as an immediate invocation of the target when 8700 -- switch -gnatd.o (conservative elaboration order for indirect calls) 8701 -- is in effect. Note that the prior elaboration of the unit containing 8702 -- the target is ensured processing the corresponding call marker. 8703 8704 if Debug_Flag_Dot_O then 8705 Process_Conditional_ABE 8706 (N => Build_Access_Marker (Target_Id), 8707 State => New_State); 8708 8709 -- Otherwise ensure that the unit with the corresponding body is 8710 -- elaborated prior to the main unit. 8711 8712 else 8713 Ensure_Prior_Elaboration 8714 (N => Attr, 8715 Unit_Id => Target_Attrs.Unit_Id, 8716 Prag_Nam => Name_Elaborate_All, 8717 State => New_State); 8718 end if; 8719 end Process_Conditional_ABE_Access; 8720 8721 --------------------------------------------- 8722 -- Process_Conditional_ABE_Activation_Impl -- 8723 --------------------------------------------- 8724 8725 procedure Process_Conditional_ABE_Activation_Impl 8726 (Call : Node_Id; 8727 Call_Attrs : Call_Attributes; 8728 Obj_Id : Entity_Id; 8729 Task_Attrs : Task_Attributes; 8730 State : Processing_Attributes) 8731 is 8732 Check_OK : constant Boolean := 8733 not Is_Ignored_Ghost_Entity (Obj_Id) 8734 and then not Task_Attrs.Ghost_Mode_Ignore 8735 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 8736 and then Task_Attrs.Elab_Checks_OK; 8737 -- A run-time ABE check may be installed only when the object and the 8738 -- task type have active elaboration checks, and both are not ignored 8739 -- Ghost constructs. 8740 8741 Root : constant Node_Id := Root_Scenario; 8742 8743 New_State : Processing_Attributes := State; 8744 -- Each step of the Processing phase constitutes a new state 8745 8746 begin 8747 -- Output relevant information when switch -gnatel (info messages on 8748 -- implicit Elaborate[_All] pragmas) is in effect. 8749 8750 if Elab_Info_Messages then 8751 Error_Msg_NE 8752 ("info: activation of & during elaboration", Call, Obj_Id); 8753 end if; 8754 8755 -- Nothing to do when the call activates a task whose type is defined 8756 -- within an instance and switch -gnatd_i (ignore activations and calls 8757 -- to instances for elaboration) is in effect. 8758 8759 if Debug_Flag_Underscore_I 8760 and then In_External_Instance 8761 (N => Call, 8762 Target_Decl => Task_Attrs.Task_Decl) 8763 then 8764 return; 8765 8766 -- Nothing to do when the activation is a guaranteed ABE 8767 8768 elsif Is_Known_Guaranteed_ABE (Call) then 8769 return; 8770 8771 -- Nothing to do when the root scenario appears at the declaration 8772 -- level and the task is in the same unit, but outside this context. 8773 -- 8774 -- task type Task_Typ; -- task declaration 8775 -- 8776 -- procedure Proc is 8777 -- function A ... is 8778 -- begin 8779 -- if Some_Condition then 8780 -- declare 8781 -- T : Task_Typ; 8782 -- begin 8783 -- <activation call> -- activation site 8784 -- end; 8785 -- ... 8786 -- end A; 8787 -- 8788 -- X : ... := A; -- root scenario 8789 -- ... 8790 -- 8791 -- task body Task_Typ is 8792 -- ... 8793 -- end Task_Typ; 8794 -- 8795 -- In the example above, the context of X is the declarative list of 8796 -- Proc. The "elaboration" of X may reach the activation of T whose body 8797 -- is defined outside of X's context. The task body is relevant only 8798 -- when Proc is invoked, but this happens only in "normal" elaboration, 8799 -- therefore the task body must not be considered if this is not the 8800 -- case. 8801 8802 -- Performance note: parent traversal 8803 8804 elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then 8805 return; 8806 8807 -- Nothing to do when the activation is ABE-safe 8808 -- 8809 -- generic 8810 -- package Gen is 8811 -- task type Task_Typ; 8812 -- end Gen; 8813 -- 8814 -- package body Gen is 8815 -- task body Task_Typ is 8816 -- begin 8817 -- ... 8818 -- end Task_Typ; 8819 -- end Gen; 8820 -- 8821 -- with Gen; 8822 -- procedure Main is 8823 -- package Nested is 8824 -- package Inst is new Gen; 8825 -- T : Inst.Task_Typ; 8826 -- <activation call> -- safe activation 8827 -- end Nested; 8828 -- ... 8829 8830 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 8831 8832 -- Note that the task body must still be examined for any nested 8833 -- scenarios. 8834 8835 null; 8836 8837 -- The activation call and the task body are both in the main unit 8838 8839 elsif Present (Task_Attrs.Body_Decl) 8840 and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) 8841 then 8842 -- If the root scenario appears prior to the task body, then this is 8843 -- a possible ABE with respect to the root scenario. 8844 -- 8845 -- task type Task_Typ; 8846 -- 8847 -- function A ... is 8848 -- begin 8849 -- if Some_Condition then 8850 -- declare 8851 -- package Pack is 8852 -- T : Task_Typ; 8853 -- end Pack; -- activation of T 8854 -- ... 8855 -- end A; 8856 -- 8857 -- X : ... := A; -- root scenario 8858 -- 8859 -- task body Task_Typ is -- task body 8860 -- ... 8861 -- end Task_Typ; 8862 -- 8863 -- Y : ... := A; -- root scenario 8864 -- 8865 -- IMPORTANT: The activation of T is a possible ABE for X, but 8866 -- not for Y. Intalling an unconditional ABE raise prior to the 8867 -- activation call would be wrong as it will fail for Y as well 8868 -- but in Y's case the activation of T is never an ABE. 8869 8870 if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then 8871 8872 -- Do not emit any ABE diagnostics when a previous scenario in 8873 -- this traversal has suppressed elaboration warnings. 8874 8875 if State.Suppress_Warnings then 8876 null; 8877 8878 -- Do not emit any ABE diagnostics when the activation occurs in 8879 -- a partial finalization context because this leads to confusing 8880 -- noise. 8881 8882 elsif State.Within_Partial_Finalization then 8883 null; 8884 8885 -- ABE diagnostics are emitted only in the static model because 8886 -- there is a well-defined order to visiting scenarios. Without 8887 -- this order diagnostics appear jumbled and result in unwanted 8888 -- noise. 8889 8890 elsif Static_Elaboration_Checks then 8891 Error_Msg_Sloc := Sloc (Call); 8892 Error_Msg_N 8893 ("??task & will be activated # before elaboration of its " 8894 & "body", Obj_Id); 8895 Error_Msg_N 8896 ("\Program_Error may be raised at run time", Obj_Id); 8897 8898 Output_Active_Scenarios (Obj_Id); 8899 end if; 8900 8901 -- Install a conditional run-time ABE check to verify that the 8902 -- task body has been elaborated prior to the activation call. 8903 8904 if Check_OK then 8905 Install_ABE_Check 8906 (N => Call, 8907 Ins_Nod => Call, 8908 Target_Id => Task_Attrs.Spec_Id, 8909 Target_Decl => Task_Attrs.Task_Decl, 8910 Target_Body => Task_Attrs.Body_Decl); 8911 8912 -- Update the state of the Processing phase to indicate that 8913 -- no implicit Elaborate[_All] pragmas must be generated from 8914 -- this point on. 8915 -- 8916 -- task type Task_Typ; 8917 -- 8918 -- function A ... is 8919 -- begin 8920 -- if Some_Condition then 8921 -- declare 8922 -- package Pack is 8923 -- <ABE check> 8924 -- T : Task_Typ; 8925 -- end Pack; -- activation of T 8926 -- ... 8927 -- end A; 8928 -- 8929 -- X : ... := A; 8930 -- 8931 -- task body Task_Typ is 8932 -- begin 8933 -- External.Subp; -- imparts Elaborate_All 8934 -- end Task_Typ; 8935 -- 8936 -- If Some_Condition is True, then the ABE check will fail at 8937 -- runtime and the call to External.Subp will never take place, 8938 -- rendering the implicit Elaborate_All useless. 8939 -- 8940 -- If Some_Condition is False, then the call to External.Subp 8941 -- will never take place, rendering the implicit Elaborate_All 8942 -- useless. 8943 8944 New_State.Suppress_Implicit_Pragmas := True; 8945 end if; 8946 end if; 8947 8948 -- Otherwise the task body is not available in this compilation or it 8949 -- resides in an external unit. Install a run-time ABE check to verify 8950 -- that the task body has been elaborated prior to the activation call 8951 -- when the dynamic model is in effect. 8952 8953 elsif Dynamic_Elaboration_Checks and then Check_OK then 8954 Install_ABE_Check 8955 (N => Call, 8956 Ins_Nod => Call, 8957 Id => Task_Attrs.Unit_Id); 8958 end if; 8959 8960 -- Both the activation call and task type are subject to SPARK_Mode 8961 -- On, this triggers the SPARK rules for task activation. Compared to 8962 -- calls and instantiations, task activation in SPARK does not require 8963 -- the presence of Elaborate[_All] pragmas in case the task type is 8964 -- defined outside the main unit. This is because SPARK utilizes a 8965 -- special policy which activates all tasks after the main unit has 8966 -- finished its elaboration. 8967 8968 if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then 8969 null; 8970 8971 -- Otherwise the Ada rules are in effect. Ensure that the unit with the 8972 -- task body is elaborated prior to the main unit. 8973 8974 else 8975 Ensure_Prior_Elaboration 8976 (N => Call, 8977 Unit_Id => Task_Attrs.Unit_Id, 8978 Prag_Nam => Name_Elaborate_All, 8979 State => New_State); 8980 end if; 8981 8982 Traverse_Body 8983 (N => Task_Attrs.Body_Decl, 8984 State => New_State); 8985 end Process_Conditional_ABE_Activation_Impl; 8986 8987 procedure Process_Conditional_ABE_Activation is 8988 new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); 8989 8990 ---------------------------------- 8991 -- Process_Conditional_ABE_Call -- 8992 ---------------------------------- 8993 8994 procedure Process_Conditional_ABE_Call 8995 (Call : Node_Id; 8996 Call_Attrs : Call_Attributes; 8997 Target_Id : Entity_Id; 8998 State : Processing_Attributes) 8999 is 9000 function In_Initialization_Context (N : Node_Id) return Boolean; 9001 -- Determine whether arbitrary node N appears within a type init proc, 9002 -- primitive [Deep_]Initialize, or a block created for initialization 9003 -- purposes. 9004 9005 function Is_Partial_Finalization_Proc return Boolean; 9006 pragma Inline (Is_Partial_Finalization_Proc); 9007 -- Determine whether call Call with target Target_Id invokes a partial 9008 -- finalization procedure. 9009 9010 ------------------------------- 9011 -- In_Initialization_Context -- 9012 ------------------------------- 9013 9014 function In_Initialization_Context (N : Node_Id) return Boolean is 9015 Par : Node_Id; 9016 Spec_Id : Entity_Id; 9017 9018 begin 9019 -- Climb the parent chain looking for initialization actions 9020 9021 Par := Parent (N); 9022 while Present (Par) loop 9023 9024 -- A block may be part of the initialization actions of a default 9025 -- initialized object. 9026 9027 if Nkind (Par) = N_Block_Statement 9028 and then Is_Initialization_Block (Par) 9029 then 9030 return True; 9031 9032 -- A subprogram body may denote an initialization routine 9033 9034 elsif Nkind (Par) = N_Subprogram_Body then 9035 Spec_Id := Unique_Defining_Entity (Par); 9036 9037 -- The current subprogram body denotes a type init proc or 9038 -- primitive [Deep_]Initialize. 9039 9040 if Is_Init_Proc (Spec_Id) 9041 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 9042 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 9043 then 9044 return True; 9045 end if; 9046 9047 -- Prevent the search from going too far 9048 9049 elsif Is_Body_Or_Package_Declaration (Par) then 9050 exit; 9051 end if; 9052 9053 Par := Parent (Par); 9054 end loop; 9055 9056 return False; 9057 end In_Initialization_Context; 9058 9059 ---------------------------------- 9060 -- Is_Partial_Finalization_Proc -- 9061 ---------------------------------- 9062 9063 function Is_Partial_Finalization_Proc return Boolean is 9064 begin 9065 -- To qualify, the target must denote primitive [Deep_]Finalize or a 9066 -- finalizer procedure, and the call must appear in an initialization 9067 -- context. 9068 9069 return 9070 (Is_Controlled_Proc (Target_Id, Name_Finalize) 9071 or else Is_Finalizer_Proc (Target_Id) 9072 or else Is_TSS (Target_Id, TSS_Deep_Finalize)) 9073 and then In_Initialization_Context (Call); 9074 end Is_Partial_Finalization_Proc; 9075 9076 -- Local variables 9077 9078 SPARK_Rules_On : Boolean; 9079 Target_Attrs : Target_Attributes; 9080 9081 New_State : Processing_Attributes := State; 9082 -- Each step of the Processing phase constitutes a new state 9083 9084 -- Start of processing for Process_Conditional_ABE_Call 9085 9086 begin 9087 Extract_Target_Attributes 9088 (Target_Id => Target_Id, 9089 Attrs => Target_Attrs); 9090 9091 -- The SPARK rules are in effect when both the call and target are 9092 -- subject to SPARK_Mode On. 9093 9094 SPARK_Rules_On := 9095 Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; 9096 9097 -- Output relevant information when switch -gnatel (info messages on 9098 -- implicit Elaborate[_All] pragmas) is in effect. 9099 9100 if Elab_Info_Messages then 9101 Info_Call 9102 (Call => Call, 9103 Target_Id => Target_Id, 9104 Info_Msg => True, 9105 In_SPARK => SPARK_Rules_On); 9106 end if; 9107 9108 -- Check whether the invocation of an entry clashes with an existing 9109 -- restriction. 9110 9111 if Is_Protected_Entry (Target_Id) then 9112 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9113 9114 elsif Is_Task_Entry (Target_Id) then 9115 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9116 9117 -- Task entry calls are never processed because the entry being 9118 -- invoked does not have a corresponding "body", it has a select. 9119 9120 return; 9121 end if; 9122 9123 -- Nothing to do when the call invokes a target defined within an 9124 -- instance and switch -gnatd_i (ignore activations and calls to 9125 -- instances for elaboration) is in effect. 9126 9127 if Debug_Flag_Underscore_I 9128 and then In_External_Instance 9129 (N => Call, 9130 Target_Decl => Target_Attrs.Spec_Decl) 9131 then 9132 return; 9133 9134 -- Nothing to do when the call is a guaranteed ABE 9135 9136 elsif Is_Known_Guaranteed_ABE (Call) then 9137 return; 9138 9139 -- Nothing to do when the root scenario appears at the declaration level 9140 -- and the target is in the same unit, but outside this context. 9141 -- 9142 -- function B ...; -- target declaration 9143 -- 9144 -- procedure Proc is 9145 -- function A ... is 9146 -- begin 9147 -- if Some_Condition then 9148 -- return B; -- call site 9149 -- ... 9150 -- end A; 9151 -- 9152 -- X : ... := A; -- root scenario 9153 -- ... 9154 -- 9155 -- function B ... is 9156 -- ... 9157 -- end B; 9158 -- 9159 -- In the example above, the context of X is the declarative region of 9160 -- Proc. The "elaboration" of X may eventually reach B which is defined 9161 -- outside of X's context. B is relevant only when Proc is invoked, but 9162 -- this happens only by means of "normal" elaboration, therefore B must 9163 -- not be considered if this is not the case. 9164 9165 -- Performance note: parent traversal 9166 9167 elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 9168 return; 9169 end if; 9170 9171 -- Warnings are suppressed when a prior scenario is already in that 9172 -- mode, or the call or target have warnings suppressed. Update the 9173 -- state of the Processing phase to reflect this. 9174 9175 New_State.Suppress_Warnings := 9176 New_State.Suppress_Warnings 9177 or else not Call_Attrs.Elab_Warnings_OK 9178 or else not Target_Attrs.Elab_Warnings_OK; 9179 9180 -- The call occurs in an initial condition context when a prior scenario 9181 -- is already in that mode, or when the target is an Initial_Condition 9182 -- procedure. Update the state of the Processing phase to reflect this. 9183 9184 New_State.Within_Initial_Condition := 9185 New_State.Within_Initial_Condition 9186 or else Is_Initial_Condition_Proc (Target_Id); 9187 9188 -- The call occurs in a partial finalization context when a prior 9189 -- scenario is already in that mode, or when the target denotes a 9190 -- [Deep_]Finalize primitive or a finalizer within an initialization 9191 -- context. Update the state of the Processing phase to reflect this. 9192 9193 New_State.Within_Partial_Finalization := 9194 New_State.Within_Partial_Finalization 9195 or else Is_Partial_Finalization_Proc; 9196 9197 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 9198 -- elaboration rules in SPARK code) is intentionally not taken into 9199 -- account here because Process_Conditional_ABE_Call_SPARK has two 9200 -- separate modes of operation. 9201 9202 if SPARK_Rules_On then 9203 Process_Conditional_ABE_Call_SPARK 9204 (Call => Call, 9205 Target_Id => Target_Id, 9206 Target_Attrs => Target_Attrs, 9207 State => New_State); 9208 9209 -- Otherwise the Ada rules are in effect 9210 9211 else 9212 Process_Conditional_ABE_Call_Ada 9213 (Call => Call, 9214 Call_Attrs => Call_Attrs, 9215 Target_Id => Target_Id, 9216 Target_Attrs => Target_Attrs, 9217 State => New_State); 9218 end if; 9219 9220 -- Inspect the target body (and barried function) for other suitable 9221 -- elaboration scenarios. 9222 9223 Traverse_Body 9224 (N => Target_Attrs.Body_Barf, 9225 State => New_State); 9226 9227 Traverse_Body 9228 (N => Target_Attrs.Body_Decl, 9229 State => New_State); 9230 end Process_Conditional_ABE_Call; 9231 9232 -------------------------------------- 9233 -- Process_Conditional_ABE_Call_Ada -- 9234 -------------------------------------- 9235 9236 procedure Process_Conditional_ABE_Call_Ada 9237 (Call : Node_Id; 9238 Call_Attrs : Call_Attributes; 9239 Target_Id : Entity_Id; 9240 Target_Attrs : Target_Attributes; 9241 State : Processing_Attributes) 9242 is 9243 Check_OK : constant Boolean := 9244 not Call_Attrs.Ghost_Mode_Ignore 9245 and then not Target_Attrs.Ghost_Mode_Ignore 9246 and then Call_Attrs.Elab_Checks_OK 9247 and then Target_Attrs.Elab_Checks_OK; 9248 -- A run-time ABE check may be installed only when both the call and the 9249 -- target have active elaboration checks, and both are not ignored Ghost 9250 -- constructs. 9251 9252 Root : constant Node_Id := Root_Scenario; 9253 9254 New_State : Processing_Attributes := State; 9255 -- Each step of the Processing phase constitutes a new state 9256 9257 begin 9258 -- Nothing to do for an Ada dispatching call because there are no ABE 9259 -- diagnostics for either models. ABE checks for the dynamic model are 9260 -- handled by Install_Primitive_Elaboration_Check. 9261 9262 if Call_Attrs.Is_Dispatching then 9263 return; 9264 9265 -- Nothing to do when the call is ABE-safe 9266 -- 9267 -- generic 9268 -- function Gen ...; 9269 -- 9270 -- function Gen ... is 9271 -- begin 9272 -- ... 9273 -- end Gen; 9274 -- 9275 -- with Gen; 9276 -- procedure Main is 9277 -- function Inst is new Gen; 9278 -- X : ... := Inst; -- safe call 9279 -- ... 9280 9281 elsif Is_Safe_Call (Call, Target_Attrs) then 9282 return; 9283 9284 -- The call and the target body are both in the main unit 9285 9286 elsif Present (Target_Attrs.Body_Decl) 9287 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9288 then 9289 -- If the root scenario appears prior to the target body, then this 9290 -- is a possible ABE with respect to the root scenario. 9291 -- 9292 -- function B ...; 9293 -- 9294 -- function A ... is 9295 -- begin 9296 -- if Some_Condition then 9297 -- return B; -- call site 9298 -- ... 9299 -- end A; 9300 -- 9301 -- X : ... := A; -- root scenario 9302 -- 9303 -- function B ... is -- target body 9304 -- ... 9305 -- end B; 9306 -- 9307 -- Y : ... := A; -- root scenario 9308 -- 9309 -- IMPORTANT: The call to B from A is a possible ABE for X, but not 9310 -- for Y. Installing an unconditional ABE raise prior to the call to 9311 -- B would be wrong as it will fail for Y as well, but in Y's case 9312 -- the call to B is never an ABE. 9313 9314 if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then 9315 9316 -- Do not emit any ABE diagnostics when a previous scenario in 9317 -- this traversal has suppressed elaboration warnings. 9318 9319 if State.Suppress_Warnings then 9320 null; 9321 9322 -- Do not emit any ABE diagnostics when the call occurs in a 9323 -- partial finalization context because this leads to confusing 9324 -- noise. 9325 9326 elsif State.Within_Partial_Finalization then 9327 null; 9328 9329 -- ABE diagnostics are emitted only in the static model because 9330 -- there is a well-defined order to visiting scenarios. Without 9331 -- this order diagnostics appear jumbled and result in unwanted 9332 -- noise. 9333 9334 elsif Static_Elaboration_Checks then 9335 Error_Msg_NE 9336 ("??cannot call & before body seen", Call, Target_Id); 9337 Error_Msg_N ("\Program_Error may be raised at run time", Call); 9338 9339 Output_Active_Scenarios (Call); 9340 end if; 9341 9342 -- Install a conditional run-time ABE check to verify that the 9343 -- target body has been elaborated prior to the call. 9344 9345 if Check_OK then 9346 Install_ABE_Check 9347 (N => Call, 9348 Ins_Nod => Call, 9349 Target_Id => Target_Attrs.Spec_Id, 9350 Target_Decl => Target_Attrs.Spec_Decl, 9351 Target_Body => Target_Attrs.Body_Decl); 9352 9353 -- Update the state of the Processing phase to indicate that 9354 -- no implicit Elaborate[_All] pragmas must be generated from 9355 -- this point on. 9356 -- 9357 -- function B ...; 9358 -- 9359 -- function A ... is 9360 -- begin 9361 -- if Some_Condition then 9362 -- <ABE check> 9363 -- return B; 9364 -- ... 9365 -- end A; 9366 -- 9367 -- X : ... := A; 9368 -- 9369 -- function B ... is 9370 -- External.Subp; -- imparts Elaborate_All 9371 -- end B; 9372 -- 9373 -- If Some_Condition is True, then the ABE check will fail at 9374 -- runtime and the call to External.Subp will never take place, 9375 -- rendering the implicit Elaborate_All useless. 9376 -- 9377 -- If Some_Condition is False, then the call to External.Subp 9378 -- will never take place, rendering the implicit Elaborate_All 9379 -- useless. 9380 9381 New_State.Suppress_Implicit_Pragmas := True; 9382 end if; 9383 end if; 9384 9385 -- Otherwise the target body is not available in this compilation or it 9386 -- resides in an external unit. Install a run-time ABE check to verify 9387 -- that the target body has been elaborated prior to the call site when 9388 -- the dynamic model is in effect. 9389 9390 elsif Dynamic_Elaboration_Checks and then Check_OK then 9391 Install_ABE_Check 9392 (N => Call, 9393 Ins_Nod => Call, 9394 Id => Target_Attrs.Unit_Id); 9395 end if; 9396 9397 -- Ensure that the unit with the target body is elaborated prior to the 9398 -- main unit. The implicit Elaborate[_All] is generated only when the 9399 -- call has elaboration checks enabled. This behaviour parallels that of 9400 -- the old ABE mechanism. 9401 9402 if Call_Attrs.Elab_Checks_OK then 9403 Ensure_Prior_Elaboration 9404 (N => Call, 9405 Unit_Id => Target_Attrs.Unit_Id, 9406 Prag_Nam => Name_Elaborate_All, 9407 State => New_State); 9408 end if; 9409 end Process_Conditional_ABE_Call_Ada; 9410 9411 ---------------------------------------- 9412 -- Process_Conditional_ABE_Call_SPARK -- 9413 ---------------------------------------- 9414 9415 procedure Process_Conditional_ABE_Call_SPARK 9416 (Call : Node_Id; 9417 Target_Id : Entity_Id; 9418 Target_Attrs : Target_Attributes; 9419 State : Processing_Attributes) 9420 is 9421 Region : Node_Id; 9422 9423 begin 9424 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9425 -- verification. 9426 9427 Check_SPARK_Model_In_Effect (Call); 9428 9429 -- The call and the target body are both in the main unit 9430 9431 if Present (Target_Attrs.Body_Decl) 9432 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9433 then 9434 -- If the call appears prior to the target body, then the call must 9435 -- appear within the early call region of the target body. 9436 -- 9437 -- function B ...; 9438 -- 9439 -- X : ... := B; -- call site 9440 -- 9441 -- <preelaborable construct 1> --+ 9442 -- ... | early call region 9443 -- <preelaborable construct N> --+ 9444 -- 9445 -- function B ... is -- target body 9446 -- ... 9447 -- end B; 9448 -- 9449 -- When the call to B is not nested within some other scenario, the 9450 -- call is automatically illegal because it can never appear in the 9451 -- early call region of B's body. This is equivalent to a guaranteed 9452 -- ABE. 9453 -- 9454 -- <preelaborable construct 1> --+ 9455 -- | 9456 -- function B ...; | 9457 -- | 9458 -- function A ... is | 9459 -- begin | early call region 9460 -- if Some_Condition then 9461 -- return B; -- call site 9462 -- ... 9463 -- end A; | 9464 -- | 9465 -- <preelaborable construct N> --+ 9466 -- 9467 -- function B ... is -- target body 9468 -- ... 9469 -- end B; 9470 -- 9471 -- When the call to B is nested within some other scenario, the call 9472 -- is always ABE-safe. It is not immediately obvious why this is the 9473 -- case. The elaboration safety follows from the early call region 9474 -- rule being applied to ALL calls preceding their associated bodies. 9475 -- 9476 -- In the example above, the call to B is safe as long as the call to 9477 -- A is safe. There are several cases to consider: 9478 -- 9479 -- <call 1 to A> 9480 -- function B ...; 9481 -- 9482 -- <call 2 to A> 9483 -- function A ... is 9484 -- begin 9485 -- if Some_Condition then 9486 -- return B; 9487 -- ... 9488 -- end A; 9489 -- 9490 -- <call 3 to A> 9491 -- function B ... is 9492 -- ... 9493 -- end B; 9494 -- 9495 -- * Call 1 - This call is either nested within some scenario or not, 9496 -- which falls under the two general cases outlined above. 9497 -- 9498 -- * Call 2 - This is the same case as Call 1. 9499 -- 9500 -- * Call 3 - The placement of this call limits the range of B's 9501 -- early call region unto call 3, therefore the call to B is no 9502 -- longer within the early call region of B's body, making it ABE- 9503 -- unsafe and therefore illegal. 9504 9505 if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then 9506 9507 -- Do not emit any ABE diagnostics when a previous scenario in 9508 -- this traversal has suppressed elaboration warnings. 9509 9510 if State.Suppress_Warnings then 9511 null; 9512 9513 -- Do not emit any ABE diagnostics when the call occurs in an 9514 -- initial condition context because this leads to incorrect 9515 -- diagnostics. 9516 9517 elsif State.Within_Initial_Condition then 9518 null; 9519 9520 -- Do not emit any ABE diagnostics when the call occurs in a 9521 -- partial finalization context because this leads to confusing 9522 -- noise. 9523 9524 elsif State.Within_Partial_Finalization then 9525 null; 9526 9527 -- ABE diagnostics are emitted only in the static model because 9528 -- there is a well-defined order to visiting scenarios. Without 9529 -- this order diagnostics appear jumbled and result in unwanted 9530 -- noise. 9531 9532 elsif Static_Elaboration_Checks then 9533 9534 -- Ensure that a call which textually precedes the subprogram 9535 -- body it invokes appears within the early call region of the 9536 -- subprogram body. 9537 9538 -- IMPORTANT: This check must always be performed even when 9539 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9540 -- not specified because the static model cannot guarantee the 9541 -- absence of elaboration issues in the presence of dispatching 9542 -- calls. 9543 9544 Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); 9545 9546 if Earlier_In_Extended_Unit (Call, Region) then 9547 Error_Msg_NE 9548 ("call must appear within early call region of subprogram " 9549 & "body & (SPARK RM 7.7(3))", Call, Target_Id); 9550 9551 Error_Msg_Sloc := Sloc (Region); 9552 Error_Msg_N ("\region starts #", Call); 9553 9554 Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); 9555 Error_Msg_N ("\region ends #", Call); 9556 9557 Output_Active_Scenarios (Call); 9558 end if; 9559 end if; 9560 9561 -- Otherwise the call appears after the target body. The call is 9562 -- ABE-safe as a consequence of applying the early call region rule 9563 -- to ALL calls preceding their associated bodies. 9564 9565 else 9566 null; 9567 end if; 9568 end if; 9569 9570 -- A call to a source target or to a target which emulates Ada or SPARK 9571 -- semantics imposes an Elaborate_All requirement on the context of the 9572 -- main unit. Determine whether the context has a pragma strong enough 9573 -- to meet the requirement. 9574 9575 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9576 -- SPARK elaboration rules in SPARK code) is active because the static 9577 -- model can ensure the prior elaboration of the unit which contains a 9578 -- body by installing an implicit Elaborate[_All] pragma. 9579 9580 if Debug_Flag_Dot_V then 9581 if Target_Attrs.From_Source 9582 or else Is_Ada_Semantic_Target (Target_Id) 9583 or else Is_SPARK_Semantic_Target (Target_Id) 9584 then 9585 Meet_Elaboration_Requirement 9586 (N => Call, 9587 Target_Id => Target_Id, 9588 Req_Nam => Name_Elaborate_All); 9589 end if; 9590 9591 -- Otherwise ensure that the unit with the target body is elaborated 9592 -- prior to the main unit. 9593 9594 else 9595 Ensure_Prior_Elaboration 9596 (N => Call, 9597 Unit_Id => Target_Attrs.Unit_Id, 9598 Prag_Nam => Name_Elaborate_All, 9599 State => State); 9600 end if; 9601 end Process_Conditional_ABE_Call_SPARK; 9602 9603 ------------------------------------------- 9604 -- Process_Conditional_ABE_Instantiation -- 9605 ------------------------------------------- 9606 9607 procedure Process_Conditional_ABE_Instantiation 9608 (Exp_Inst : Node_Id; 9609 State : Processing_Attributes) 9610 is 9611 Gen_Attrs : Target_Attributes; 9612 Gen_Id : Entity_Id; 9613 Inst : Node_Id; 9614 Inst_Attrs : Instantiation_Attributes; 9615 Inst_Id : Entity_Id; 9616 9617 SPARK_Rules_On : Boolean; 9618 -- This flag is set when the SPARK rules are in effect 9619 9620 New_State : Processing_Attributes := State; 9621 -- Each step of the Processing phase constitutes a new state 9622 9623 begin 9624 Extract_Instantiation_Attributes 9625 (Exp_Inst => Exp_Inst, 9626 Inst => Inst, 9627 Inst_Id => Inst_Id, 9628 Gen_Id => Gen_Id, 9629 Attrs => Inst_Attrs); 9630 9631 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 9632 9633 -- The SPARK rules are in effect when both the instantiation and generic 9634 -- are subject to SPARK_Mode On. 9635 9636 SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 9637 9638 -- Output relevant information when switch -gnatel (info messages on 9639 -- implicit Elaborate[_All] pragmas) is in effect. 9640 9641 if Elab_Info_Messages then 9642 Info_Instantiation 9643 (Inst => Inst, 9644 Gen_Id => Gen_Id, 9645 Info_Msg => True, 9646 In_SPARK => SPARK_Rules_On); 9647 end if; 9648 9649 -- Nothing to do when the instantiation is a guaranteed ABE 9650 9651 if Is_Known_Guaranteed_ABE (Inst) then 9652 return; 9653 9654 -- Nothing to do when the root scenario appears at the declaration level 9655 -- and the generic is in the same unit, but outside this context. 9656 -- 9657 -- generic 9658 -- procedure Gen is ...; -- generic declaration 9659 -- 9660 -- procedure Proc is 9661 -- function A ... is 9662 -- begin 9663 -- if Some_Condition then 9664 -- declare 9665 -- procedure I is new Gen; -- instantiation site 9666 -- ... 9667 -- ... 9668 -- end A; 9669 -- 9670 -- X : ... := A; -- root scenario 9671 -- ... 9672 -- 9673 -- procedure Gen is 9674 -- ... 9675 -- end Gen; 9676 -- 9677 -- In the example above, the context of X is the declarative region of 9678 -- Proc. The "elaboration" of X may eventually reach Gen which appears 9679 -- outside of X's context. Gen is relevant only when Proc is invoked, 9680 -- but this happens only by means of "normal" elaboration, therefore 9681 -- Gen must not be considered if this is not the case. 9682 9683 -- Performance note: parent traversal 9684 9685 elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 9686 return; 9687 end if; 9688 9689 -- Warnings are suppressed when a prior scenario is already in that 9690 -- mode, or when the instantiation has warnings suppressed. Update 9691 -- the state of the processing phase to reflect this. 9692 9693 New_State.Suppress_Warnings := 9694 New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; 9695 9696 -- The SPARK rules are in effect 9697 9698 if SPARK_Rules_On then 9699 Process_Conditional_ABE_Instantiation_SPARK 9700 (Inst => Inst, 9701 Gen_Id => Gen_Id, 9702 Gen_Attrs => Gen_Attrs, 9703 State => New_State); 9704 9705 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 9706 -- violate the SPARK rules. 9707 9708 else 9709 Process_Conditional_ABE_Instantiation_Ada 9710 (Exp_Inst => Exp_Inst, 9711 Inst => Inst, 9712 Inst_Attrs => Inst_Attrs, 9713 Gen_Id => Gen_Id, 9714 Gen_Attrs => Gen_Attrs, 9715 State => New_State); 9716 end if; 9717 end Process_Conditional_ABE_Instantiation; 9718 9719 ----------------------------------------------- 9720 -- Process_Conditional_ABE_Instantiation_Ada -- 9721 ----------------------------------------------- 9722 9723 procedure Process_Conditional_ABE_Instantiation_Ada 9724 (Exp_Inst : Node_Id; 9725 Inst : Node_Id; 9726 Inst_Attrs : Instantiation_Attributes; 9727 Gen_Id : Entity_Id; 9728 Gen_Attrs : Target_Attributes; 9729 State : Processing_Attributes) 9730 is 9731 Check_OK : constant Boolean := 9732 not Inst_Attrs.Ghost_Mode_Ignore 9733 and then not Gen_Attrs.Ghost_Mode_Ignore 9734 and then Inst_Attrs.Elab_Checks_OK 9735 and then Gen_Attrs.Elab_Checks_OK; 9736 -- A run-time ABE check may be installed only when both the instance and 9737 -- the generic have active elaboration checks and both are not ignored 9738 -- Ghost constructs. 9739 9740 Root : constant Node_Id := Root_Scenario; 9741 9742 New_State : Processing_Attributes := State; 9743 -- Each step of the Processing phase constitutes a new state 9744 9745 begin 9746 -- Nothing to do when the instantiation is ABE-safe 9747 -- 9748 -- generic 9749 -- package Gen is 9750 -- ... 9751 -- end Gen; 9752 -- 9753 -- package body Gen is 9754 -- ... 9755 -- end Gen; 9756 -- 9757 -- with Gen; 9758 -- procedure Main is 9759 -- package Inst is new Gen (ABE); -- safe instantiation 9760 -- ... 9761 9762 if Is_Safe_Instantiation (Inst, Gen_Attrs) then 9763 return; 9764 9765 -- The instantiation and the generic body are both in the main unit 9766 9767 elsif Present (Gen_Attrs.Body_Decl) 9768 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 9769 then 9770 -- If the root scenario appears prior to the generic body, then this 9771 -- is a possible ABE with respect to the root scenario. 9772 -- 9773 -- generic 9774 -- package Gen is 9775 -- ... 9776 -- end Gen; 9777 -- 9778 -- function A ... is 9779 -- begin 9780 -- if Some_Condition then 9781 -- declare 9782 -- package Inst is new Gen; -- instantiation site 9783 -- ... 9784 -- end A; 9785 -- 9786 -- X : ... := A; -- root scenario 9787 -- 9788 -- package body Gen is -- generic body 9789 -- ... 9790 -- end Gen; 9791 -- 9792 -- Y : ... := A; -- root scenario 9793 -- 9794 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but 9795 -- not for Y. Installing an unconditional ABE raise prior to the 9796 -- instance site would be wrong as it will fail for Y as well, but in 9797 -- Y's case the instantiation of Gen is never an ABE. 9798 9799 if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then 9800 9801 -- Do not emit any ABE diagnostics when a previous scenario in 9802 -- this traversal has suppressed elaboration warnings. 9803 9804 if State.Suppress_Warnings then 9805 null; 9806 9807 -- Do not emit any ABE diagnostics when the instantiation occurs 9808 -- in partial finalization context because this leads to unwanted 9809 -- noise. 9810 9811 elsif State.Within_Partial_Finalization then 9812 null; 9813 9814 -- ABE diagnostics are emitted only in the static model because 9815 -- there is a well-defined order to visiting scenarios. Without 9816 -- this order diagnostics appear jumbled and result in unwanted 9817 -- noise. 9818 9819 elsif Static_Elaboration_Checks then 9820 Error_Msg_NE 9821 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9822 Error_Msg_N ("\Program_Error may be raised at run time", Inst); 9823 9824 Output_Active_Scenarios (Inst); 9825 end if; 9826 9827 -- Install a conditional run-time ABE check to verify that the 9828 -- generic body has been elaborated prior to the instantiation. 9829 9830 if Check_OK then 9831 Install_ABE_Check 9832 (N => Inst, 9833 Ins_Nod => Exp_Inst, 9834 Target_Id => Gen_Attrs.Spec_Id, 9835 Target_Decl => Gen_Attrs.Spec_Decl, 9836 Target_Body => Gen_Attrs.Body_Decl); 9837 9838 -- Update the state of the Processing phase to indicate that 9839 -- no implicit Elaborate[_All] pragmas must be generated from 9840 -- this point on. 9841 -- 9842 -- generic 9843 -- package Gen is 9844 -- ... 9845 -- end Gen; 9846 -- 9847 -- function A ... is 9848 -- begin 9849 -- if Some_Condition then 9850 -- <ABE check> 9851 -- declare Inst is new Gen; 9852 -- ... 9853 -- end A; 9854 -- 9855 -- X : ... := A; 9856 -- 9857 -- package body Gen is 9858 -- begin 9859 -- External.Subp; -- imparts Elaborate_All 9860 -- end Gen; 9861 -- 9862 -- If Some_Condition is True, then the ABE check will fail at 9863 -- runtime and the call to External.Subp will never take place, 9864 -- rendering the implicit Elaborate_All useless. 9865 -- 9866 -- If Some_Condition is False, then the call to External.Subp 9867 -- will never take place, rendering the implicit Elaborate_All 9868 -- useless. 9869 9870 New_State.Suppress_Implicit_Pragmas := True; 9871 end if; 9872 end if; 9873 9874 -- Otherwise the generic body is not available in this compilation or it 9875 -- resides in an external unit. Install a run-time ABE check to verify 9876 -- that the generic body has been elaborated prior to the instantiation 9877 -- when the dynamic model is in effect. 9878 9879 elsif Dynamic_Elaboration_Checks and then Check_OK then 9880 Install_ABE_Check 9881 (N => Inst, 9882 Ins_Nod => Exp_Inst, 9883 Id => Gen_Attrs.Unit_Id); 9884 end if; 9885 9886 -- Ensure that the unit with the generic body is elaborated prior to 9887 -- the main unit. No implicit pragma is generated if the instantiation 9888 -- has elaboration checks suppressed. This behaviour parallels that of 9889 -- the old ABE mechanism. 9890 9891 if Inst_Attrs.Elab_Checks_OK then 9892 Ensure_Prior_Elaboration 9893 (N => Inst, 9894 Unit_Id => Gen_Attrs.Unit_Id, 9895 Prag_Nam => Name_Elaborate, 9896 State => New_State); 9897 end if; 9898 end Process_Conditional_ABE_Instantiation_Ada; 9899 9900 ------------------------------------------------- 9901 -- Process_Conditional_ABE_Instantiation_SPARK -- 9902 ------------------------------------------------- 9903 9904 procedure Process_Conditional_ABE_Instantiation_SPARK 9905 (Inst : Node_Id; 9906 Gen_Id : Entity_Id; 9907 Gen_Attrs : Target_Attributes; 9908 State : Processing_Attributes) 9909 is 9910 Req_Nam : Name_Id; 9911 9912 begin 9913 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9914 -- verification. 9915 9916 Check_SPARK_Model_In_Effect (Inst); 9917 9918 -- A source instantiation imposes an Elaborate[_All] requirement on the 9919 -- context of the main unit. Determine whether the context has a pragma 9920 -- strong enough to meet the requirement. The check is orthogonal to the 9921 -- ABE ramifications of the instantiation. 9922 9923 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9924 -- SPARK elaboration rules in SPARK code) is active because the static 9925 -- model can ensure the prior elaboration of the unit which contains a 9926 -- body by installing an implicit Elaborate[_All] pragma. 9927 9928 if Debug_Flag_Dot_V then 9929 if Nkind (Inst) = N_Package_Instantiation then 9930 Req_Nam := Name_Elaborate_All; 9931 else 9932 Req_Nam := Name_Elaborate; 9933 end if; 9934 9935 Meet_Elaboration_Requirement 9936 (N => Inst, 9937 Target_Id => Gen_Id, 9938 Req_Nam => Req_Nam); 9939 9940 -- Otherwise ensure that the unit with the target body is elaborated 9941 -- prior to the main unit. 9942 9943 else 9944 Ensure_Prior_Elaboration 9945 (N => Inst, 9946 Unit_Id => Gen_Attrs.Unit_Id, 9947 Prag_Nam => Name_Elaborate, 9948 State => State); 9949 end if; 9950 end Process_Conditional_ABE_Instantiation_SPARK; 9951 9952 ------------------------------------------------- 9953 -- Process_Conditional_ABE_Variable_Assignment -- 9954 ------------------------------------------------- 9955 9956 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is 9957 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); 9958 Prag : constant Node_Id := SPARK_Pragma (Var_Id); 9959 9960 SPARK_Rules_On : Boolean; 9961 -- This flag is set when the SPARK rules are in effect 9962 9963 begin 9964 -- The SPARK rules are in effect when both the assignment and the 9965 -- variable are subject to SPARK_Mode On. 9966 9967 SPARK_Rules_On := 9968 Present (Prag) 9969 and then Get_SPARK_Mode_From_Annotation (Prag) = On 9970 and then Is_SPARK_Mode_On_Node (Asmt); 9971 9972 -- Output relevant information when switch -gnatel (info messages on 9973 -- implicit Elaborate[_All] pragmas) is in effect. 9974 9975 if Elab_Info_Messages then 9976 Elab_Msg_NE 9977 (Msg => "assignment to & during elaboration", 9978 N => Asmt, 9979 Id => Var_Id, 9980 Info_Msg => True, 9981 In_SPARK => SPARK_Rules_On); 9982 end if; 9983 9984 -- The SPARK rules are in effect. These rules are applied regardless of 9985 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9986 -- in effect because the static model cannot ensure safe assignment of 9987 -- variables. 9988 9989 if SPARK_Rules_On then 9990 Process_Conditional_ABE_Variable_Assignment_SPARK 9991 (Asmt => Asmt, 9992 Var_Id => Var_Id); 9993 9994 -- Otherwise the Ada rules are in effect 9995 9996 else 9997 Process_Conditional_ABE_Variable_Assignment_Ada 9998 (Asmt => Asmt, 9999 Var_Id => Var_Id); 10000 end if; 10001 end Process_Conditional_ABE_Variable_Assignment; 10002 10003 ----------------------------------------------------- 10004 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 10005 ----------------------------------------------------- 10006 10007 procedure Process_Conditional_ABE_Variable_Assignment_Ada 10008 (Asmt : Node_Id; 10009 Var_Id : Entity_Id) 10010 is 10011 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 10012 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 10013 10014 begin 10015 -- Emit a warning when an uninitialized variable declared in a package 10016 -- spec without a pragma Elaborate_Body is initialized by elaboration 10017 -- code within the corresponding body. 10018 10019 if Is_Elaboration_Warnings_OK_Id (Var_Id) 10020 and then not Is_Initialized (Var_Decl) 10021 and then not Has_Pragma_Elaborate_Body (Spec_Id) 10022 then 10023 Error_Msg_NE 10024 ("??variable & can be accessed by clients before this " 10025 & "initialization", Asmt, Var_Id); 10026 10027 Error_Msg_NE 10028 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 10029 & "initialization", Asmt, Spec_Id); 10030 10031 Output_Active_Scenarios (Asmt); 10032 10033 -- Generate an implicit Elaborate_Body in the spec 10034 10035 Set_Elaborate_Body_Desirable (Spec_Id); 10036 end if; 10037 end Process_Conditional_ABE_Variable_Assignment_Ada; 10038 10039 ------------------------------------------------------- 10040 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 10041 ------------------------------------------------------- 10042 10043 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 10044 (Asmt : Node_Id; 10045 Var_Id : Entity_Id) 10046 is 10047 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 10048 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 10049 10050 begin 10051 -- Ensure that a suitable elaboration model is in effect for SPARK rule 10052 -- verification. 10053 10054 Check_SPARK_Model_In_Effect (Asmt); 10055 10056 -- Emit an error when an initialized variable declared in a package spec 10057 -- without pragma Elaborate_Body is further modified by elaboration code 10058 -- within the corresponding body. 10059 10060 if Is_Elaboration_Warnings_OK_Id (Var_Id) 10061 and then Is_Initialized (Var_Decl) 10062 and then not Has_Pragma_Elaborate_Body (Spec_Id) 10063 then 10064 Error_Msg_NE 10065 ("variable & modified by elaboration code in package body", 10066 Asmt, Var_Id); 10067 10068 Error_Msg_NE 10069 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 10070 & "initialization", Asmt, Spec_Id); 10071 10072 Output_Active_Scenarios (Asmt); 10073 end if; 10074 end Process_Conditional_ABE_Variable_Assignment_SPARK; 10075 10076 ------------------------------------------------ 10077 -- Process_Conditional_ABE_Variable_Reference -- 10078 ------------------------------------------------ 10079 10080 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is 10081 Var_Attrs : Variable_Attributes; 10082 Var_Id : Entity_Id; 10083 10084 begin 10085 Extract_Variable_Reference_Attributes 10086 (Ref => Ref, 10087 Var_Id => Var_Id, 10088 Attrs => Var_Attrs); 10089 10090 if Is_Read (Ref) then 10091 Process_Conditional_ABE_Variable_Reference_Read 10092 (Ref => Ref, 10093 Var_Id => Var_Id, 10094 Attrs => Var_Attrs); 10095 end if; 10096 end Process_Conditional_ABE_Variable_Reference; 10097 10098 ----------------------------------------------------- 10099 -- Process_Conditional_ABE_Variable_Reference_Read -- 10100 ----------------------------------------------------- 10101 10102 procedure Process_Conditional_ABE_Variable_Reference_Read 10103 (Ref : Node_Id; 10104 Var_Id : Entity_Id; 10105 Attrs : Variable_Attributes) 10106 is 10107 begin 10108 -- Output relevant information when switch -gnatel (info messages on 10109 -- implicit Elaborate[_All] pragmas) is in effect. 10110 10111 if Elab_Info_Messages then 10112 Elab_Msg_NE 10113 (Msg => "read of variable & during elaboration", 10114 N => Ref, 10115 Id => Var_Id, 10116 Info_Msg => True, 10117 In_SPARK => True); 10118 end if; 10119 10120 -- Nothing to do when the variable appears within the main unit because 10121 -- diagnostics on reads are relevant only for external variables. 10122 10123 if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then 10124 null; 10125 10126 -- Nothing to do when the variable is already initialized. Note that the 10127 -- variable may be further modified by the external unit. 10128 10129 elsif Is_Initialized (Declaration_Node (Var_Id)) then 10130 null; 10131 10132 -- Nothing to do when the external unit guarantees the initialization of 10133 -- the variable by means of pragma Elaborate_Body. 10134 10135 elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then 10136 null; 10137 10138 -- A variable read imposes an Elaborate requirement on the context of 10139 -- the main unit. Determine whether the context has a pragma strong 10140 -- enough to meet the requirement. 10141 10142 else 10143 Meet_Elaboration_Requirement 10144 (N => Ref, 10145 Target_Id => Var_Id, 10146 Req_Nam => Name_Elaborate); 10147 end if; 10148 end Process_Conditional_ABE_Variable_Reference_Read; 10149 10150 ----------------------------- 10151 -- Process_Conditional_ABE -- 10152 ----------------------------- 10153 10154 -- NOTE: The body of this routine is intentionally out of order because it 10155 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). 10156 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10157 10158 procedure Process_Conditional_ABE 10159 (N : Node_Id; 10160 State : Processing_Attributes := Initial_State) 10161 is 10162 Call_Attrs : Call_Attributes; 10163 Target_Id : Entity_Id; 10164 10165 begin 10166 -- Add the current scenario to the stack of active scenarios 10167 10168 Push_Active_Scenario (N); 10169 10170 -- 'Access 10171 10172 if Is_Suitable_Access (N) then 10173 Process_Conditional_ABE_Access 10174 (Attr => N, 10175 State => State); 10176 10177 -- Activations and calls 10178 10179 elsif Is_Suitable_Call (N) then 10180 10181 -- In general, only calls found within the main unit are processed 10182 -- because the ALI information supplied to binde is for the main 10183 -- unit only. However, to preserve the consistency of the tree and 10184 -- ensure proper serialization of internal names, external calls 10185 -- also receive corresponding call markers (see Build_Call_Marker). 10186 -- Regardless of the reason, external calls must not be processed. 10187 10188 if In_Main_Context (N) then 10189 Extract_Call_Attributes 10190 (Call => N, 10191 Target_Id => Target_Id, 10192 Attrs => Call_Attrs); 10193 10194 if Is_Activation_Proc (Target_Id) then 10195 Process_Conditional_ABE_Activation 10196 (Call => N, 10197 Call_Attrs => Call_Attrs, 10198 State => State); 10199 10200 else 10201 Process_Conditional_ABE_Call 10202 (Call => N, 10203 Call_Attrs => Call_Attrs, 10204 Target_Id => Target_Id, 10205 State => State); 10206 end if; 10207 end if; 10208 10209 -- Instantiations 10210 10211 elsif Is_Suitable_Instantiation (N) then 10212 Process_Conditional_ABE_Instantiation 10213 (Exp_Inst => N, 10214 State => State); 10215 10216 -- Variable assignments 10217 10218 elsif Is_Suitable_Variable_Assignment (N) then 10219 Process_Conditional_ABE_Variable_Assignment (N); 10220 10221 -- Variable references 10222 10223 elsif Is_Suitable_Variable_Reference (N) then 10224 10225 -- In general, only variable references found within the main unit 10226 -- are processed because the ALI information supplied to binde is for 10227 -- the main unit only. However, to preserve the consistency of the 10228 -- tree and ensure proper serialization of internal names, external 10229 -- variable references also receive corresponding variable reference 10230 -- markers (see Build_Varaible_Reference_Marker). Regardless of the 10231 -- reason, external variable references must not be processed. 10232 10233 if In_Main_Context (N) then 10234 Process_Conditional_ABE_Variable_Reference (N); 10235 end if; 10236 end if; 10237 10238 -- Remove the current scenario from the stack of active scenarios once 10239 -- all ABE diagnostics and checks have been performed. 10240 10241 Pop_Active_Scenario (N); 10242 end Process_Conditional_ABE; 10243 10244 -------------------------------------------- 10245 -- Process_Guaranteed_ABE_Activation_Impl -- 10246 -------------------------------------------- 10247 10248 procedure Process_Guaranteed_ABE_Activation_Impl 10249 (Call : Node_Id; 10250 Call_Attrs : Call_Attributes; 10251 Obj_Id : Entity_Id; 10252 Task_Attrs : Task_Attributes; 10253 State : Processing_Attributes) 10254 is 10255 pragma Unreferenced (State); 10256 10257 Check_OK : constant Boolean := 10258 not Is_Ignored_Ghost_Entity (Obj_Id) 10259 and then not Task_Attrs.Ghost_Mode_Ignore 10260 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 10261 and then Task_Attrs.Elab_Checks_OK; 10262 -- A run-time ABE check may be installed only when the object and the 10263 -- task type have active elaboration checks, and both are not ignored 10264 -- Ghost constructs. 10265 10266 begin 10267 -- Nothing to do when the root scenario appears at the declaration 10268 -- level and the task is in the same unit, but outside this context. 10269 -- 10270 -- task type Task_Typ; -- task declaration 10271 -- 10272 -- procedure Proc is 10273 -- function A ... is 10274 -- begin 10275 -- if Some_Condition then 10276 -- declare 10277 -- T : Task_Typ; 10278 -- begin 10279 -- <activation call> -- activation site 10280 -- end; 10281 -- ... 10282 -- end A; 10283 -- 10284 -- X : ... := A; -- root scenario 10285 -- ... 10286 -- 10287 -- task body Task_Typ is 10288 -- ... 10289 -- end Task_Typ; 10290 -- 10291 -- In the example above, the context of X is the declarative list of 10292 -- Proc. The "elaboration" of X may reach the activation of T whose body 10293 -- is defined outside of X's context. The task body is relevant only 10294 -- when Proc is invoked, but this happens only in "normal" elaboration, 10295 -- therefore the task body must not be considered if this is not the 10296 -- case. 10297 10298 -- Performance note: parent traversal 10299 10300 if Is_Up_Level_Target (Task_Attrs.Task_Decl) then 10301 return; 10302 10303 -- Nothing to do when the activation is ABE-safe 10304 -- 10305 -- generic 10306 -- package Gen is 10307 -- task type Task_Typ; 10308 -- end Gen; 10309 -- 10310 -- package body Gen is 10311 -- task body Task_Typ is 10312 -- begin 10313 -- ... 10314 -- end Task_Typ; 10315 -- end Gen; 10316 -- 10317 -- with Gen; 10318 -- procedure Main is 10319 -- package Nested is 10320 -- package Inst is new Gen; 10321 -- T : Inst.Task_Typ; 10322 -- end Nested; -- safe activation 10323 -- ... 10324 10325 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 10326 return; 10327 10328 -- An activation call leads to a guaranteed ABE when the activation 10329 -- call and the task appear within the same context ignoring library 10330 -- levels, and the body of the task has not been seen yet or appears 10331 -- after the activation call. 10332 -- 10333 -- procedure Guaranteed_ABE is 10334 -- task type Task_Typ; 10335 -- 10336 -- package Nested is 10337 -- T : Task_Typ; 10338 -- <activation call> -- guaranteed ABE 10339 -- end Nested; 10340 -- 10341 -- task body Task_Typ is 10342 -- ... 10343 -- end Task_Typ; 10344 -- ... 10345 10346 -- Performance note: parent traversal 10347 10348 elsif Is_Guaranteed_ABE 10349 (N => Call, 10350 Target_Decl => Task_Attrs.Task_Decl, 10351 Target_Body => Task_Attrs.Body_Decl) 10352 then 10353 if Call_Attrs.Elab_Warnings_OK then 10354 Error_Msg_Sloc := Sloc (Call); 10355 Error_Msg_N 10356 ("??task & will be activated # before elaboration of its body", 10357 Obj_Id); 10358 Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); 10359 end if; 10360 10361 -- Mark the activation call as a guaranteed ABE 10362 10363 Set_Is_Known_Guaranteed_ABE (Call); 10364 10365 -- Install a run-time ABE failue because this activation call will 10366 -- always result in an ABE. 10367 10368 if Check_OK then 10369 Install_ABE_Failure 10370 (N => Call, 10371 Ins_Nod => Call); 10372 end if; 10373 end if; 10374 end Process_Guaranteed_ABE_Activation_Impl; 10375 10376 procedure Process_Guaranteed_ABE_Activation is 10377 new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); 10378 10379 --------------------------------- 10380 -- Process_Guaranteed_ABE_Call -- 10381 --------------------------------- 10382 10383 procedure Process_Guaranteed_ABE_Call 10384 (Call : Node_Id; 10385 Call_Attrs : Call_Attributes; 10386 Target_Id : Entity_Id) 10387 is 10388 Target_Attrs : Target_Attributes; 10389 10390 begin 10391 Extract_Target_Attributes 10392 (Target_Id => Target_Id, 10393 Attrs => Target_Attrs); 10394 10395 -- Nothing to do when the root scenario appears at the declaration level 10396 -- and the target is in the same unit, but outside this context. 10397 -- 10398 -- function B ...; -- target declaration 10399 -- 10400 -- procedure Proc is 10401 -- function A ... is 10402 -- begin 10403 -- if Some_Condition then 10404 -- return B; -- call site 10405 -- ... 10406 -- end A; 10407 -- 10408 -- X : ... := A; -- root scenario 10409 -- ... 10410 -- 10411 -- function B ... is 10412 -- ... 10413 -- end B; 10414 -- 10415 -- In the example above, the context of X is the declarative region of 10416 -- Proc. The "elaboration" of X may eventually reach B which is defined 10417 -- outside of X's context. B is relevant only when Proc is invoked, but 10418 -- this happens only by means of "normal" elaboration, therefore B must 10419 -- not be considered if this is not the case. 10420 10421 -- Performance note: parent traversal 10422 10423 if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 10424 return; 10425 10426 -- Nothing to do when the call is ABE-safe 10427 -- 10428 -- generic 10429 -- function Gen ...; 10430 -- 10431 -- function Gen ... is 10432 -- begin 10433 -- ... 10434 -- end Gen; 10435 -- 10436 -- with Gen; 10437 -- procedure Main is 10438 -- function Inst is new Gen; 10439 -- X : ... := Inst; -- safe call 10440 -- ... 10441 10442 elsif Is_Safe_Call (Call, Target_Attrs) then 10443 return; 10444 10445 -- A call leads to a guaranteed ABE when the call and the target appear 10446 -- within the same context ignoring library levels, and the body of the 10447 -- target has not been seen yet or appears after the call. 10448 -- 10449 -- procedure Guaranteed_ABE is 10450 -- function Func ...; 10451 -- 10452 -- package Nested is 10453 -- Obj : ... := Func; -- guaranteed ABE 10454 -- end Nested; 10455 -- 10456 -- function Func ... is 10457 -- ... 10458 -- end Func; 10459 -- ... 10460 10461 -- Performance note: parent traversal 10462 10463 elsif Is_Guaranteed_ABE 10464 (N => Call, 10465 Target_Decl => Target_Attrs.Spec_Decl, 10466 Target_Body => Target_Attrs.Body_Decl) 10467 then 10468 if Call_Attrs.Elab_Warnings_OK then 10469 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); 10470 Error_Msg_N ("\Program_Error will be raised at run time", Call); 10471 end if; 10472 10473 -- Mark the call as a guarnateed ABE 10474 10475 Set_Is_Known_Guaranteed_ABE (Call); 10476 10477 -- Install a run-time ABE failure because the call will always result 10478 -- in an ABE. The failure is installed when both the call and target 10479 -- have enabled elaboration checks, and both are not ignored Ghost 10480 -- constructs. 10481 10482 if Call_Attrs.Elab_Checks_OK 10483 and then Target_Attrs.Elab_Checks_OK 10484 and then not Call_Attrs.Ghost_Mode_Ignore 10485 and then not Target_Attrs.Ghost_Mode_Ignore 10486 then 10487 Install_ABE_Failure 10488 (N => Call, 10489 Ins_Nod => Call); 10490 end if; 10491 end if; 10492 end Process_Guaranteed_ABE_Call; 10493 10494 ------------------------------------------ 10495 -- Process_Guaranteed_ABE_Instantiation -- 10496 ------------------------------------------ 10497 10498 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is 10499 Gen_Attrs : Target_Attributes; 10500 Gen_Id : Entity_Id; 10501 Inst : Node_Id; 10502 Inst_Attrs : Instantiation_Attributes; 10503 Inst_Id : Entity_Id; 10504 10505 begin 10506 Extract_Instantiation_Attributes 10507 (Exp_Inst => Exp_Inst, 10508 Inst => Inst, 10509 Inst_Id => Inst_Id, 10510 Gen_Id => Gen_Id, 10511 Attrs => Inst_Attrs); 10512 10513 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 10514 10515 -- Nothing to do when the root scenario appears at the declaration level 10516 -- and the generic is in the same unit, but outside this context. 10517 -- 10518 -- generic 10519 -- procedure Gen is ...; -- generic declaration 10520 -- 10521 -- procedure Proc is 10522 -- function A ... is 10523 -- begin 10524 -- if Some_Condition then 10525 -- declare 10526 -- procedure I is new Gen; -- instantiation site 10527 -- ... 10528 -- ... 10529 -- end A; 10530 -- 10531 -- X : ... := A; -- root scenario 10532 -- ... 10533 -- 10534 -- procedure Gen is 10535 -- ... 10536 -- end Gen; 10537 -- 10538 -- In the example above, the context of X is the declarative region of 10539 -- Proc. The "elaboration" of X may eventually reach Gen which appears 10540 -- outside of X's context. Gen is relevant only when Proc is invoked, 10541 -- but this happens only by means of "normal" elaboration, therefore 10542 -- Gen must not be considered if this is not the case. 10543 10544 -- Performance note: parent traversal 10545 10546 if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 10547 return; 10548 10549 -- Nothing to do when the instantiation is ABE-safe 10550 -- 10551 -- generic 10552 -- package Gen is 10553 -- ... 10554 -- end Gen; 10555 -- 10556 -- package body Gen is 10557 -- ... 10558 -- end Gen; 10559 -- 10560 -- with Gen; 10561 -- procedure Main is 10562 -- package Inst is new Gen (ABE); -- safe instantiation 10563 -- ... 10564 10565 elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then 10566 return; 10567 10568 -- An instantiation leads to a guaranteed ABE when the instantiation and 10569 -- the generic appear within the same context ignoring library levels, 10570 -- and the body of the generic has not been seen yet or appears after 10571 -- the instantiation. 10572 -- 10573 -- procedure Guaranteed_ABE is 10574 -- generic 10575 -- procedure Gen; 10576 -- 10577 -- package Nested is 10578 -- procedure Inst is new Gen; -- guaranteed ABE 10579 -- end Nested; 10580 -- 10581 -- procedure Gen is 10582 -- ... 10583 -- end Gen; 10584 -- ... 10585 10586 -- Performance note: parent traversal 10587 10588 elsif Is_Guaranteed_ABE 10589 (N => Inst, 10590 Target_Decl => Gen_Attrs.Spec_Decl, 10591 Target_Body => Gen_Attrs.Body_Decl) 10592 then 10593 if Inst_Attrs.Elab_Warnings_OK then 10594 Error_Msg_NE 10595 ("??cannot instantiate & before body seen", Inst, Gen_Id); 10596 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 10597 end if; 10598 10599 -- Mark the instantiation as a guarantee ABE. This automatically 10600 -- suppresses the instantiation of the generic body. 10601 10602 Set_Is_Known_Guaranteed_ABE (Inst); 10603 10604 -- Install a run-time ABE failure because the instantiation will 10605 -- always result in an ABE. The failure is installed when both the 10606 -- instance and the generic have enabled elaboration checks, and both 10607 -- are not ignored Ghost constructs. 10608 10609 if Inst_Attrs.Elab_Checks_OK 10610 and then Gen_Attrs.Elab_Checks_OK 10611 and then not Inst_Attrs.Ghost_Mode_Ignore 10612 and then not Gen_Attrs.Ghost_Mode_Ignore 10613 then 10614 Install_ABE_Failure 10615 (N => Inst, 10616 Ins_Nod => Exp_Inst); 10617 end if; 10618 end if; 10619 end Process_Guaranteed_ABE_Instantiation; 10620 10621 ---------------------------- 10622 -- Process_Guaranteed_ABE -- 10623 ---------------------------- 10624 10625 -- NOTE: The body of this routine is intentionally out of order because it 10626 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). 10627 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10628 10629 procedure Process_Guaranteed_ABE (N : Node_Id) is 10630 Call_Attrs : Call_Attributes; 10631 Target_Id : Entity_Id; 10632 10633 begin 10634 -- Add the current scenario to the stack of active scenarios 10635 10636 Push_Active_Scenario (N); 10637 10638 -- Only calls, instantiations, and task activations may result in a 10639 -- guaranteed ABE. 10640 10641 if Is_Suitable_Call (N) then 10642 Extract_Call_Attributes 10643 (Call => N, 10644 Target_Id => Target_Id, 10645 Attrs => Call_Attrs); 10646 10647 if Is_Activation_Proc (Target_Id) then 10648 Process_Guaranteed_ABE_Activation 10649 (Call => N, 10650 Call_Attrs => Call_Attrs, 10651 State => Initial_State); 10652 10653 else 10654 Process_Guaranteed_ABE_Call 10655 (Call => N, 10656 Call_Attrs => Call_Attrs, 10657 Target_Id => Target_Id); 10658 end if; 10659 10660 elsif Is_Suitable_Instantiation (N) then 10661 Process_Guaranteed_ABE_Instantiation (N); 10662 end if; 10663 10664 -- Remove the current scenario from the stack of active scenarios once 10665 -- all ABE diagnostics and checks have been performed. 10666 10667 Pop_Active_Scenario (N); 10668 end Process_Guaranteed_ABE; 10669 10670 -------------------------- 10671 -- Push_Active_Scenario -- 10672 -------------------------- 10673 10674 procedure Push_Active_Scenario (N : Node_Id) is 10675 begin 10676 Scenario_Stack.Append (N); 10677 end Push_Active_Scenario; 10678 10679 --------------------------------- 10680 -- Record_Elaboration_Scenario -- 10681 --------------------------------- 10682 10683 procedure Record_Elaboration_Scenario (N : Node_Id) is 10684 Level : Enclosing_Level_Kind; 10685 10686 Any_Level_OK : Boolean; 10687 -- This flag is set when a particular scenario is allowed to appear at 10688 -- any level. 10689 10690 Declaration_Level_OK : Boolean; 10691 -- This flag is set when a particular scenario is allowed to appear at 10692 -- the declaration level. 10693 10694 Library_Level_OK : Boolean; 10695 -- This flag is set when a particular scenario is allowed to appear at 10696 -- the library level. 10697 10698 begin 10699 -- Assume that the scenario cannot appear on any level 10700 10701 Any_Level_OK := False; 10702 Declaration_Level_OK := False; 10703 Library_Level_OK := False; 10704 10705 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 10706 -- enabled) is in effect because the legacy ABE mechanism does not need 10707 -- to carry out this action. 10708 10709 if Legacy_Elaboration_Checks then 10710 return; 10711 10712 -- Nothing to do for ASIS because ABE checks and diagnostics are not 10713 -- performed in this mode. 10714 10715 elsif ASIS_Mode then 10716 return; 10717 10718 -- Nothing to do when the scenario is being preanalyzed 10719 10720 elsif Preanalysis_Active then 10721 return; 10722 end if; 10723 10724 -- Ensure that a library-level call does not appear in a preelaborated 10725 -- unit. The check must come before ignoring scenarios within external 10726 -- units or inside generics because calls in those context must also be 10727 -- verified. 10728 10729 if Is_Suitable_Call (N) then 10730 Check_Preelaborated_Call (N); 10731 end if; 10732 10733 -- Nothing to do when the scenario does not appear within the main unit 10734 10735 if not In_Main_Context (N) then 10736 return; 10737 10738 -- Scenarios within a generic unit are never considered because generics 10739 -- cannot be elaborated. 10740 10741 elsif Inside_A_Generic then 10742 return; 10743 10744 -- Scenarios which do not fall in one of the elaboration categories 10745 -- listed below are not considered. The categories are: 10746 10747 -- 'Access for entries, operators, and subprograms 10748 -- Assignments to variables 10749 -- Calls (includes task activation) 10750 -- Derived types 10751 -- Instantiations 10752 -- Pragma Refined_State 10753 -- Reads of variables 10754 10755 elsif Is_Suitable_Access (N) then 10756 Library_Level_OK := True; 10757 10758 -- Signal any enclosing local exception handlers that the 'Access may 10759 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 10760 -- (conservative elaboration order for indirect calls) is in effect. 10761 -- Marking the exception handlers ensures proper expansion by both 10762 -- the front and back end restriction when No_Exception_Propagation 10763 -- is in effect. 10764 10765 if Debug_Flag_Dot_O then 10766 Possible_Local_Raise (N, Standard_Program_Error); 10767 end if; 10768 10769 elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then 10770 Declaration_Level_OK := True; 10771 Library_Level_OK := True; 10772 10773 -- Signal any enclosing local exception handlers that the call or 10774 -- instantiation may raise Program_Error due to a failed ABE check. 10775 -- Marking the exception handlers ensures proper expansion by both 10776 -- the front and back end restriction when No_Exception_Propagation 10777 -- is in effect. 10778 10779 Possible_Local_Raise (N, Standard_Program_Error); 10780 10781 elsif Is_Suitable_SPARK_Derived_Type (N) then 10782 Any_Level_OK := True; 10783 10784 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10785 Library_Level_OK := True; 10786 10787 elsif Is_Suitable_Variable_Assignment (N) 10788 or else Is_Suitable_Variable_Reference (N) 10789 then 10790 Library_Level_OK := True; 10791 10792 -- Otherwise the input does not denote a suitable scenario 10793 10794 else 10795 return; 10796 end if; 10797 10798 -- The static model imposes additional restrictions on the placement of 10799 -- scenarios. In contrast, the dynamic model assumes that every scenario 10800 -- will be elaborated or invoked at some point. 10801 10802 if Static_Elaboration_Checks then 10803 10804 -- Certain scenarios are allowed to appear at any level. This check 10805 -- is performed here in order to save on a parent traversal. 10806 10807 if Any_Level_OK then 10808 null; 10809 10810 -- Otherwise the scenario must appear at a specific level 10811 10812 else 10813 -- Performance note: parent traversal 10814 10815 Level := Find_Enclosing_Level (N); 10816 10817 -- Declaration-level scenario 10818 10819 if Declaration_Level_OK and then Level = Declaration_Level then 10820 null; 10821 10822 -- Library-level or instantiation scenario 10823 10824 elsif Library_Level_OK 10825 and then Level in Library_Or_Instantiation_Level 10826 then 10827 null; 10828 10829 -- Otherwise the scenario does not appear at the proper level and 10830 -- cannot possibly act as a top-level scenario. 10831 10832 else 10833 return; 10834 end if; 10835 end if; 10836 end if; 10837 10838 -- Derived types subject to SPARK_Mode On require elaboration-related 10839 -- checks even though the type may not be declared within elaboration 10840 -- code. The types are recorded in a separate table which is examined 10841 -- during the Processing phase. Note that the checks must be delayed 10842 -- because the bodies of overriding primitives are not available yet. 10843 10844 if Is_Suitable_SPARK_Derived_Type (N) then 10845 Record_SPARK_Elaboration_Scenario (N); 10846 10847 -- Nothing left to do for derived types 10848 10849 return; 10850 10851 -- Instantiations of generics both subject to SPARK_Mode On require 10852 -- elaboration-related checks even though the instantiations may not 10853 -- appear within elaboration code. The instantiations are recored in 10854 -- a separate table which is examined during the Procesing phase. Note 10855 -- that the checks must be delayed because it is not known yet whether 10856 -- the generic unit has a body or not. 10857 10858 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which 10859 -- is subject to common conditional and guaranteed ABE checks. 10860 10861 elsif Is_Suitable_SPARK_Instantiation (N) then 10862 Record_SPARK_Elaboration_Scenario (N); 10863 10864 -- External constituents that refine abstract states which appear in 10865 -- pragma Initializes require elaboration-related checks even though 10866 -- a Refined_State pragma lacks any elaboration semantic. 10867 10868 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10869 Record_SPARK_Elaboration_Scenario (N); 10870 10871 -- Nothing left to do for pragma Refined_State 10872 10873 return; 10874 end if; 10875 10876 -- Perform early detection of guaranteed ABEs in order to suppress the 10877 -- instantiation of generic bodies as gigi cannot handle certain types 10878 -- of premature instantiations. 10879 10880 Process_Guaranteed_ABE (N); 10881 10882 -- At this point all checks have been performed. Record the scenario for 10883 -- later processing by the ABE phase. 10884 10885 Top_Level_Scenarios.Append (N); 10886 Set_Is_Recorded_Top_Level_Scenario (N); 10887 end Record_Elaboration_Scenario; 10888 10889 --------------------------------------- 10890 -- Record_SPARK_Elaboration_Scenario -- 10891 --------------------------------------- 10892 10893 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is 10894 begin 10895 SPARK_Scenarios.Append (N); 10896 Set_Is_Recorded_SPARK_Scenario (N); 10897 end Record_SPARK_Elaboration_Scenario; 10898 10899 ----------------------------------- 10900 -- Recorded_SPARK_Scenarios_Hash -- 10901 ----------------------------------- 10902 10903 function Recorded_SPARK_Scenarios_Hash 10904 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index 10905 is 10906 begin 10907 return 10908 Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); 10909 end Recorded_SPARK_Scenarios_Hash; 10910 10911 --------------------------------------- 10912 -- Recorded_Top_Level_Scenarios_Hash -- 10913 --------------------------------------- 10914 10915 function Recorded_Top_Level_Scenarios_Hash 10916 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index 10917 is 10918 begin 10919 return 10920 Recorded_Top_Level_Scenarios_Index 10921 (Key mod Recorded_Top_Level_Scenarios_Max); 10922 end Recorded_Top_Level_Scenarios_Hash; 10923 10924 -------------------------- 10925 -- Reset_Visited_Bodies -- 10926 -------------------------- 10927 10928 procedure Reset_Visited_Bodies is 10929 begin 10930 if Visited_Bodies_In_Use then 10931 Visited_Bodies_In_Use := False; 10932 Visited_Bodies.Reset; 10933 end if; 10934 end Reset_Visited_Bodies; 10935 10936 ------------------- 10937 -- Root_Scenario -- 10938 ------------------- 10939 10940 function Root_Scenario return Node_Id is 10941 package Stack renames Scenario_Stack; 10942 10943 begin 10944 -- Ensure that the scenario stack has at least one active scenario in 10945 -- it. The one at the bottom (index First) is the root scenario. 10946 10947 pragma Assert (Stack.Last >= Stack.First); 10948 return Stack.Table (Stack.First); 10949 end Root_Scenario; 10950 10951 --------------------------- 10952 -- Set_Early_Call_Region -- 10953 --------------------------- 10954 10955 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 10956 begin 10957 pragma Assert (Ekind_In (Body_Id, E_Entry, 10958 E_Entry_Family, 10959 E_Function, 10960 E_Procedure, 10961 E_Subprogram_Body)); 10962 10963 Early_Call_Regions_In_Use := True; 10964 Early_Call_Regions.Set (Body_Id, Start); 10965 end Set_Early_Call_Region; 10966 10967 ---------------------------- 10968 -- Set_Elaboration_Status -- 10969 ---------------------------- 10970 10971 procedure Set_Elaboration_Status 10972 (Unit_Id : Entity_Id; 10973 Val : Elaboration_Attributes) 10974 is 10975 begin 10976 Elaboration_Statuses_In_Use := True; 10977 Elaboration_Statuses.Set (Unit_Id, Val); 10978 end Set_Elaboration_Status; 10979 10980 ------------------------------------ 10981 -- Set_Is_Recorded_SPARK_Scenario -- 10982 ------------------------------------ 10983 10984 procedure Set_Is_Recorded_SPARK_Scenario 10985 (N : Node_Id; 10986 Val : Boolean := True) 10987 is 10988 begin 10989 Recorded_SPARK_Scenarios_In_Use := True; 10990 Recorded_SPARK_Scenarios.Set (N, Val); 10991 end Set_Is_Recorded_SPARK_Scenario; 10992 10993 ---------------------------------------- 10994 -- Set_Is_Recorded_Top_Level_Scenario -- 10995 ---------------------------------------- 10996 10997 procedure Set_Is_Recorded_Top_Level_Scenario 10998 (N : Node_Id; 10999 Val : Boolean := True) 11000 is 11001 begin 11002 Recorded_Top_Level_Scenarios_In_Use := True; 11003 Recorded_Top_Level_Scenarios.Set (N, Val); 11004 end Set_Is_Recorded_Top_Level_Scenario; 11005 11006 ------------------------- 11007 -- Set_Is_Visited_Body -- 11008 ------------------------- 11009 11010 procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is 11011 begin 11012 Visited_Bodies_In_Use := True; 11013 Visited_Bodies.Set (Subp_Body, True); 11014 end Set_Is_Visited_Body; 11015 11016 ------------------------------- 11017 -- Static_Elaboration_Checks -- 11018 ------------------------------- 11019 11020 function Static_Elaboration_Checks return Boolean is 11021 begin 11022 return not Dynamic_Elaboration_Checks; 11023 end Static_Elaboration_Checks; 11024 11025 ------------------- 11026 -- Traverse_Body -- 11027 ------------------- 11028 11029 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is 11030 procedure Find_And_Process_Nested_Scenarios; 11031 pragma Inline (Find_And_Process_Nested_Scenarios); 11032 -- Examine the declarations and statements of subprogram body N for 11033 -- suitable scenarios. 11034 11035 --------------------------------------- 11036 -- Find_And_Process_Nested_Scenarios -- 11037 --------------------------------------- 11038 11039 procedure Find_And_Process_Nested_Scenarios is 11040 function Is_Potential_Scenario 11041 (Nod : Node_Id) return Traverse_Result; 11042 -- Determine whether arbitrary node Nod denotes a suitable scenario. 11043 -- If it does, save it in the Nested_Scenarios list of the subprogram 11044 -- body, and process it. 11045 11046 procedure Traverse_List (List : List_Id); 11047 pragma Inline (Traverse_List); 11048 -- Invoke Traverse_Potential_Scenarios on each node in list List 11049 11050 procedure Traverse_Potential_Scenarios is 11051 new Traverse_Proc (Is_Potential_Scenario); 11052 11053 --------------------------- 11054 -- Is_Potential_Scenario -- 11055 --------------------------- 11056 11057 function Is_Potential_Scenario 11058 (Nod : Node_Id) return Traverse_Result 11059 is 11060 begin 11061 -- Special cases 11062 11063 -- Skip constructs which do not have elaboration of their own and 11064 -- need to be elaborated by other means such as invocation, task 11065 -- activation, etc. 11066 11067 if Is_Non_Library_Level_Encapsulator (Nod) then 11068 return Skip; 11069 11070 -- Terminate the traversal of a task body when encountering an 11071 -- accept or select statement, and 11072 -- 11073 -- * Entry calls during elaboration are not allowed. In this 11074 -- case the accept or select statement will cause the task 11075 -- to block at elaboration time because there are no entry 11076 -- calls to unblock it. 11077 -- 11078 -- or 11079 -- 11080 -- * Switch -gnatd_a (stop elaboration checks on accept or 11081 -- select statement) is in effect. 11082 11083 elsif (Debug_Flag_Underscore_A 11084 or else Restriction_Active 11085 (No_Entry_Calls_In_Elaboration_Code)) 11086 and then Nkind_In (Original_Node (Nod), N_Accept_Statement, 11087 N_Selective_Accept) 11088 then 11089 return Abandon; 11090 11091 -- Terminate the traversal of a task body when encountering a 11092 -- suspension call, and 11093 -- 11094 -- * Entry calls during elaboration are not allowed. In this 11095 -- case the suspension call emulates an entry call and will 11096 -- cause the task to block at elaboration time. 11097 -- 11098 -- or 11099 -- 11100 -- * Switch -gnatd_s (stop elaboration checks on synchronous 11101 -- suspension) is in effect. 11102 -- 11103 -- Note that the guard should not be checking the state of flag 11104 -- Within_Task_Body because only suspension calls which appear 11105 -- immediately within the statements of the task are supported. 11106 -- Flag Within_Task_Body carries over to deeper levels of the 11107 -- traversal. 11108 11109 elsif (Debug_Flag_Underscore_S 11110 or else Restriction_Active 11111 (No_Entry_Calls_In_Elaboration_Code)) 11112 and then Is_Synchronous_Suspension_Call (Nod) 11113 and then In_Task_Body (Nod) 11114 then 11115 return Abandon; 11116 11117 -- Certain nodes carry semantic lists which act as repositories 11118 -- until expansion transforms the node and relocates the contents. 11119 -- Examine these lists in case expansion is disabled. 11120 11121 elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then 11122 Traverse_List (Actions (Nod)); 11123 11124 elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then 11125 Traverse_List (Condition_Actions (Nod)); 11126 11127 elsif Nkind (Nod) = N_If_Expression then 11128 Traverse_List (Then_Actions (Nod)); 11129 Traverse_List (Else_Actions (Nod)); 11130 11131 elsif Nkind_In (Nod, N_Component_Association, 11132 N_Iterated_Component_Association) 11133 then 11134 Traverse_List (Loop_Actions (Nod)); 11135 11136 -- General case 11137 11138 elsif Is_Suitable_Scenario (Nod) then 11139 Process_Conditional_ABE 11140 (N => Nod, 11141 State => State); 11142 end if; 11143 11144 return OK; 11145 end Is_Potential_Scenario; 11146 11147 ------------------- 11148 -- Traverse_List -- 11149 ------------------- 11150 11151 procedure Traverse_List (List : List_Id) is 11152 Item : Node_Id; 11153 11154 begin 11155 Item := First (List); 11156 while Present (Item) loop 11157 Traverse_Potential_Scenarios (Item); 11158 Next (Item); 11159 end loop; 11160 end Traverse_List; 11161 11162 -- Start of processing for Find_And_Process_Nested_Scenarios 11163 11164 begin 11165 -- Examine the declarations for suitable scenarios 11166 11167 Traverse_List (Declarations (N)); 11168 11169 -- Examine the handled sequence of statements. This also includes any 11170 -- exceptions handlers. 11171 11172 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 11173 end Find_And_Process_Nested_Scenarios; 11174 11175 -- Start of processing for Traverse_Body 11176 11177 begin 11178 -- Nothing to do when there is no body 11179 11180 if No (N) then 11181 return; 11182 11183 elsif Nkind (N) /= N_Subprogram_Body then 11184 return; 11185 end if; 11186 11187 -- Nothing to do if the body was already traversed during the processing 11188 -- of the same top-level scenario. 11189 11190 if Is_Visited_Body (N) then 11191 return; 11192 11193 -- Otherwise mark the body as traversed 11194 11195 else 11196 Set_Is_Visited_Body (N); 11197 end if; 11198 11199 -- Examine the declarations and statements of the subprogram body for 11200 -- suitable scenarios, save and process them accordingly. 11201 11202 Find_And_Process_Nested_Scenarios; 11203 end Traverse_Body; 11204 11205 ----------------- 11206 -- Unit_Entity -- 11207 ----------------- 11208 11209 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is 11210 function Is_Subunit (Id : Entity_Id) return Boolean; 11211 pragma Inline (Is_Subunit); 11212 -- Determine whether the entity of an initial declaration denotes a 11213 -- subunit. 11214 11215 ---------------- 11216 -- Is_Subunit -- 11217 ---------------- 11218 11219 function Is_Subunit (Id : Entity_Id) return Boolean is 11220 Decl : constant Node_Id := Unit_Declaration_Node (Id); 11221 11222 begin 11223 return 11224 Nkind_In (Decl, N_Generic_Package_Declaration, 11225 N_Generic_Subprogram_Declaration, 11226 N_Package_Declaration, 11227 N_Protected_Type_Declaration, 11228 N_Subprogram_Declaration, 11229 N_Task_Type_Declaration) 11230 and then Present (Corresponding_Body (Decl)) 11231 and then Nkind (Parent (Unit_Declaration_Node 11232 (Corresponding_Body (Decl)))) = N_Subunit; 11233 end Is_Subunit; 11234 11235 -- Local variables 11236 11237 Id : Entity_Id; 11238 11239 -- Start of processing for Unit_Entity 11240 11241 begin 11242 Id := Unique_Entity (Unit_Id); 11243 11244 -- Skip all subunits found in the scope chain which ends at the input 11245 -- unit. 11246 11247 while Is_Subunit (Id) loop 11248 Id := Scope (Id); 11249 end loop; 11250 11251 return Id; 11252 end Unit_Entity; 11253 11254 --------------------------------- 11255 -- Update_Elaboration_Scenario -- 11256 --------------------------------- 11257 11258 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 11259 procedure Update_SPARK_Scenario; 11260 pragma Inline (Update_SPARK_Scenario); 11261 -- Update the contents of table SPARK_Scenarios if Old_N is recorded 11262 -- there. 11263 11264 procedure Update_Top_Level_Scenario; 11265 pragma Inline (Update_Top_Level_Scenario); 11266 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded 11267 -- there. 11268 11269 --------------------------- 11270 -- Update_SPARK_Scenario -- 11271 --------------------------- 11272 11273 procedure Update_SPARK_Scenario is 11274 package Scenarios renames SPARK_Scenarios; 11275 11276 begin 11277 if Is_Recorded_SPARK_Scenario (Old_N) then 11278 11279 -- Performance note: list traversal 11280 11281 for Index in Scenarios.First .. Scenarios.Last loop 11282 if Scenarios.Table (Index) = Old_N then 11283 Scenarios.Table (Index) := New_N; 11284 11285 -- The old SPARK scenario is no longer recorded, but the new 11286 -- one is. 11287 11288 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11289 Set_Is_Recorded_Top_Level_Scenario (New_N); 11290 return; 11291 end if; 11292 end loop; 11293 11294 -- A recorded SPARK scenario must be in the table of recorded 11295 -- SPARK scenarios. 11296 11297 pragma Assert (False); 11298 end if; 11299 end Update_SPARK_Scenario; 11300 11301 ------------------------------- 11302 -- Update_Top_Level_Scenario -- 11303 ------------------------------- 11304 11305 procedure Update_Top_Level_Scenario is 11306 package Scenarios renames Top_Level_Scenarios; 11307 11308 begin 11309 if Is_Recorded_Top_Level_Scenario (Old_N) then 11310 11311 -- Performance note: list traversal 11312 11313 for Index in Scenarios.First .. Scenarios.Last loop 11314 if Scenarios.Table (Index) = Old_N then 11315 Scenarios.Table (Index) := New_N; 11316 11317 -- The old top-level scenario is no longer recorded, but the 11318 -- new one is. 11319 11320 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11321 Set_Is_Recorded_Top_Level_Scenario (New_N); 11322 return; 11323 end if; 11324 end loop; 11325 11326 -- A recorded top-level scenario must be in the table of recorded 11327 -- top-level scenarios. 11328 11329 pragma Assert (False); 11330 end if; 11331 end Update_Top_Level_Scenario; 11332 11333 -- Start of processing for Update_Elaboration_Requirement 11334 11335 begin 11336 -- Nothing to do when the old and new scenarios are one and the same 11337 11338 if Old_N = New_N then 11339 return; 11340 11341 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 11342 -- internal data structures to reflect this change. This ensures that a 11343 -- potential run-time conditional ABE check or a guaranteed ABE failure 11344 -- is inserted at the proper place in the tree. 11345 11346 elsif Is_Scenario (Old_N) then 11347 Update_SPARK_Scenario; 11348 Update_Top_Level_Scenario; 11349 end if; 11350 end Update_Elaboration_Scenario; 11351 11352 ------------------------- 11353 -- Visited_Bodies_Hash -- 11354 ------------------------- 11355 11356 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is 11357 begin 11358 return Visited_Bodies_Index (Key mod Visited_Bodies_Max); 11359 end Visited_Bodies_Hash; 11360 11361 --------------------------------------------------------------------------- 11362 -- -- 11363 -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- 11364 -- -- 11365 -- M E C H A N I S M -- 11366 -- -- 11367 --------------------------------------------------------------------------- 11368 11369 -- This section contains the implementation of the pre-18.x legacy ABE 11370 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 11371 -- elaboration checking mode enabled). 11372 11373 ----------------------------- 11374 -- Description of Approach -- 11375 ----------------------------- 11376 11377 -- Every non-static call that is encountered by Sem_Res results in a call 11378 -- to Check_Elab_Call, with N being the call node, and Outer set to its 11379 -- default value of True. In addition X'Access is treated like a call 11380 -- for the access-to-procedure case, and in SPARK mode only we also 11381 -- check variable references. 11382 11383 -- The goal of Check_Elab_Call is to determine whether or not the reference 11384 -- in question can generate an access before elaboration error (raising 11385 -- Program_Error) either by directly calling a subprogram whose body 11386 -- has not yet been elaborated, or indirectly, by calling a subprogram 11387 -- whose body has been elaborated, but which contains a call to such a 11388 -- subprogram. 11389 11390 -- In addition, in SPARK mode, we are checking for a variable reference in 11391 -- another package, which requires an explicit Elaborate_All pragma. 11392 11393 -- The only references that we need to look at the outer level are 11394 -- references that occur in elaboration code. There are two cases. The 11395 -- reference can be at the outer level of elaboration code, or it can 11396 -- be within another unit, e.g. the elaboration code of a subprogram. 11397 11398 -- In the case of an elaboration call at the outer level, we must trace 11399 -- all calls to outer level routines either within the current unit or to 11400 -- other units that are with'ed. For calls within the current unit, we can 11401 -- determine if the body has been elaborated or not, and if it has not, 11402 -- then a warning is generated. 11403 11404 -- Note that there are two subcases. If the original call directly calls a 11405 -- subprogram whose body has not been elaborated, then we know that an ABE 11406 -- will take place, and we replace the call by a raise of Program_Error. 11407 -- If the call is indirect, then we don't know that the PE will be raised, 11408 -- since the call might be guarded by a conditional. In this case we set 11409 -- Do_Elab_Check on the call so that a dynamic check is generated, and 11410 -- output a warning. 11411 11412 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 11413 -- reference (SPARK mode case), we require that a pragma Elaborate_All 11414 -- or pragma Elaborate be present, or that the referenced unit have a 11415 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 11416 -- of these conditions is met, then a warning is generated that a pragma 11417 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 11418 -- pragma is generated. 11419 11420 -- For the case of an elaboration call at some inner level, we are 11421 -- interested in tracing only calls to subprograms at the same level, i.e. 11422 -- those that can be called during elaboration. Any calls to outer level 11423 -- routines cannot cause ABE's as a result of the original call (there 11424 -- might be an outer level call to the subprogram from outside that causes 11425 -- the ABE, but that gets analyzed separately). 11426 11427 -- Note that we never trace calls to inner level subprograms, since these 11428 -- cannot result in ABE's unless there is an elaboration problem at a lower 11429 -- level, which will be separately detected. 11430 11431 -- Note on pragma Elaborate. The checking here assumes that a pragma 11432 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 11433 -- can be called without causing an ABE. This is not in fact the case since 11434 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 11435 -- by Elaborate_All. However, we decide to trust the user in this case. 11436 11437 -------------------------------------- 11438 -- Instantiation Elaboration Errors -- 11439 -------------------------------------- 11440 11441 -- A special case arises when an instantiation appears in a context that is 11442 -- known to be before the body is elaborated, e.g. 11443 11444 -- generic package x is ... 11445 -- ... 11446 -- package xx is new x; 11447 -- ... 11448 -- package body x is ... 11449 11450 -- In this situation it is certain that an elaboration error will occur, 11451 -- and an unconditional raise Program_Error statement is inserted before 11452 -- the instantiation, and a warning generated. 11453 11454 -- The problem is that in this case we have no place to put the body of 11455 -- the instantiation. We can't put it in the normal place, because it is 11456 -- too early, and will cause errors to occur as a result of referencing 11457 -- entities before they are declared. 11458 11459 -- Our approach in this case is simply to avoid creating the body of the 11460 -- instantiation in such a case. The instantiation spec is modified to 11461 -- include dummy bodies for all subprograms, so that the resulting code 11462 -- does not contain subprogram specs with no corresponding bodies. 11463 11464 -- The following table records the recursive call chain for output in the 11465 -- Output routine. Each entry records the call node and the entity of the 11466 -- called routine. The number of entries in the table (i.e. the value of 11467 -- Elab_Call.Last) indicates the current depth of recursion and is used to 11468 -- identify the outer level. 11469 11470 type Elab_Call_Element is record 11471 Cloc : Source_Ptr; 11472 Ent : Entity_Id; 11473 end record; 11474 11475 package Elab_Call is new Table.Table 11476 (Table_Component_Type => Elab_Call_Element, 11477 Table_Index_Type => Int, 11478 Table_Low_Bound => 1, 11479 Table_Initial => 50, 11480 Table_Increment => 100, 11481 Table_Name => "Elab_Call"); 11482 11483 -- The following table records all calls that have been processed starting 11484 -- from an outer level call. The table prevents both infinite recursion and 11485 -- useless reanalysis of calls within the same context. The use of context 11486 -- is important because it allows for proper checks in more complex code: 11487 11488 -- if ... then 11489 -- Call; -- requires a check 11490 -- Call; -- does not need a check thanks to the table 11491 -- elsif ... then 11492 -- Call; -- requires a check, different context 11493 -- end if; 11494 11495 -- Call; -- requires a check, different context 11496 11497 type Visited_Element is record 11498 Subp_Id : Entity_Id; 11499 -- The entity of the subprogram being called 11500 11501 Context : Node_Id; 11502 -- The context where the call to the subprogram occurs 11503 end record; 11504 11505 package Elab_Visited is new Table.Table 11506 (Table_Component_Type => Visited_Element, 11507 Table_Index_Type => Int, 11508 Table_Low_Bound => 1, 11509 Table_Initial => 200, 11510 Table_Increment => 100, 11511 Table_Name => "Elab_Visited"); 11512 11513 -- The following table records delayed calls which must be examined after 11514 -- all generic bodies have been instantiated. 11515 11516 type Delay_Element is record 11517 N : Node_Id; 11518 -- The parameter N from the call to Check_Internal_Call. Note that this 11519 -- node may get rewritten over the delay period by expansion in the call 11520 -- case (but not in the instantiation case). 11521 11522 E : Entity_Id; 11523 -- The parameter E from the call to Check_Internal_Call 11524 11525 Orig_Ent : Entity_Id; 11526 -- The parameter Orig_Ent from the call to Check_Internal_Call 11527 11528 Curscop : Entity_Id; 11529 -- The current scope of the call. This is restored when we complete the 11530 -- delayed call, so that we do this in the right scope. 11531 11532 Outer_Scope : Entity_Id; 11533 -- Save scope of outer level call 11534 11535 From_Elab_Code : Boolean; 11536 -- Save indication of whether this call is from elaboration code 11537 11538 In_Task_Activation : Boolean; 11539 -- Save indication of whether this call is from a task body. Tasks are 11540 -- activated at the "begin", which is after all local procedure bodies, 11541 -- so calls to those procedures can't fail, even if they occur after the 11542 -- task body. 11543 11544 From_SPARK_Code : Boolean; 11545 -- Save indication of whether this call is under SPARK_Mode => On 11546 end record; 11547 11548 package Delay_Check is new Table.Table 11549 (Table_Component_Type => Delay_Element, 11550 Table_Index_Type => Int, 11551 Table_Low_Bound => 1, 11552 Table_Initial => 1000, 11553 Table_Increment => 100, 11554 Table_Name => "Delay_Check"); 11555 11556 C_Scope : Entity_Id; 11557 -- Top-level scope of current scope. Compute this only once at the outer 11558 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 11559 11560 Outer_Level_Sloc : Source_Ptr; 11561 -- Save Sloc value for outer level call node for comparisons of source 11562 -- locations. A body is too late if it appears after the *outer* level 11563 -- call, not the particular call that is being analyzed. 11564 11565 From_Elab_Code : Boolean; 11566 -- This flag shows whether the outer level call currently being examined 11567 -- is or is not in elaboration code. We are only interested in calls to 11568 -- routines in other units if this flag is True. 11569 11570 In_Task_Activation : Boolean := False; 11571 -- This flag indicates whether we are performing elaboration checks on task 11572 -- bodies, at the point of activation. If true, we do not raise 11573 -- Program_Error for calls to local procedures, because all local bodies 11574 -- are known to be elaborated. However, we still need to trace such calls, 11575 -- because a local procedure could call a procedure in another package, 11576 -- so we might need an implicit Elaborate_All. 11577 11578 Delaying_Elab_Checks : Boolean := True; 11579 -- This is set True till the compilation is complete, including the 11580 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 11581 -- the delay table is used to make the delayed calls and this flag is reset 11582 -- to False, so that the calls are processed. 11583 11584 ----------------------- 11585 -- Local Subprograms -- 11586 ----------------------- 11587 11588 -- Note: Outer_Scope in all following specs represents the scope of 11589 -- interest of the outer level call. If it is set to Standard_Standard, 11590 -- then it means the outer level call was at elaboration level, and that 11591 -- thus all calls are of interest. If it was set to some other scope, 11592 -- then the original call was an inner call, and we are not interested 11593 -- in calls that go outside this scope. 11594 11595 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 11596 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 11597 -- for the WITH clause for unit U (which will always be present). A special 11598 -- case is when N is a function or procedure instantiation, in which case 11599 -- it is sufficient to set Elaborate_Desirable, since in this case there is 11600 -- no possibility of transitive elaboration issues. 11601 11602 procedure Check_A_Call 11603 (N : Node_Id; 11604 E : Entity_Id; 11605 Outer_Scope : Entity_Id; 11606 Inter_Unit_Only : Boolean; 11607 Generate_Warnings : Boolean := True; 11608 In_Init_Proc : Boolean := False); 11609 -- This is the internal recursive routine that is called to check for 11610 -- possible elaboration error. The argument N is a subprogram call or 11611 -- generic instantiation, or 'Access attribute reference to be checked, and 11612 -- E is the entity of the called subprogram, or instantiated generic unit, 11613 -- or subprogram referenced by 'Access. 11614 -- 11615 -- In SPARK mode, N can also be a variable reference, since in SPARK this 11616 -- also triggers a requirement for Elaborate_All, and in this case E is the 11617 -- entity being referenced. 11618 -- 11619 -- Outer_Scope is the outer level scope for the original reference. 11620 -- Inter_Unit_Only is set if the call is only to be checked in the 11621 -- case where it is to another unit (and skipped if within a unit). 11622 -- Generate_Warnings is set to False to suppress warning messages about 11623 -- missing pragma Elaborate_All's. These messages are not wanted for 11624 -- inner calls in the dynamic model. Note that an instance of the Access 11625 -- attribute applied to a subprogram also generates a call to this 11626 -- procedure (since the referenced subprogram may be called later 11627 -- indirectly). Flag In_Init_Proc should be set whenever the current 11628 -- context is a type init proc. 11629 -- 11630 -- Note: this might better be called Check_A_Reference to recognize the 11631 -- variable case for SPARK, but we prefer to retain the historical name 11632 -- since in practice this is mostly about checking calls for the possible 11633 -- occurrence of an access-before-elaboration exception. 11634 11635 procedure Check_Bad_Instantiation (N : Node_Id); 11636 -- N is a node for an instantiation (if called with any other node kind, 11637 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 11638 -- the special case of a generic instantiation of a generic spec in the 11639 -- same declarative part as the instantiation where a body is present and 11640 -- has not yet been seen. This is an obvious error, but needs to be checked 11641 -- specially at the time of the instantiation, since it is a case where we 11642 -- cannot insert the body anywhere. If this case is detected, warnings are 11643 -- generated, and a raise of Program_Error is inserted. In addition any 11644 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 11645 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 11646 -- flag as an indication that no attempt should be made to insert an 11647 -- instance body. 11648 11649 procedure Check_Internal_Call 11650 (N : Node_Id; 11651 E : Entity_Id; 11652 Outer_Scope : Entity_Id; 11653 Orig_Ent : Entity_Id); 11654 -- N is a function call or procedure statement call node and E is the 11655 -- entity of the called function, which is within the current compilation 11656 -- unit (where subunits count as part of the parent). This call checks if 11657 -- this call, or any call within any accessed body could cause an ABE, and 11658 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 11659 -- renamings, and points to the original name of the entity. This is used 11660 -- for error messages. Outer_Scope is the outer level scope for the 11661 -- original call. 11662 11663 procedure Check_Internal_Call_Continue 11664 (N : Node_Id; 11665 E : Entity_Id; 11666 Outer_Scope : Entity_Id; 11667 Orig_Ent : Entity_Id); 11668 -- The processing for Check_Internal_Call is divided up into two phases, 11669 -- and this represents the second phase. The second phase is delayed if 11670 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 11671 -- phase makes an entry in the Delay_Check table, which is processed when 11672 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 11673 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 11674 -- original call. 11675 11676 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 11677 -- N is either a function or procedure call or an access attribute that 11678 -- references a subprogram. This call retrieves the relevant entity. If 11679 -- this is a call to a protected subprogram, the entity is a selected 11680 -- component. The callable entity may be absent, in which case Empty is 11681 -- returned. This happens with non-analyzed calls in nested generics. 11682 -- 11683 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 11684 -- entity, in which case, the value returned is simply this entity. 11685 11686 function Has_Generic_Body (N : Node_Id) return Boolean; 11687 -- N is a generic package instantiation node, and this routine determines 11688 -- if this package spec does in fact have a generic body. If so, then 11689 -- True is returned, otherwise False. Note that this is not at all the 11690 -- same as checking if the unit requires a body, since it deals with 11691 -- the case of optional bodies accurately (i.e. if a body is optional, 11692 -- then it looks to see if a body is actually present). Note: this 11693 -- function can only do a fully correct job if in generating code mode 11694 -- where all bodies have to be present. If we are operating in semantics 11695 -- check only mode, then in some cases of optional bodies, a result of 11696 -- False may incorrectly be given. In practice this simply means that 11697 -- some cases of warnings for incorrect order of elaboration will only 11698 -- be given when generating code, which is not a big problem (and is 11699 -- inevitable, given the optional body semantics of Ada). 11700 11701 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 11702 -- Given code for an elaboration check (or unconditional raise if the check 11703 -- is not needed), inserts the code in the appropriate place. N is the call 11704 -- or instantiation node for which the check code is required. C is the 11705 -- test whose failure triggers the raise. 11706 11707 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 11708 -- Returns True if node N is a call to a generic formal subprogram 11709 11710 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 11711 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 11712 11713 procedure Output_Calls 11714 (N : Node_Id; 11715 Check_Elab_Flag : Boolean); 11716 -- Outputs chain of calls stored in the Elab_Call table. The caller has 11717 -- already generated the main warning message, so the warnings generated 11718 -- are all continuation messages. The argument is the call node at which 11719 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 11720 -- enumerated only when flag Elab_Warning is set for the dynamic case or 11721 -- when flag Elab_Info_Messages is set for the static case. 11722 11723 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 11724 -- Given two scopes, determine whether they are the same scope from an 11725 -- elaboration point of view, i.e. packages and blocks are ignored. 11726 11727 procedure Set_C_Scope; 11728 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 11729 -- to be the enclosing compilation unit of this scope. 11730 11731 procedure Set_Elaboration_Constraint 11732 (Call : Node_Id; 11733 Subp : Entity_Id; 11734 Scop : Entity_Id); 11735 -- The current unit U may depend semantically on some unit P that is not 11736 -- in the current context. If there is an elaboration call that reaches P, 11737 -- we need to indicate that P requires an Elaborate_All, but this is not 11738 -- effective in U's ali file, if there is no with_clause for P. In this 11739 -- case we add the Elaborate_All on the unit Q that directly or indirectly 11740 -- makes P available. This can happen in two cases: 11741 -- 11742 -- a) Q declares a subtype of a type declared in P, and the call is an 11743 -- initialization call for an object of that subtype. 11744 -- 11745 -- b) Q declares an object of some tagged type whose root type is 11746 -- declared in P, and the initialization call uses object notation on 11747 -- that object to reach a primitive operation or a classwide operation 11748 -- declared in P. 11749 -- 11750 -- If P appears in the context of U, the current processing is correct. 11751 -- Otherwise we must identify these two cases to retrieve Q and place the 11752 -- Elaborate_All_Desirable on it. 11753 11754 function Spec_Entity (E : Entity_Id) return Entity_Id; 11755 -- Given a compilation unit entity, if it is a spec entity, it is returned 11756 -- unchanged. If it is a body entity, then the spec for the corresponding 11757 -- spec is returned 11758 11759 function Within (E1, E2 : Entity_Id) return Boolean; 11760 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 11761 -- of its contained scopes, False otherwise. 11762 11763 function Within_Elaborate_All 11764 (Unit : Unit_Number_Type; 11765 E : Entity_Id) return Boolean; 11766 -- Return True if we are within the scope of an Elaborate_All for E, or if 11767 -- we are within the scope of an Elaborate_All for some other unit U, and U 11768 -- with's E. This prevents spurious warnings when the called entity is 11769 -- renamed within U, or in case of generic instances. 11770 11771 -------------------------------------- 11772 -- Activate_Elaborate_All_Desirable -- 11773 -------------------------------------- 11774 11775 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 11776 UN : constant Unit_Number_Type := Get_Code_Unit (N); 11777 CU : constant Node_Id := Cunit (UN); 11778 UE : constant Entity_Id := Cunit_Entity (UN); 11779 Unm : constant Unit_Name_Type := Unit_Name (UN); 11780 CI : constant List_Id := Context_Items (CU); 11781 Itm : Node_Id; 11782 Ent : Entity_Id; 11783 11784 procedure Add_To_Context_And_Mark (Itm : Node_Id); 11785 -- This procedure is called when the elaborate indication must be 11786 -- applied to a unit not in the context of the referencing unit. The 11787 -- unit gets added to the context as an implicit with. 11788 11789 function In_Withs_Of (UEs : Entity_Id) return Boolean; 11790 -- UEs is the spec entity of a unit. If the unit to be marked is 11791 -- in the context item list of this unit spec, then the call returns 11792 -- True and Itm is left set to point to the relevant N_With_Clause node. 11793 11794 procedure Set_Elab_Flag (Itm : Node_Id); 11795 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 11796 11797 ----------------------------- 11798 -- Add_To_Context_And_Mark -- 11799 ----------------------------- 11800 11801 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 11802 CW : constant Node_Id := 11803 Make_With_Clause (Sloc (Itm), 11804 Name => Name (Itm)); 11805 11806 begin 11807 Set_Library_Unit (CW, Library_Unit (Itm)); 11808 Set_Implicit_With (CW); 11809 11810 -- Set elaborate all desirable on copy and then append the copy to 11811 -- the list of body with's and we are done. 11812 11813 Set_Elab_Flag (CW); 11814 Append_To (CI, CW); 11815 end Add_To_Context_And_Mark; 11816 11817 ----------------- 11818 -- In_Withs_Of -- 11819 ----------------- 11820 11821 function In_Withs_Of (UEs : Entity_Id) return Boolean is 11822 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 11823 CUs : constant Node_Id := Cunit (UNs); 11824 CIs : constant List_Id := Context_Items (CUs); 11825 11826 begin 11827 Itm := First (CIs); 11828 while Present (Itm) loop 11829 if Nkind (Itm) = N_With_Clause then 11830 Ent := 11831 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11832 11833 if U = Ent then 11834 return True; 11835 end if; 11836 end if; 11837 11838 Next (Itm); 11839 end loop; 11840 11841 return False; 11842 end In_Withs_Of; 11843 11844 ------------------- 11845 -- Set_Elab_Flag -- 11846 ------------------- 11847 11848 procedure Set_Elab_Flag (Itm : Node_Id) is 11849 begin 11850 if Nkind (N) in N_Subprogram_Instantiation then 11851 Set_Elaborate_Desirable (Itm); 11852 else 11853 Set_Elaborate_All_Desirable (Itm); 11854 end if; 11855 end Set_Elab_Flag; 11856 11857 -- Start of processing for Activate_Elaborate_All_Desirable 11858 11859 begin 11860 -- Do not set binder indication if expansion is disabled, as when 11861 -- compiling a generic unit. 11862 11863 if not Expander_Active then 11864 return; 11865 end if; 11866 11867 -- If an instance of a generic package contains a controlled object (so 11868 -- we're calling Initialize at elaboration time), and the instance is in 11869 -- a package body P that says "with P;", then we need to return without 11870 -- adding "pragma Elaborate_All (P);" to P. 11871 11872 if U = Main_Unit_Entity then 11873 return; 11874 end if; 11875 11876 Itm := First (CI); 11877 while Present (Itm) loop 11878 if Nkind (Itm) = N_With_Clause then 11879 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11880 11881 -- If we find it, then mark elaborate all desirable and return 11882 11883 if U = Ent then 11884 Set_Elab_Flag (Itm); 11885 return; 11886 end if; 11887 end if; 11888 11889 Next (Itm); 11890 end loop; 11891 11892 -- If we fall through then the with clause is not present in the 11893 -- current unit. One legitimate possibility is that the with clause 11894 -- is present in the spec when we are a body. 11895 11896 if Is_Body_Name (Unm) 11897 and then In_Withs_Of (Spec_Entity (UE)) 11898 then 11899 Add_To_Context_And_Mark (Itm); 11900 return; 11901 end if; 11902 11903 -- Similarly, we may be in the spec or body of a child unit, where 11904 -- the unit in question is with'ed by some ancestor of the child unit. 11905 11906 if Is_Child_Name (Unm) then 11907 declare 11908 Pkg : Entity_Id; 11909 11910 begin 11911 Pkg := UE; 11912 loop 11913 Pkg := Scope (Pkg); 11914 exit when Pkg = Standard_Standard; 11915 11916 if In_Withs_Of (Pkg) then 11917 Add_To_Context_And_Mark (Itm); 11918 return; 11919 end if; 11920 end loop; 11921 end; 11922 end if; 11923 11924 -- Here if we do not find with clause on spec or body. We just ignore 11925 -- this case; it means that the elaboration involves some other unit 11926 -- than the unit being compiled, and will be caught elsewhere. 11927 end Activate_Elaborate_All_Desirable; 11928 11929 ------------------ 11930 -- Check_A_Call -- 11931 ------------------ 11932 11933 procedure Check_A_Call 11934 (N : Node_Id; 11935 E : Entity_Id; 11936 Outer_Scope : Entity_Id; 11937 Inter_Unit_Only : Boolean; 11938 Generate_Warnings : Boolean := True; 11939 In_Init_Proc : Boolean := False) 11940 is 11941 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 11942 -- Indicates if we have Access attribute case 11943 11944 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 11945 -- True if we're calling an instance of a generic subprogram, or a 11946 -- subprogram in an instance of a generic package, and the call is 11947 -- outside that instance. 11948 11949 procedure Elab_Warning 11950 (Msg_D : String; 11951 Msg_S : String; 11952 Ent : Node_Or_Entity_Id); 11953 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 11954 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 11955 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 11956 -- Msg_S is an info message (output if Elab_Info_Messages is set). 11957 11958 function Find_W_Scope return Entity_Id; 11959 -- Find top-level scope for called entity (not following renamings 11960 -- or derivations). This is where the Elaborate_All will go if it is 11961 -- needed. We start with the called entity, except in the case of an 11962 -- initialization procedure outside the current package, where the init 11963 -- proc is in the root package, and we start from the entity of the name 11964 -- in the call. 11965 11966 ----------------------------------- 11967 -- Call_To_Instance_From_Outside -- 11968 ----------------------------------- 11969 11970 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 11971 Scop : Entity_Id := Id; 11972 11973 begin 11974 loop 11975 if Scop = Standard_Standard then 11976 return False; 11977 end if; 11978 11979 if Is_Generic_Instance (Scop) then 11980 return not In_Open_Scopes (Scop); 11981 end if; 11982 11983 Scop := Scope (Scop); 11984 end loop; 11985 end Call_To_Instance_From_Outside; 11986 11987 ------------------ 11988 -- Elab_Warning -- 11989 ------------------ 11990 11991 procedure Elab_Warning 11992 (Msg_D : String; 11993 Msg_S : String; 11994 Ent : Node_Or_Entity_Id) 11995 is 11996 begin 11997 -- Dynamic elaboration checks, real warning 11998 11999 if Dynamic_Elaboration_Checks then 12000 if not Access_Case then 12001 if Msg_D /= "" and then Elab_Warnings then 12002 Error_Msg_NE (Msg_D, N, Ent); 12003 end if; 12004 12005 -- In the access case emit first warning message as well, 12006 -- otherwise list of calls will appear as errors. 12007 12008 elsif Elab_Warnings then 12009 Error_Msg_NE (Msg_S, N, Ent); 12010 end if; 12011 12012 -- Static elaboration checks, info message 12013 12014 else 12015 if Elab_Info_Messages then 12016 Error_Msg_NE (Msg_S, N, Ent); 12017 end if; 12018 end if; 12019 end Elab_Warning; 12020 12021 ------------------ 12022 -- Find_W_Scope -- 12023 ------------------ 12024 12025 function Find_W_Scope return Entity_Id is 12026 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 12027 W_Scope : Entity_Id; 12028 12029 begin 12030 if Is_Init_Proc (Refed_Ent) 12031 and then not In_Same_Extended_Unit (N, Refed_Ent) 12032 then 12033 W_Scope := Scope (Refed_Ent); 12034 else 12035 W_Scope := E; 12036 end if; 12037 12038 -- Now loop through scopes to get to the enclosing compilation unit 12039 12040 while not Is_Compilation_Unit (W_Scope) loop 12041 W_Scope := Scope (W_Scope); 12042 end loop; 12043 12044 return W_Scope; 12045 end Find_W_Scope; 12046 12047 -- Local variables 12048 12049 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 12050 -- Indicates if we have instantiation case 12051 12052 Loc : constant Source_Ptr := Sloc (N); 12053 12054 Variable_Case : constant Boolean := 12055 Nkind (N) in N_Has_Entity 12056 and then Present (Entity (N)) 12057 and then Ekind (Entity (N)) = E_Variable; 12058 -- Indicates if we have variable reference case 12059 12060 W_Scope : constant Entity_Id := Find_W_Scope; 12061 -- Top-level scope of directly called entity for subprogram. This 12062 -- differs from E_Scope in the case where renamings or derivations 12063 -- are involved, since it does not follow these links. W_Scope is 12064 -- generally in a visible unit, and it is this scope that may require 12065 -- an Elaborate_All. However, there are some cases (initialization 12066 -- calls and calls involving object notation) where W_Scope might not 12067 -- be in the context of the current unit, and there is an intermediate 12068 -- package that is, in which case the Elaborate_All has to be placed 12069 -- on this intermediate package. These special cases are handled in 12070 -- Set_Elaboration_Constraint. 12071 12072 Ent : Entity_Id; 12073 Callee_Unit_Internal : Boolean; 12074 Caller_Unit_Internal : Boolean; 12075 Decl : Node_Id; 12076 Inst_Callee : Source_Ptr; 12077 Inst_Caller : Source_Ptr; 12078 Unit_Callee : Unit_Number_Type; 12079 Unit_Caller : Unit_Number_Type; 12080 12081 Body_Acts_As_Spec : Boolean; 12082 -- Set to true if call is to body acting as spec (no separate spec) 12083 12084 Cunit_SC : Boolean := False; 12085 -- Set to suppress dynamic elaboration checks where one of the 12086 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 12087 -- if a pragma Elaborate[_All] applies to that scope, in which case 12088 -- warnings on the scope are also suppressed. For the internal case, 12089 -- we ignore this flag. 12090 12091 E_Scope : Entity_Id; 12092 -- Top-level scope of entity for called subprogram. This value includes 12093 -- following renamings and derivations, so this scope can be in a 12094 -- non-visible unit. This is the scope that is to be investigated to 12095 -- see whether an elaboration check is required. 12096 12097 Is_DIC : Boolean; 12098 -- Flag set when the subprogram being invoked is the procedure generated 12099 -- for pragma Default_Initial_Condition. 12100 12101 SPARK_Elab_Errors : Boolean; 12102 -- Flag set when an entity is called or a variable is read during SPARK 12103 -- dynamic elaboration. 12104 12105 -- Start of processing for Check_A_Call 12106 12107 begin 12108 -- If the call is known to be within a local Suppress Elaboration 12109 -- pragma, nothing to check. This can happen in task bodies. But 12110 -- we ignore this for a call to a generic formal. 12111 12112 if Nkind (N) in N_Subprogram_Call 12113 and then No_Elaboration_Check (N) 12114 and then not Is_Call_Of_Generic_Formal (N) 12115 then 12116 return; 12117 12118 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 12119 -- check, we don't mind in this case if the call occurs before the body 12120 -- since this is all generated code. 12121 12122 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 12123 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 12124 then 12125 return; 12126 12127 -- Intrinsics such as instances of Unchecked_Deallocation do not have 12128 -- any body, so elaboration checking is not needed, and would be wrong. 12129 12130 elsif Is_Intrinsic_Subprogram (E) then 12131 return; 12132 12133 -- Do not consider references to internal variables for SPARK semantics 12134 12135 elsif Variable_Case and then not Comes_From_Source (E) then 12136 return; 12137 end if; 12138 12139 -- Proceed with check 12140 12141 Ent := E; 12142 12143 -- For a variable reference, just set Body_Acts_As_Spec to False 12144 12145 if Variable_Case then 12146 Body_Acts_As_Spec := False; 12147 12148 -- Additional checks for all other cases 12149 12150 else 12151 -- Go to parent for derived subprogram, or to original subprogram in 12152 -- the case of a renaming (Alias covers both these cases). 12153 12154 loop 12155 if (Suppress_Elaboration_Warnings (Ent) 12156 or else Elaboration_Checks_Suppressed (Ent)) 12157 and then (Inst_Case or else No (Alias (Ent))) 12158 then 12159 return; 12160 end if; 12161 12162 -- Nothing to do for imported entities 12163 12164 if Is_Imported (Ent) then 12165 return; 12166 end if; 12167 12168 exit when Inst_Case or else No (Alias (Ent)); 12169 Ent := Alias (Ent); 12170 end loop; 12171 12172 Decl := Unit_Declaration_Node (Ent); 12173 12174 if Nkind (Decl) = N_Subprogram_Body then 12175 Body_Acts_As_Spec := True; 12176 12177 elsif Nkind_In (Decl, N_Subprogram_Declaration, 12178 N_Subprogram_Body_Stub) 12179 or else Inst_Case 12180 then 12181 Body_Acts_As_Spec := False; 12182 12183 -- If we have none of an instantiation, subprogram body or subprogram 12184 -- declaration, or in the SPARK case, a variable reference, then 12185 -- it is not a case that we want to check. (One case is a call to a 12186 -- generic formal subprogram, where we do not want the check in the 12187 -- template). 12188 12189 else 12190 return; 12191 end if; 12192 end if; 12193 12194 E_Scope := Ent; 12195 loop 12196 if Elaboration_Checks_Suppressed (E_Scope) 12197 or else Suppress_Elaboration_Warnings (E_Scope) 12198 then 12199 Cunit_SC := True; 12200 end if; 12201 12202 -- Exit when we get to compilation unit, not counting subunits 12203 12204 exit when Is_Compilation_Unit (E_Scope) 12205 and then (Is_Child_Unit (E_Scope) 12206 or else Scope (E_Scope) = Standard_Standard); 12207 12208 pragma Assert (E_Scope /= Standard_Standard); 12209 12210 -- Move up a scope looking for compilation unit 12211 12212 E_Scope := Scope (E_Scope); 12213 end loop; 12214 12215 -- No checks needed for pure or preelaborated compilation units 12216 12217 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 12218 return; 12219 end if; 12220 12221 -- If the generic entity is within a deeper instance than we are, then 12222 -- either the instantiation to which we refer itself caused an ABE, in 12223 -- which case that will be handled separately, or else we know that the 12224 -- body we need appears as needed at the point of the instantiation. 12225 -- However, this assumption is only valid if we are in static mode. 12226 12227 if not Dynamic_Elaboration_Checks 12228 and then 12229 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 12230 then 12231 return; 12232 end if; 12233 12234 -- Do not give a warning for a package with no body 12235 12236 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 12237 return; 12238 end if; 12239 12240 -- Case of entity is in same unit as call or instantiation. In the 12241 -- instantiation case, W_Scope may be different from E_Scope; we want 12242 -- the unit in which the instantiation occurs, since we're analyzing 12243 -- based on the expansion. 12244 12245 if W_Scope = C_Scope then 12246 if not Inter_Unit_Only then 12247 Check_Internal_Call (N, Ent, Outer_Scope, E); 12248 end if; 12249 12250 return; 12251 end if; 12252 12253 -- Case of entity is not in current unit (i.e. with'ed unit case) 12254 12255 -- We are only interested in such calls if the outer call was from 12256 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 12257 12258 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 12259 return; 12260 end if; 12261 12262 -- Nothing to do if some scope said that no checks were required 12263 12264 if Cunit_SC then 12265 return; 12266 end if; 12267 12268 -- Nothing to do for a generic instance, because a call to an instance 12269 -- cannot fail the elaboration check, because the body of the instance 12270 -- is always elaborated immediately after the spec. 12271 12272 if Call_To_Instance_From_Outside (Ent) then 12273 return; 12274 end if; 12275 12276 -- Nothing to do if subprogram with no separate spec. However, a call 12277 -- to Deep_Initialize may result in a call to a user-defined Initialize 12278 -- procedure, which imposes a body dependency. This happens only if the 12279 -- type is controlled and the Initialize procedure is not inherited. 12280 12281 if Body_Acts_As_Spec then 12282 if Is_TSS (Ent, TSS_Deep_Initialize) then 12283 declare 12284 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 12285 Init : Entity_Id; 12286 12287 begin 12288 if not Is_Controlled (Typ) then 12289 return; 12290 else 12291 Init := Find_Prim_Op (Typ, Name_Initialize); 12292 12293 if Comes_From_Source (Init) then 12294 Ent := Init; 12295 else 12296 return; 12297 end if; 12298 end if; 12299 end; 12300 12301 else 12302 return; 12303 end if; 12304 end if; 12305 12306 -- Check cases of internal units 12307 12308 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 12309 12310 -- Do not give a warning if the with'ed unit is internal and this is 12311 -- the generic instantiation case (this saves a lot of hassle dealing 12312 -- with the Text_IO special child units) 12313 12314 if Callee_Unit_Internal and Inst_Case then 12315 return; 12316 end if; 12317 12318 if C_Scope = Standard_Standard then 12319 Caller_Unit_Internal := False; 12320 else 12321 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 12322 end if; 12323 12324 -- Do not give a warning if the with'ed unit is internal and the caller 12325 -- is not internal (since the binder always elaborates internal units 12326 -- first). 12327 12328 if Callee_Unit_Internal and not Caller_Unit_Internal then 12329 return; 12330 end if; 12331 12332 -- For now, if debug flag -gnatdE is not set, do no checking for one 12333 -- internal unit withing another. This fixes the problem with the sgi 12334 -- build and storage errors. To be resolved later ??? 12335 12336 if (Callee_Unit_Internal and Caller_Unit_Internal) 12337 and not Debug_Flag_EE 12338 then 12339 return; 12340 end if; 12341 12342 if Is_TSS (E, TSS_Deep_Initialize) then 12343 Ent := E; 12344 end if; 12345 12346 -- If the call is in an instance, and the called entity is not 12347 -- defined in the same instance, then the elaboration issue focuses 12348 -- around the unit containing the template, it is this unit that 12349 -- requires an Elaborate_All. 12350 12351 -- However, if we are doing dynamic elaboration, we need to chase the 12352 -- call in the usual manner. 12353 12354 -- We also need to chase the call in the usual manner if it is a call 12355 -- to a generic formal parameter, since that case was not handled as 12356 -- part of the processing of the template. 12357 12358 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 12359 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 12360 12361 if Inst_Caller = No_Location then 12362 Unit_Caller := No_Unit; 12363 else 12364 Unit_Caller := Get_Source_Unit (N); 12365 end if; 12366 12367 if Inst_Callee = No_Location then 12368 Unit_Callee := No_Unit; 12369 else 12370 Unit_Callee := Get_Source_Unit (Ent); 12371 end if; 12372 12373 if Unit_Caller /= No_Unit 12374 and then Unit_Callee /= Unit_Caller 12375 and then not Dynamic_Elaboration_Checks 12376 and then not Is_Call_Of_Generic_Formal (N) 12377 then 12378 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 12379 12380 -- If we don't get a spec entity, just ignore call. Not quite 12381 -- clear why this check is necessary. ??? 12382 12383 if No (E_Scope) then 12384 return; 12385 end if; 12386 12387 -- Otherwise step to enclosing compilation unit 12388 12389 while not Is_Compilation_Unit (E_Scope) loop 12390 E_Scope := Scope (E_Scope); 12391 end loop; 12392 12393 -- For the case where N is not an instance, and is not a call within 12394 -- instance to other than a generic formal, we recompute E_Scope 12395 -- for the error message, since we do NOT want to go to the unit 12396 -- that has the ultimate declaration in the case of renaming and 12397 -- derivation and we also want to go to the generic unit in the 12398 -- case of an instance, and no further. 12399 12400 else 12401 -- Loop to carefully follow renamings and derivations one step 12402 -- outside the current unit, but not further. 12403 12404 if not (Inst_Case or Variable_Case) 12405 and then Present (Alias (Ent)) 12406 then 12407 E_Scope := Alias (Ent); 12408 else 12409 E_Scope := Ent; 12410 end if; 12411 12412 loop 12413 while not Is_Compilation_Unit (E_Scope) loop 12414 E_Scope := Scope (E_Scope); 12415 end loop; 12416 12417 -- If E_Scope is the same as C_Scope, it means that there 12418 -- definitely was a local renaming or derivation, and we 12419 -- are not yet out of the current unit. 12420 12421 exit when E_Scope /= C_Scope; 12422 Ent := Alias (Ent); 12423 E_Scope := Ent; 12424 12425 -- If no alias, there could be a previous error, but not if we've 12426 -- already reached the outermost level (Standard). 12427 12428 if No (Ent) then 12429 return; 12430 end if; 12431 end loop; 12432 end if; 12433 12434 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 12435 return; 12436 end if; 12437 12438 -- Determine whether the Default_Initial_Condition procedure of some 12439 -- type is being invoked. 12440 12441 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 12442 12443 -- Checks related to Default_Initial_Condition fall under the SPARK 12444 -- umbrella because this is a SPARK-specific annotation. 12445 12446 SPARK_Elab_Errors := 12447 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 12448 12449 -- Now check if an Elaborate_All (or dynamic check) is needed 12450 12451 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 12452 and then Generate_Warnings 12453 and then not Suppress_Elaboration_Warnings (Ent) 12454 and then not Elaboration_Checks_Suppressed (Ent) 12455 and then not Suppress_Elaboration_Warnings (E_Scope) 12456 and then not Elaboration_Checks_Suppressed (E_Scope) 12457 then 12458 -- Instantiation case 12459 12460 if Inst_Case then 12461 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12462 Error_Msg_NE 12463 ("instantiation of & during elaboration in SPARK", N, Ent); 12464 else 12465 Elab_Warning 12466 ("instantiation of & may raise Program_Error?l?", 12467 "info: instantiation of & during elaboration?$?", Ent); 12468 end if; 12469 12470 -- Indirect call case, info message only in static elaboration 12471 -- case, because the attribute reference itself cannot raise an 12472 -- exception. Note that SPARK does not permit indirect calls. 12473 12474 elsif Access_Case then 12475 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 12476 12477 -- Variable reference in SPARK mode 12478 12479 elsif Variable_Case then 12480 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12481 Error_Msg_NE 12482 ("reference to & during elaboration in SPARK", N, Ent); 12483 end if; 12484 12485 -- Subprogram call case 12486 12487 else 12488 if Nkind (Name (N)) in N_Has_Entity 12489 and then Is_Init_Proc (Entity (Name (N))) 12490 and then Comes_From_Source (Ent) 12491 then 12492 Elab_Warning 12493 ("implicit call to & may raise Program_Error?l?", 12494 "info: implicit call to & during elaboration?$?", 12495 Ent); 12496 12497 elsif SPARK_Elab_Errors then 12498 12499 -- Emit a specialized error message when the elaboration of an 12500 -- object of a private type evaluates the expression of pragma 12501 -- Default_Initial_Condition. This prevents the internal name 12502 -- of the procedure from appearing in the error message. 12503 12504 if Is_DIC then 12505 Error_Msg_N 12506 ("call to Default_Initial_Condition during elaboration in " 12507 & "SPARK", N); 12508 else 12509 Error_Msg_NE 12510 ("call to & during elaboration in SPARK", N, Ent); 12511 end if; 12512 12513 else 12514 Elab_Warning 12515 ("call to & may raise Program_Error?l?", 12516 "info: call to & during elaboration?$?", 12517 Ent); 12518 end if; 12519 end if; 12520 12521 Error_Msg_Qual_Level := Nat'Last; 12522 12523 -- Case of Elaborate_All not present and required, for SPARK this 12524 -- is an error, so give an error message. 12525 12526 if SPARK_Elab_Errors then 12527 Error_Msg_NE -- CODEFIX 12528 ("\Elaborate_All pragma required for&", N, W_Scope); 12529 12530 -- Otherwise we generate an implicit pragma. For a subprogram 12531 -- instantiation, Elaborate is good enough, since no transitive 12532 -- call is possible at elaboration time in this case. 12533 12534 elsif Nkind (N) in N_Subprogram_Instantiation then 12535 Elab_Warning 12536 ("\missing pragma Elaborate for&?l?", 12537 "\implicit pragma Elaborate for& generated?$?", 12538 W_Scope); 12539 12540 -- For all other cases, we need an implicit Elaborate_All 12541 12542 else 12543 Elab_Warning 12544 ("\missing pragma Elaborate_All for&?l?", 12545 "\implicit pragma Elaborate_All for & generated?$?", 12546 W_Scope); 12547 end if; 12548 12549 Error_Msg_Qual_Level := 0; 12550 12551 -- Take into account the flags related to elaboration warning 12552 -- messages when enumerating the various calls involved. This 12553 -- ensures the proper pairing of the main warning and the 12554 -- clarification messages generated by Output_Calls. 12555 12556 Output_Calls (N, Check_Elab_Flag => True); 12557 12558 -- Set flag to prevent further warnings for same unit unless in 12559 -- All_Errors_Mode. 12560 12561 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 12562 Set_Suppress_Elaboration_Warnings (W_Scope); 12563 end if; 12564 end if; 12565 12566 -- Check for runtime elaboration check required 12567 12568 if Dynamic_Elaboration_Checks then 12569 if not Elaboration_Checks_Suppressed (Ent) 12570 and then not Elaboration_Checks_Suppressed (W_Scope) 12571 and then not Elaboration_Checks_Suppressed (E_Scope) 12572 and then not Cunit_SC 12573 then 12574 -- Runtime elaboration check required. Generate check of the 12575 -- elaboration Boolean for the unit containing the entity. 12576 12577 -- Note that for this case, we do check the real unit (the one 12578 -- from following renamings, since that is the issue). 12579 12580 -- Could this possibly miss a useless but required PE??? 12581 12582 Insert_Elab_Check (N, 12583 Make_Attribute_Reference (Loc, 12584 Attribute_Name => Name_Elaborated, 12585 Prefix => 12586 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 12587 12588 -- Prevent duplicate elaboration checks on the same call, which 12589 -- can happen if the body enclosing the call appears itself in a 12590 -- call whose elaboration check is delayed. 12591 12592 if Nkind (N) in N_Subprogram_Call then 12593 Set_No_Elaboration_Check (N); 12594 end if; 12595 end if; 12596 12597 -- Case of static elaboration model 12598 12599 else 12600 -- Do not do anything if elaboration checks suppressed. Note that 12601 -- we check Ent here, not E, since we want the real entity for the 12602 -- body to see if checks are suppressed for it, not the dummy 12603 -- entry for renamings or derivations. 12604 12605 if Elaboration_Checks_Suppressed (Ent) 12606 or else Elaboration_Checks_Suppressed (E_Scope) 12607 or else Elaboration_Checks_Suppressed (W_Scope) 12608 then 12609 null; 12610 12611 -- Do not generate an Elaborate_All for finalization routines 12612 -- that perform partial clean up as part of initialization. 12613 12614 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 12615 null; 12616 12617 -- Here we need to generate an implicit elaborate all 12618 12619 else 12620 -- Generate Elaborate_All warning unless suppressed 12621 12622 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 12623 and then not Suppress_Elaboration_Warnings (Ent) 12624 and then not Suppress_Elaboration_Warnings (E_Scope) 12625 and then not Suppress_Elaboration_Warnings (W_Scope) 12626 then 12627 Error_Msg_Node_2 := W_Scope; 12628 Error_Msg_NE 12629 ("info: call to& in elaboration code requires pragma " 12630 & "Elaborate_All on&?$?", N, E); 12631 end if; 12632 12633 -- Set indication for binder to generate Elaborate_All 12634 12635 Set_Elaboration_Constraint (N, E, W_Scope); 12636 end if; 12637 end if; 12638 end Check_A_Call; 12639 12640 ----------------------------- 12641 -- Check_Bad_Instantiation -- 12642 ----------------------------- 12643 12644 procedure Check_Bad_Instantiation (N : Node_Id) is 12645 Ent : Entity_Id; 12646 12647 begin 12648 -- Nothing to do if we do not have an instantiation (happens in some 12649 -- error cases, and also in the formal package declaration case) 12650 12651 if Nkind (N) not in N_Generic_Instantiation then 12652 return; 12653 12654 -- Nothing to do if serious errors detected (avoid cascaded errors) 12655 12656 elsif Serious_Errors_Detected /= 0 then 12657 return; 12658 12659 -- Nothing to do if not in full analysis mode 12660 12661 elsif not Full_Analysis then 12662 return; 12663 12664 -- Nothing to do if inside a generic template 12665 12666 elsif Inside_A_Generic then 12667 return; 12668 12669 -- Nothing to do if a library level instantiation 12670 12671 elsif Nkind (Parent (N)) = N_Compilation_Unit then 12672 return; 12673 12674 -- Nothing to do if we are compiling a proper body for semantic 12675 -- purposes only. The generic body may be in another proper body. 12676 12677 elsif 12678 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 12679 then 12680 return; 12681 end if; 12682 12683 Ent := Get_Generic_Entity (N); 12684 12685 -- The case we are interested in is when the generic spec is in the 12686 -- current declarative part 12687 12688 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 12689 or else not In_Same_Extended_Unit (N, Ent) 12690 then 12691 return; 12692 end if; 12693 12694 -- If the generic entity is within a deeper instance than we are, then 12695 -- either the instantiation to which we refer itself caused an ABE, in 12696 -- which case that will be handled separately. Otherwise, we know that 12697 -- the body we need appears as needed at the point of the instantiation. 12698 -- If they are both at the same level but not within the same instance 12699 -- then the body of the generic will be in the earlier instance. 12700 12701 declare 12702 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 12703 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 12704 12705 begin 12706 if D1 > D2 then 12707 return; 12708 12709 elsif D1 = D2 12710 and then Is_Generic_Instance (Scope (Ent)) 12711 and then not In_Open_Scopes (Scope (Ent)) 12712 then 12713 return; 12714 end if; 12715 end; 12716 12717 -- Now we can proceed, if the entity being called has a completion, 12718 -- then we are definitely OK, since we have already seen the body. 12719 12720 if Has_Completion (Ent) then 12721 return; 12722 end if; 12723 12724 -- If there is no body, then nothing to do 12725 12726 if not Has_Generic_Body (N) then 12727 return; 12728 end if; 12729 12730 -- Here we definitely have a bad instantiation 12731 12732 Error_Msg_Warn := SPARK_Mode /= On; 12733 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 12734 Error_Msg_N ("\Program_Error [<<", N); 12735 12736 Insert_Elab_Check (N); 12737 Set_Is_Known_Guaranteed_ABE (N); 12738 end Check_Bad_Instantiation; 12739 12740 --------------------- 12741 -- Check_Elab_Call -- 12742 --------------------- 12743 12744 procedure Check_Elab_Call 12745 (N : Node_Id; 12746 Outer_Scope : Entity_Id := Empty; 12747 In_Init_Proc : Boolean := False) 12748 is 12749 Ent : Entity_Id; 12750 P : Node_Id; 12751 12752 begin 12753 pragma Assert (Legacy_Elaboration_Checks); 12754 12755 -- If the reference is not in the main unit, there is nothing to check. 12756 -- Elaboration call from units in the context of the main unit will lead 12757 -- to semantic dependencies when those units are compiled. 12758 12759 if not In_Extended_Main_Code_Unit (N) then 12760 return; 12761 end if; 12762 12763 -- For an entry call, check relevant restriction 12764 12765 if Nkind (N) = N_Entry_Call_Statement 12766 and then not In_Subprogram_Or_Concurrent_Unit 12767 then 12768 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 12769 12770 -- Nothing to do if this is not an expected type of reference (happens 12771 -- in some error conditions, and in some cases where rewriting occurs). 12772 12773 elsif Nkind (N) not in N_Subprogram_Call 12774 and then Nkind (N) /= N_Attribute_Reference 12775 and then (SPARK_Mode /= On 12776 or else Nkind (N) not in N_Has_Entity 12777 or else No (Entity (N)) 12778 or else Ekind (Entity (N)) /= E_Variable) 12779 then 12780 return; 12781 12782 -- Nothing to do if this is a call already rewritten for elab checking. 12783 -- Such calls appear as the targets of If_Expressions. 12784 12785 -- This check MUST be wrong, it catches far too much 12786 12787 elsif Nkind (Parent (N)) = N_If_Expression then 12788 return; 12789 12790 -- Nothing to do if inside a generic template 12791 12792 elsif Inside_A_Generic 12793 and then No (Enclosing_Generic_Body (N)) 12794 then 12795 return; 12796 12797 -- Nothing to do if call is being preanalyzed, as when within a 12798 -- pre/postcondition, a predicate, or an invariant. 12799 12800 elsif In_Spec_Expression then 12801 return; 12802 end if; 12803 12804 -- Nothing to do if this is a call to a postcondition, which is always 12805 -- within a subprogram body, even though the current scope may be the 12806 -- enclosing scope of the subprogram. 12807 12808 if Nkind (N) = N_Procedure_Call_Statement 12809 and then Is_Entity_Name (Name (N)) 12810 and then Chars (Entity (Name (N))) = Name_uPostconditions 12811 then 12812 return; 12813 end if; 12814 12815 -- Here we have a reference at elaboration time that must be checked 12816 12817 if Debug_Flag_Underscore_LL then 12818 Write_Str (" Check_Elab_Ref: "); 12819 12820 if Nkind (N) = N_Attribute_Reference then 12821 if not Is_Entity_Name (Prefix (N)) then 12822 Write_Str ("<<not entity name>>"); 12823 else 12824 Write_Name (Chars (Entity (Prefix (N)))); 12825 end if; 12826 12827 Write_Str ("'Access"); 12828 12829 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 12830 Write_Str ("<<not entity name>> "); 12831 12832 else 12833 Write_Name (Chars (Entity (Name (N)))); 12834 end if; 12835 12836 Write_Str (" reference at "); 12837 Write_Location (Sloc (N)); 12838 Write_Eol; 12839 end if; 12840 12841 -- Climb up the tree to make sure we are not inside default expression 12842 -- of a parameter specification or a record component, since in both 12843 -- these cases, we will be doing the actual reference later, not now, 12844 -- and it is at the time of the actual reference (statically speaking) 12845 -- that we must do our static check, not at the time of its initial 12846 -- analysis). 12847 12848 -- However, we have to check references within component definitions 12849 -- (e.g. a function call that determines an array component bound), 12850 -- so we terminate the loop in that case. 12851 12852 P := Parent (N); 12853 while Present (P) loop 12854 if Nkind_In (P, N_Parameter_Specification, 12855 N_Component_Declaration) 12856 then 12857 return; 12858 12859 -- The reference occurs within the constraint of a component, 12860 -- so it must be checked. 12861 12862 elsif Nkind (P) = N_Component_Definition then 12863 exit; 12864 12865 else 12866 P := Parent (P); 12867 end if; 12868 end loop; 12869 12870 -- Stuff that happens only at the outer level 12871 12872 if No (Outer_Scope) then 12873 Elab_Visited.Set_Last (0); 12874 12875 -- Nothing to do if current scope is Standard (this is a bit odd, but 12876 -- it happens in the case of generic instantiations). 12877 12878 C_Scope := Current_Scope; 12879 12880 if C_Scope = Standard_Standard then 12881 return; 12882 end if; 12883 12884 -- First case, we are in elaboration code 12885 12886 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 12887 12888 if From_Elab_Code then 12889 12890 -- Complain if ref that comes from source in preelaborated unit 12891 -- and we are not inside a subprogram (i.e. we are in elab code). 12892 12893 if Comes_From_Source (N) 12894 and then In_Preelaborated_Unit 12895 and then not In_Inlined_Body 12896 and then Nkind (N) /= N_Attribute_Reference 12897 then 12898 -- This is a warning in GNAT mode allowing such calls to be 12899 -- used in the predefined library with appropriate care. 12900 12901 Error_Msg_Warn := GNAT_Mode; 12902 Error_Msg_N 12903 ("<<non-static call not allowed in preelaborated unit", N); 12904 return; 12905 end if; 12906 12907 -- Second case, we are inside a subprogram or concurrent unit, which 12908 -- means we are not in elaboration code. 12909 12910 else 12911 -- In this case, the issue is whether we are inside the 12912 -- declarative part of the unit in which we live, or inside its 12913 -- statements. In the latter case, there is no issue of ABE calls 12914 -- at this level (a call from outside to the unit in which we live 12915 -- might cause an ABE, but that will be detected when we analyze 12916 -- that outer level call, as it recurses into the called unit). 12917 12918 -- Climb up the tree, doing this test, and also testing for being 12919 -- inside a default expression, which, as discussed above, is not 12920 -- checked at this stage. 12921 12922 declare 12923 P : Node_Id; 12924 L : List_Id; 12925 12926 begin 12927 P := N; 12928 loop 12929 -- If we find a parentless subtree, it seems safe to assume 12930 -- that we are not in a declarative part and that no 12931 -- checking is required. 12932 12933 if No (P) then 12934 return; 12935 end if; 12936 12937 if Is_List_Member (P) then 12938 L := List_Containing (P); 12939 P := Parent (L); 12940 else 12941 L := No_List; 12942 P := Parent (P); 12943 end if; 12944 12945 exit when Nkind (P) = N_Subunit; 12946 12947 -- Filter out case of default expressions, where we do not 12948 -- do the check at this stage. 12949 12950 if Nkind_In (P, N_Parameter_Specification, 12951 N_Component_Declaration) 12952 then 12953 return; 12954 end if; 12955 12956 -- A protected body has no elaboration code and contains 12957 -- only other bodies. 12958 12959 if Nkind (P) = N_Protected_Body then 12960 return; 12961 12962 elsif Nkind_In (P, N_Subprogram_Body, 12963 N_Task_Body, 12964 N_Block_Statement, 12965 N_Entry_Body) 12966 then 12967 if L = Declarations (P) then 12968 exit; 12969 12970 -- We are not in elaboration code, but we are doing 12971 -- dynamic elaboration checks, in this case, we still 12972 -- need to do the reference, since the subprogram we are 12973 -- in could be called from another unit, also in dynamic 12974 -- elaboration check mode, at elaboration time. 12975 12976 elsif Dynamic_Elaboration_Checks then 12977 12978 -- We provide a debug flag to disable this check. That 12979 -- way we have an easy work around for regressions 12980 -- that are caused by this new check. This debug flag 12981 -- can be removed later. 12982 12983 if Debug_Flag_DD then 12984 return; 12985 end if; 12986 12987 -- Do the check in this case 12988 12989 exit; 12990 12991 elsif Nkind (P) = N_Task_Body then 12992 12993 -- The check is deferred until Check_Task_Activation 12994 -- but we need to capture local suppress pragmas 12995 -- that may inhibit checks on this call. 12996 12997 Ent := Get_Referenced_Ent (N); 12998 12999 if No (Ent) then 13000 return; 13001 13002 elsif Elaboration_Checks_Suppressed (Current_Scope) 13003 or else Elaboration_Checks_Suppressed (Ent) 13004 or else Elaboration_Checks_Suppressed (Scope (Ent)) 13005 then 13006 if Nkind (N) in N_Subprogram_Call then 13007 Set_No_Elaboration_Check (N); 13008 end if; 13009 end if; 13010 13011 return; 13012 13013 -- Static model, call is not in elaboration code, we 13014 -- never need to worry, because in the static model the 13015 -- top-level caller always takes care of things. 13016 13017 else 13018 return; 13019 end if; 13020 end if; 13021 end loop; 13022 end; 13023 end if; 13024 end if; 13025 13026 Ent := Get_Referenced_Ent (N); 13027 13028 if No (Ent) then 13029 return; 13030 end if; 13031 13032 -- Determine whether a prior call to the same subprogram was already 13033 -- examined within the same context. If this is the case, then there is 13034 -- no need to proceed with the various warnings and checks because the 13035 -- work was already done for the previous call. 13036 13037 declare 13038 Self : constant Visited_Element := 13039 (Subp_Id => Ent, Context => Parent (N)); 13040 13041 begin 13042 for Index in 1 .. Elab_Visited.Last loop 13043 if Self = Elab_Visited.Table (Index) then 13044 return; 13045 end if; 13046 end loop; 13047 end; 13048 13049 -- See if we need to analyze this reference. We analyze it if either of 13050 -- the following conditions is met: 13051 13052 -- It is an inner level call (since in this case it was triggered 13053 -- by an outer level call from elaboration code), but only if the 13054 -- call is within the scope of the original outer level call. 13055 13056 -- It is an outer level reference from elaboration code, or a call to 13057 -- an entity is in the same elaboration scope. 13058 13059 -- And in these cases, we will check both inter-unit calls and 13060 -- intra-unit (within a single unit) calls. 13061 13062 C_Scope := Current_Scope; 13063 13064 -- If not outer level reference, then we follow it if it is within the 13065 -- original scope of the outer reference. 13066 13067 if Present (Outer_Scope) 13068 and then Within (Scope (Ent), Outer_Scope) 13069 then 13070 Set_C_Scope; 13071 Check_A_Call 13072 (N => N, 13073 E => Ent, 13074 Outer_Scope => Outer_Scope, 13075 Inter_Unit_Only => False, 13076 In_Init_Proc => In_Init_Proc); 13077 13078 -- Nothing to do if elaboration checks suppressed for this scope. 13079 -- However, an interesting exception, the fact that elaboration checks 13080 -- are suppressed within an instance (because we can trace the body when 13081 -- we process the template) does not extend to calls to generic formal 13082 -- subprograms. 13083 13084 elsif Elaboration_Checks_Suppressed (Current_Scope) 13085 and then not Is_Call_Of_Generic_Formal (N) 13086 then 13087 null; 13088 13089 elsif From_Elab_Code then 13090 Set_C_Scope; 13091 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13092 13093 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13094 Set_C_Scope; 13095 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13096 13097 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 13098 -- is set, then we will do the check, but only in the inter-unit case 13099 -- (this is to accommodate unguarded elaboration calls from other units 13100 -- in which this same mode is set). We don't want warnings in this case, 13101 -- it would generate warnings having nothing to do with elaboration. 13102 13103 elsif Dynamic_Elaboration_Checks then 13104 Set_C_Scope; 13105 Check_A_Call 13106 (N, 13107 Ent, 13108 Standard_Standard, 13109 Inter_Unit_Only => True, 13110 Generate_Warnings => False); 13111 13112 -- Otherwise nothing to do 13113 13114 else 13115 return; 13116 end if; 13117 13118 -- A call to an Init_Proc in elaboration code may bring additional 13119 -- dependencies, if some of the record components thereof have 13120 -- initializations that are function calls that come from source. We 13121 -- treat the current node as a call to each of these functions, to check 13122 -- their elaboration impact. 13123 13124 if Is_Init_Proc (Ent) and then From_Elab_Code then 13125 Process_Init_Proc : declare 13126 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 13127 13128 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 13129 -- Find subprogram calls within body of Init_Proc for Traverse 13130 -- instantiation below. 13131 13132 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 13133 -- Traversal procedure to find all calls with body of Init_Proc 13134 13135 --------------------- 13136 -- Check_Init_Call -- 13137 --------------------- 13138 13139 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 13140 Func : Entity_Id; 13141 13142 begin 13143 if Nkind (Nod) in N_Subprogram_Call 13144 and then Is_Entity_Name (Name (Nod)) 13145 then 13146 Func := Entity (Name (Nod)); 13147 13148 if Comes_From_Source (Func) then 13149 Check_A_Call 13150 (N, Func, Standard_Standard, Inter_Unit_Only => True); 13151 end if; 13152 13153 return OK; 13154 13155 else 13156 return OK; 13157 end if; 13158 end Check_Init_Call; 13159 13160 -- Start of processing for Process_Init_Proc 13161 13162 begin 13163 if Nkind (Unit_Decl) = N_Subprogram_Body then 13164 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 13165 end if; 13166 end Process_Init_Proc; 13167 end if; 13168 end Check_Elab_Call; 13169 13170 ----------------------- 13171 -- Check_Elab_Assign -- 13172 ----------------------- 13173 13174 procedure Check_Elab_Assign (N : Node_Id) is 13175 Ent : Entity_Id; 13176 Scop : Entity_Id; 13177 13178 Pkg_Spec : Entity_Id; 13179 Pkg_Body : Entity_Id; 13180 13181 begin 13182 pragma Assert (Legacy_Elaboration_Checks); 13183 13184 -- For record or array component, check prefix. If it is an access type, 13185 -- then there is nothing to do (we do not know what is being assigned), 13186 -- but otherwise this is an assignment to the prefix. 13187 13188 if Nkind_In (N, N_Indexed_Component, 13189 N_Selected_Component, 13190 N_Slice) 13191 then 13192 if not Is_Access_Type (Etype (Prefix (N))) then 13193 Check_Elab_Assign (Prefix (N)); 13194 end if; 13195 13196 return; 13197 end if; 13198 13199 -- For type conversion, check expression 13200 13201 if Nkind (N) = N_Type_Conversion then 13202 Check_Elab_Assign (Expression (N)); 13203 return; 13204 end if; 13205 13206 -- Nothing to do if this is not an entity reference otherwise get entity 13207 13208 if Is_Entity_Name (N) then 13209 Ent := Entity (N); 13210 else 13211 return; 13212 end if; 13213 13214 -- What we are looking for is a reference in the body of a package that 13215 -- modifies a variable declared in the visible part of the package spec. 13216 13217 if Present (Ent) 13218 and then Comes_From_Source (N) 13219 and then not Suppress_Elaboration_Warnings (Ent) 13220 and then Ekind (Ent) = E_Variable 13221 and then not In_Private_Part (Ent) 13222 and then Is_Library_Level_Entity (Ent) 13223 then 13224 Scop := Current_Scope; 13225 loop 13226 if No (Scop) or else Scop = Standard_Standard then 13227 return; 13228 elsif Ekind (Scop) = E_Package 13229 and then Is_Compilation_Unit (Scop) 13230 then 13231 exit; 13232 else 13233 Scop := Scope (Scop); 13234 end if; 13235 end loop; 13236 13237 -- Here Scop points to the containing library package 13238 13239 Pkg_Spec := Scop; 13240 Pkg_Body := Body_Entity (Pkg_Spec); 13241 13242 -- All OK if the package has an Elaborate_Body pragma 13243 13244 if Has_Pragma_Elaborate_Body (Scop) then 13245 return; 13246 end if; 13247 13248 -- OK if entity being modified is not in containing package spec 13249 13250 if not In_Same_Source_Unit (Scop, Ent) then 13251 return; 13252 end if; 13253 13254 -- All OK if entity appears in generic package or generic instance. 13255 -- We just get too messed up trying to give proper warnings in the 13256 -- presence of generics. Better no message than a junk one. 13257 13258 Scop := Scope (Ent); 13259 while Present (Scop) and then Scop /= Pkg_Spec loop 13260 if Ekind (Scop) = E_Generic_Package then 13261 return; 13262 elsif Ekind (Scop) = E_Package 13263 and then Is_Generic_Instance (Scop) 13264 then 13265 return; 13266 end if; 13267 13268 Scop := Scope (Scop); 13269 end loop; 13270 13271 -- All OK if in task, don't issue warnings there 13272 13273 if In_Task_Activation then 13274 return; 13275 end if; 13276 13277 -- OK if no package body 13278 13279 if No (Pkg_Body) then 13280 return; 13281 end if; 13282 13283 -- OK if reference is not in package body 13284 13285 if not In_Same_Source_Unit (Pkg_Body, N) then 13286 return; 13287 end if; 13288 13289 -- OK if package body has no handled statement sequence 13290 13291 declare 13292 HSS : constant Node_Id := 13293 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 13294 begin 13295 if No (HSS) or else not Comes_From_Source (HSS) then 13296 return; 13297 end if; 13298 end; 13299 13300 -- We definitely have a case of a modification of an entity in 13301 -- the package spec from the elaboration code of the package body. 13302 -- We may not give the warning (because there are some additional 13303 -- checks to avoid too many false positives), but it would be a good 13304 -- idea for the binder to try to keep the body elaboration close to 13305 -- the spec elaboration. 13306 13307 Set_Elaborate_Body_Desirable (Pkg_Spec); 13308 13309 -- All OK in gnat mode (we know what we are doing) 13310 13311 if GNAT_Mode then 13312 return; 13313 end if; 13314 13315 -- All OK if all warnings suppressed 13316 13317 if Warning_Mode = Suppress then 13318 return; 13319 end if; 13320 13321 -- All OK if elaboration checks suppressed for entity 13322 13323 if Checks_May_Be_Suppressed (Ent) 13324 and then Is_Check_Suppressed (Ent, Elaboration_Check) 13325 then 13326 return; 13327 end if; 13328 13329 -- OK if the entity is initialized. Note that the No_Initialization 13330 -- flag usually means that the initialization has been rewritten into 13331 -- assignments, but that still counts for us. 13332 13333 declare 13334 Decl : constant Node_Id := Declaration_Node (Ent); 13335 begin 13336 if Nkind (Decl) = N_Object_Declaration 13337 and then (Present (Expression (Decl)) 13338 or else No_Initialization (Decl)) 13339 then 13340 return; 13341 end if; 13342 end; 13343 13344 -- Here is where we give the warning 13345 13346 -- All OK if warnings suppressed on the entity 13347 13348 if not Has_Warnings_Off (Ent) then 13349 Error_Msg_Sloc := Sloc (Ent); 13350 13351 Error_Msg_NE 13352 ("??& can be accessed by clients before this initialization", 13353 N, Ent); 13354 Error_Msg_NE 13355 ("\??add Elaborate_Body to spec to ensure & is initialized", 13356 N, Ent); 13357 end if; 13358 13359 if not All_Errors_Mode then 13360 Set_Suppress_Elaboration_Warnings (Ent); 13361 end if; 13362 end if; 13363 end Check_Elab_Assign; 13364 13365 ---------------------- 13366 -- Check_Elab_Calls -- 13367 ---------------------- 13368 13369 -- WARNING: This routine manages SPARK regions 13370 13371 procedure Check_Elab_Calls is 13372 Saved_SM : SPARK_Mode_Type; 13373 Saved_SMP : Node_Id; 13374 13375 begin 13376 pragma Assert (Legacy_Elaboration_Checks); 13377 13378 -- If expansion is disabled, do not generate any checks, unless we 13379 -- are in GNATprove mode, so that errors are issued in GNATprove for 13380 -- violations of static elaboration rules in SPARK code. Also skip 13381 -- checks if any subunits are missing because in either case we lack the 13382 -- full information that we need, and no object file will be created in 13383 -- any case. 13384 13385 if (not Expander_Active and not GNATprove_Mode) 13386 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 13387 or else Subunits_Missing 13388 then 13389 return; 13390 end if; 13391 13392 -- Skip delayed calls if we had any errors 13393 13394 if Serious_Errors_Detected = 0 then 13395 Delaying_Elab_Checks := False; 13396 Expander_Mode_Save_And_Set (True); 13397 13398 for J in Delay_Check.First .. Delay_Check.Last loop 13399 Push_Scope (Delay_Check.Table (J).Curscop); 13400 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 13401 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 13402 13403 Saved_SM := SPARK_Mode; 13404 Saved_SMP := SPARK_Mode_Pragma; 13405 13406 -- Set appropriate value of SPARK_Mode 13407 13408 if Delay_Check.Table (J).From_SPARK_Code then 13409 SPARK_Mode := On; 13410 end if; 13411 13412 Check_Internal_Call_Continue 13413 (N => Delay_Check.Table (J).N, 13414 E => Delay_Check.Table (J).E, 13415 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 13416 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 13417 13418 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 13419 Pop_Scope; 13420 end loop; 13421 13422 -- Set Delaying_Elab_Checks back on for next main compilation 13423 13424 Expander_Mode_Restore; 13425 Delaying_Elab_Checks := True; 13426 end if; 13427 end Check_Elab_Calls; 13428 13429 ------------------------------ 13430 -- Check_Elab_Instantiation -- 13431 ------------------------------ 13432 13433 procedure Check_Elab_Instantiation 13434 (N : Node_Id; 13435 Outer_Scope : Entity_Id := Empty) 13436 is 13437 Ent : Entity_Id; 13438 13439 begin 13440 pragma Assert (Legacy_Elaboration_Checks); 13441 13442 -- Check for and deal with bad instantiation case. There is some 13443 -- duplicated code here, but we will worry about this later ??? 13444 13445 Check_Bad_Instantiation (N); 13446 13447 if Is_Known_Guaranteed_ABE (N) then 13448 return; 13449 end if; 13450 13451 -- Nothing to do if we do not have an instantiation (happens in some 13452 -- error cases, and also in the formal package declaration case) 13453 13454 if Nkind (N) not in N_Generic_Instantiation then 13455 return; 13456 end if; 13457 13458 -- Nothing to do if inside a generic template 13459 13460 if Inside_A_Generic then 13461 return; 13462 end if; 13463 13464 -- Nothing to do if the instantiation is not in the main unit 13465 13466 if not In_Extended_Main_Code_Unit (N) then 13467 return; 13468 end if; 13469 13470 Ent := Get_Generic_Entity (N); 13471 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 13472 13473 -- See if we need to analyze this instantiation. We analyze it if 13474 -- either of the following conditions is met: 13475 13476 -- It is an inner level instantiation (since in this case it was 13477 -- triggered by an outer level call from elaboration code), but 13478 -- only if the instantiation is within the scope of the original 13479 -- outer level call. 13480 13481 -- It is an outer level instantiation from elaboration code, or the 13482 -- instantiated entity is in the same elaboration scope. 13483 13484 -- And in these cases, we will check both the inter-unit case and 13485 -- the intra-unit (within a single unit) case. 13486 13487 C_Scope := Current_Scope; 13488 13489 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 13490 Set_C_Scope; 13491 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 13492 13493 elsif From_Elab_Code then 13494 Set_C_Scope; 13495 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13496 13497 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13498 Set_C_Scope; 13499 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13500 13501 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 13502 -- set, then we will do the check, but only in the inter-unit case (this 13503 -- is to accommodate unguarded elaboration calls from other units in 13504 -- which this same mode is set). We inhibit warnings in this case, since 13505 -- this instantiation is not occurring in elaboration code. 13506 13507 elsif Dynamic_Elaboration_Checks then 13508 Set_C_Scope; 13509 Check_A_Call 13510 (N, 13511 Ent, 13512 Standard_Standard, 13513 Inter_Unit_Only => True, 13514 Generate_Warnings => False); 13515 13516 else 13517 return; 13518 end if; 13519 end Check_Elab_Instantiation; 13520 13521 ------------------------- 13522 -- Check_Internal_Call -- 13523 ------------------------- 13524 13525 procedure Check_Internal_Call 13526 (N : Node_Id; 13527 E : Entity_Id; 13528 Outer_Scope : Entity_Id; 13529 Orig_Ent : Entity_Id) 13530 is 13531 function Within_Initial_Condition (Call : Node_Id) return Boolean; 13532 -- Determine whether call Call occurs within pragma Initial_Condition or 13533 -- pragma Check with check_kind set to Initial_Condition. 13534 13535 ------------------------------ 13536 -- Within_Initial_Condition -- 13537 ------------------------------ 13538 13539 function Within_Initial_Condition (Call : Node_Id) return Boolean is 13540 Args : List_Id; 13541 Nam : Name_Id; 13542 Par : Node_Id; 13543 13544 begin 13545 -- Traverse the parent chain looking for an enclosing pragma 13546 13547 Par := Call; 13548 while Present (Par) loop 13549 if Nkind (Par) = N_Pragma then 13550 Nam := Pragma_Name (Par); 13551 13552 -- Pragma Initial_Condition appears in its alternative from as 13553 -- Check (Initial_Condition, ...). 13554 13555 if Nam = Name_Check then 13556 Args := Pragma_Argument_Associations (Par); 13557 13558 -- Pragma Check should have at least two arguments 13559 13560 pragma Assert (Present (Args)); 13561 13562 return 13563 Chars (Expression (First (Args))) = Name_Initial_Condition; 13564 13565 -- Direct match 13566 13567 elsif Nam = Name_Initial_Condition then 13568 return True; 13569 13570 -- Since pragmas are never nested within other pragmas, stop 13571 -- the traversal. 13572 13573 else 13574 return False; 13575 end if; 13576 13577 -- Prevent the search from going too far 13578 13579 elsif Is_Body_Or_Package_Declaration (Par) then 13580 exit; 13581 end if; 13582 13583 Par := Parent (Par); 13584 13585 -- If assertions are not enabled, the check pragma is rewritten 13586 -- as an if_statement in sem_prag, to generate various warnings 13587 -- on boolean expressions. Retrieve the original pragma. 13588 13589 if Nkind (Original_Node (Par)) = N_Pragma then 13590 Par := Original_Node (Par); 13591 end if; 13592 end loop; 13593 13594 return False; 13595 end Within_Initial_Condition; 13596 13597 -- Local variables 13598 13599 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 13600 13601 -- Start of processing for Check_Internal_Call 13602 13603 begin 13604 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 13605 -- node comes from source. 13606 13607 if Nkind (N) = N_Attribute_Reference 13608 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 13609 or else not Comes_From_Source (N)) 13610 then 13611 return; 13612 13613 -- If not function or procedure call, instantiation, or 'Access, then 13614 -- ignore call (this happens in some error cases and rewriting cases). 13615 13616 elsif not Nkind_In (N, N_Attribute_Reference, 13617 N_Function_Call, 13618 N_Procedure_Call_Statement) 13619 and then not Inst_Case 13620 then 13621 return; 13622 13623 -- Nothing to do if this is a call or instantiation that has already 13624 -- been found to be a sure ABE. 13625 13626 elsif Nkind (N) /= N_Attribute_Reference 13627 and then Is_Known_Guaranteed_ABE (N) 13628 then 13629 return; 13630 13631 -- Nothing to do if errors already detected (avoid cascaded errors) 13632 13633 elsif Serious_Errors_Detected /= 0 then 13634 return; 13635 13636 -- Nothing to do if not in full analysis mode 13637 13638 elsif not Full_Analysis then 13639 return; 13640 13641 -- Nothing to do if analyzing in special spec-expression mode, since the 13642 -- call is not actually being made at this time. 13643 13644 elsif In_Spec_Expression then 13645 return; 13646 13647 -- Nothing to do for call to intrinsic subprogram 13648 13649 elsif Is_Intrinsic_Subprogram (E) then 13650 return; 13651 13652 -- Nothing to do if call is within a generic unit 13653 13654 elsif Inside_A_Generic then 13655 return; 13656 13657 -- Nothing to do when the call appears within pragma Initial_Condition. 13658 -- The pragma is part of the elaboration statements of a package body 13659 -- and may only call external subprograms or subprograms whose body is 13660 -- already available. 13661 13662 elsif Within_Initial_Condition (N) then 13663 return; 13664 end if; 13665 13666 -- Delay this call if we are still delaying calls 13667 13668 if Delaying_Elab_Checks then 13669 Delay_Check.Append 13670 ((N => N, 13671 E => E, 13672 Orig_Ent => Orig_Ent, 13673 Curscop => Current_Scope, 13674 Outer_Scope => Outer_Scope, 13675 From_Elab_Code => From_Elab_Code, 13676 In_Task_Activation => In_Task_Activation, 13677 From_SPARK_Code => SPARK_Mode = On)); 13678 return; 13679 13680 -- Otherwise, call phase 2 continuation right now 13681 13682 else 13683 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 13684 end if; 13685 end Check_Internal_Call; 13686 13687 ---------------------------------- 13688 -- Check_Internal_Call_Continue -- 13689 ---------------------------------- 13690 13691 procedure Check_Internal_Call_Continue 13692 (N : Node_Id; 13693 E : Entity_Id; 13694 Outer_Scope : Entity_Id; 13695 Orig_Ent : Entity_Id) 13696 is 13697 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 13698 -- Function applied to each node as we traverse the body. Checks for 13699 -- call or entity reference that needs checking, and if so checks it. 13700 -- Always returns OK, so entire tree is traversed, except that as 13701 -- described below subprogram bodies are skipped for now. 13702 13703 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 13704 -- Traverse procedure using above Find_Elab_Reference function 13705 13706 ------------------------- 13707 -- Find_Elab_Reference -- 13708 ------------------------- 13709 13710 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 13711 Actual : Node_Id; 13712 13713 begin 13714 -- If user has specified that there are no entry calls in elaboration 13715 -- code, do not trace past an accept statement, because the rendez- 13716 -- vous will happen after elaboration. 13717 13718 if Nkind_In (Original_Node (N), N_Accept_Statement, 13719 N_Selective_Accept) 13720 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 13721 then 13722 return Abandon; 13723 13724 -- If we have a function call, check it 13725 13726 elsif Nkind (N) = N_Function_Call then 13727 Check_Elab_Call (N, Outer_Scope); 13728 return OK; 13729 13730 -- If we have a procedure call, check the call, and also check 13731 -- arguments that are assignments (OUT or IN OUT mode formals). 13732 13733 elsif Nkind (N) = N_Procedure_Call_Statement then 13734 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 13735 13736 Actual := First_Actual (N); 13737 while Present (Actual) loop 13738 if Known_To_Be_Assigned (Actual) then 13739 Check_Elab_Assign (Actual); 13740 end if; 13741 13742 Next_Actual (Actual); 13743 end loop; 13744 13745 return OK; 13746 13747 -- If we have an access attribute for a subprogram, check it. 13748 -- Suppress this behavior under debug flag. 13749 13750 elsif not Debug_Flag_Dot_UU 13751 and then Nkind (N) = N_Attribute_Reference 13752 and then Nam_In (Attribute_Name (N), Name_Access, 13753 Name_Unrestricted_Access) 13754 and then Is_Entity_Name (Prefix (N)) 13755 and then Is_Subprogram (Entity (Prefix (N))) 13756 then 13757 Check_Elab_Call (N, Outer_Scope); 13758 return OK; 13759 13760 -- In SPARK mode, if we have an entity reference to a variable, then 13761 -- check it. For now we consider any reference. 13762 13763 elsif SPARK_Mode = On 13764 and then Nkind (N) in N_Has_Entity 13765 and then Present (Entity (N)) 13766 and then Ekind (Entity (N)) = E_Variable 13767 then 13768 Check_Elab_Call (N, Outer_Scope); 13769 return OK; 13770 13771 -- If we have a generic instantiation, check it 13772 13773 elsif Nkind (N) in N_Generic_Instantiation then 13774 Check_Elab_Instantiation (N, Outer_Scope); 13775 return OK; 13776 13777 -- Skip subprogram bodies that come from source (wait for call to 13778 -- analyze these). The reason for the come from source test is to 13779 -- avoid catching task bodies. 13780 13781 -- For task bodies, we should really avoid these too, waiting for the 13782 -- task activation, but that's too much trouble to catch for now, so 13783 -- we go in unconditionally. This is not so terrible, it means the 13784 -- error backtrace is not quite complete, and we are too eager to 13785 -- scan bodies of tasks that are unused, but this is hardly very 13786 -- significant. 13787 13788 elsif Nkind (N) = N_Subprogram_Body 13789 and then Comes_From_Source (N) 13790 then 13791 return Skip; 13792 13793 elsif Nkind (N) = N_Assignment_Statement 13794 and then Comes_From_Source (N) 13795 then 13796 Check_Elab_Assign (Name (N)); 13797 return OK; 13798 13799 else 13800 return OK; 13801 end if; 13802 end Find_Elab_Reference; 13803 13804 Inst_Case : constant Boolean := Is_Generic_Unit (E); 13805 Loc : constant Source_Ptr := Sloc (N); 13806 13807 Ebody : Entity_Id; 13808 Sbody : Node_Id; 13809 13810 -- Start of processing for Check_Internal_Call_Continue 13811 13812 begin 13813 -- Save outer level call if at outer level 13814 13815 if Elab_Call.Last = 0 then 13816 Outer_Level_Sloc := Loc; 13817 end if; 13818 13819 -- If the call is to a function that renames a literal, no check needed 13820 13821 if Ekind (E) = E_Enumeration_Literal then 13822 return; 13823 end if; 13824 13825 -- Register the subprogram as examined within this particular context. 13826 -- This ensures that calls to the same subprogram but in different 13827 -- contexts receive warnings and checks of their own since the calls 13828 -- may be reached through different flow paths. 13829 13830 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 13831 13832 Sbody := Unit_Declaration_Node (E); 13833 13834 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then 13835 Ebody := Corresponding_Body (Sbody); 13836 13837 if No (Ebody) then 13838 return; 13839 else 13840 Sbody := Unit_Declaration_Node (Ebody); 13841 end if; 13842 end if; 13843 13844 -- If the body appears after the outer level call or instantiation then 13845 -- we have an error case handled below. 13846 13847 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 13848 and then not In_Task_Activation 13849 then 13850 null; 13851 13852 -- If we have the instantiation case we are done, since we now know that 13853 -- the body of the generic appeared earlier. 13854 13855 elsif Inst_Case then 13856 return; 13857 13858 -- Otherwise we have a call, so we trace through the called body to see 13859 -- if it has any problems. 13860 13861 else 13862 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 13863 13864 Elab_Call.Append ((Cloc => Loc, Ent => E)); 13865 13866 if Debug_Flag_Underscore_LL then 13867 Write_Str ("Elab_Call.Last = "); 13868 Write_Int (Int (Elab_Call.Last)); 13869 Write_Str (" Ent = "); 13870 Write_Name (Chars (E)); 13871 Write_Str (" at "); 13872 Write_Location (Sloc (N)); 13873 Write_Eol; 13874 end if; 13875 13876 -- Now traverse declarations and statements of subprogram body. Note 13877 -- that we cannot simply Traverse (Sbody), since traverse does not 13878 -- normally visit subprogram bodies. 13879 13880 declare 13881 Decl : Node_Id; 13882 begin 13883 Decl := First (Declarations (Sbody)); 13884 while Present (Decl) loop 13885 Traverse (Decl); 13886 Next (Decl); 13887 end loop; 13888 end; 13889 13890 Traverse (Handled_Statement_Sequence (Sbody)); 13891 13892 Elab_Call.Decrement_Last; 13893 return; 13894 end if; 13895 13896 -- Here is the case of calling a subprogram where the body has not yet 13897 -- been encountered. A warning message is needed, except if this is the 13898 -- case of appearing within an aspect specification that results in 13899 -- a check call, we do not really have such a situation, so no warning 13900 -- is needed (e.g. the case of a precondition, where the call appears 13901 -- textually before the body, but in actual fact is moved to the 13902 -- appropriate subprogram body and so does not need a check). 13903 13904 declare 13905 P : Node_Id; 13906 O : Node_Id; 13907 13908 begin 13909 P := Parent (N); 13910 loop 13911 -- Keep looking at parents if we are still in the subexpression 13912 13913 if Nkind (P) in N_Subexpr then 13914 P := Parent (P); 13915 13916 -- Here P is the parent of the expression, check for special case 13917 13918 else 13919 O := Original_Node (P); 13920 13921 -- Definitely not the special case if orig node is not a pragma 13922 13923 exit when Nkind (O) /= N_Pragma; 13924 13925 -- Check we have an If statement or a null statement (happens 13926 -- when the If has been expanded to be True). 13927 13928 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); 13929 13930 -- Our special case will be indicated either by the pragma 13931 -- coming from an aspect ... 13932 13933 if Present (Corresponding_Aspect (O)) then 13934 return; 13935 13936 -- Or, in the case of an initial condition, specifically by a 13937 -- Check pragma specifying an Initial_Condition check. 13938 13939 elsif Pragma_Name (O) = Name_Check 13940 and then 13941 Chars 13942 (Expression (First (Pragma_Argument_Associations (O)))) = 13943 Name_Initial_Condition 13944 then 13945 return; 13946 13947 -- For anything else, we have an error 13948 13949 else 13950 exit; 13951 end if; 13952 end if; 13953 end loop; 13954 end; 13955 13956 -- Not that special case, warning and dynamic check is required 13957 13958 -- If we have nothing in the call stack, then this is at the outer 13959 -- level, and the ABE is bound to occur, unless it's a 'Access, or 13960 -- it's a renaming. 13961 13962 if Elab_Call.Last = 0 then 13963 Error_Msg_Warn := SPARK_Mode /= On; 13964 13965 declare 13966 Insert_Check : Boolean := True; 13967 -- This flag is set to True if an elaboration check should be 13968 -- inserted. 13969 13970 begin 13971 if In_Task_Activation then 13972 Insert_Check := False; 13973 13974 elsif Inst_Case then 13975 Error_Msg_NE 13976 ("cannot instantiate& before body seen<<", N, Orig_Ent); 13977 13978 elsif Nkind (N) = N_Attribute_Reference then 13979 Error_Msg_NE 13980 ("Access attribute of & before body seen<<", N, Orig_Ent); 13981 Error_Msg_N ("\possible Program_Error on later references<", N); 13982 Insert_Check := False; 13983 13984 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 13985 N_Subprogram_Renaming_Declaration 13986 then 13987 Error_Msg_NE 13988 ("cannot call& before body seen<<", N, Orig_Ent); 13989 13990 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then 13991 Insert_Check := False; 13992 end if; 13993 13994 if Insert_Check then 13995 Error_Msg_N ("\Program_Error [<<", N); 13996 Insert_Elab_Check (N); 13997 end if; 13998 end; 13999 14000 -- Call is not at outer level 14001 14002 else 14003 -- Do not generate elaboration checks in GNATprove mode because the 14004 -- elaboration counter and the check are both forms of expansion. 14005 14006 if GNATprove_Mode then 14007 null; 14008 14009 -- Generate an elaboration check 14010 14011 elsif not Elaboration_Checks_Suppressed (E) then 14012 Set_Elaboration_Entity_Required (E); 14013 14014 -- Create a declaration of the elaboration entity, and insert it 14015 -- prior to the subprogram or the generic unit, within the same 14016 -- scope. Since the subprogram may be overloaded, create a unique 14017 -- entity. 14018 14019 if No (Elaboration_Entity (E)) then 14020 declare 14021 Loce : constant Source_Ptr := Sloc (E); 14022 Ent : constant Entity_Id := 14023 Make_Defining_Identifier (Loc, 14024 New_External_Name (Chars (E), 'E', -1)); 14025 14026 begin 14027 Set_Elaboration_Entity (E, Ent); 14028 Push_Scope (Scope (E)); 14029 14030 Insert_Action (Declaration_Node (E), 14031 Make_Object_Declaration (Loce, 14032 Defining_Identifier => Ent, 14033 Object_Definition => 14034 New_Occurrence_Of (Standard_Short_Integer, Loce), 14035 Expression => 14036 Make_Integer_Literal (Loc, Uint_0))); 14037 14038 -- Set elaboration flag at the point of the body 14039 14040 Set_Elaboration_Flag (Sbody, E); 14041 14042 -- Kill current value indication. This is necessary because 14043 -- the tests of this flag are inserted out of sequence and 14044 -- must not pick up bogus indications of the wrong constant 14045 -- value. Also, this is never a true constant, since one way 14046 -- or another, it gets reset. 14047 14048 Set_Current_Value (Ent, Empty); 14049 Set_Last_Assignment (Ent, Empty); 14050 Set_Is_True_Constant (Ent, False); 14051 Pop_Scope; 14052 end; 14053 end if; 14054 14055 -- Generate: 14056 -- if Enn = 0 then 14057 -- raise Program_Error with "access before elaboration"; 14058 -- end if; 14059 14060 Insert_Elab_Check (N, 14061 Make_Attribute_Reference (Loc, 14062 Attribute_Name => Name_Elaborated, 14063 Prefix => New_Occurrence_Of (E, Loc))); 14064 end if; 14065 14066 -- Generate the warning 14067 14068 if not Suppress_Elaboration_Warnings (E) 14069 and then not Elaboration_Checks_Suppressed (E) 14070 14071 -- Suppress this warning if we have a function call that occurred 14072 -- within an assertion expression, since we can get false warnings 14073 -- in this case, due to the out of order handling in this case. 14074 14075 and then 14076 (Nkind (Original_Node (N)) /= N_Function_Call 14077 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 14078 then 14079 Error_Msg_Warn := SPARK_Mode /= On; 14080 14081 if Inst_Case then 14082 Error_Msg_NE 14083 ("instantiation of& may occur before body is seen<l<", 14084 N, Orig_Ent); 14085 else 14086 -- A rather specific check. For Finalize/Adjust/Initialize, if 14087 -- the type has Warnings_Off set, suppress the warning. 14088 14089 if Nam_In (Chars (E), Name_Adjust, 14090 Name_Finalize, 14091 Name_Initialize) 14092 and then Present (First_Formal (E)) 14093 then 14094 declare 14095 T : constant Entity_Id := Etype (First_Formal (E)); 14096 begin 14097 if Is_Controlled (T) then 14098 if Warnings_Off (T) 14099 or else (Ekind (T) = E_Private_Type 14100 and then Warnings_Off (Full_View (T))) 14101 then 14102 goto Output; 14103 end if; 14104 end if; 14105 end; 14106 end if; 14107 14108 -- Go ahead and give warning if not this special case 14109 14110 Error_Msg_NE 14111 ("call to& may occur before body is seen<l<", N, Orig_Ent); 14112 end if; 14113 14114 Error_Msg_N ("\Program_Error ]<l<", N); 14115 14116 -- There is no need to query the elaboration warning message flags 14117 -- because the main message is an error, not a warning, therefore 14118 -- all the clarification messages produces by Output_Calls must be 14119 -- emitted unconditionally. 14120 14121 <<Output>> 14122 14123 Output_Calls (N, Check_Elab_Flag => False); 14124 end if; 14125 end if; 14126 end Check_Internal_Call_Continue; 14127 14128 --------------------------- 14129 -- Check_Task_Activation -- 14130 --------------------------- 14131 14132 procedure Check_Task_Activation (N : Node_Id) is 14133 Loc : constant Source_Ptr := Sloc (N); 14134 Inter_Procs : constant Elist_Id := New_Elmt_List; 14135 Intra_Procs : constant Elist_Id := New_Elmt_List; 14136 Ent : Entity_Id; 14137 P : Entity_Id; 14138 Task_Scope : Entity_Id; 14139 Cunit_SC : Boolean := False; 14140 Decl : Node_Id; 14141 Elmt : Elmt_Id; 14142 Enclosing : Entity_Id; 14143 14144 procedure Add_Task_Proc (Typ : Entity_Id); 14145 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 14146 -- For record types, this procedure recurses over component types. 14147 14148 procedure Collect_Tasks (Decls : List_Id); 14149 -- Collect the types of the tasks that are to be activated in the given 14150 -- list of declarations, in order to perform elaboration checks on the 14151 -- corresponding task procedures that are called implicitly here. 14152 14153 function Outer_Unit (E : Entity_Id) return Entity_Id; 14154 -- find enclosing compilation unit of Entity, ignoring subunits, or 14155 -- else enclosing subprogram. If E is not a package, there is no need 14156 -- for inter-unit elaboration checks. 14157 14158 ------------------- 14159 -- Add_Task_Proc -- 14160 ------------------- 14161 14162 procedure Add_Task_Proc (Typ : Entity_Id) is 14163 Comp : Entity_Id; 14164 Proc : Entity_Id := Empty; 14165 14166 begin 14167 if Is_Task_Type (Typ) then 14168 Proc := Get_Task_Body_Procedure (Typ); 14169 14170 elsif Is_Array_Type (Typ) 14171 and then Has_Task (Base_Type (Typ)) 14172 then 14173 Add_Task_Proc (Component_Type (Typ)); 14174 14175 elsif Is_Record_Type (Typ) 14176 and then Has_Task (Base_Type (Typ)) 14177 then 14178 Comp := First_Component (Typ); 14179 while Present (Comp) loop 14180 Add_Task_Proc (Etype (Comp)); 14181 Comp := Next_Component (Comp); 14182 end loop; 14183 end if; 14184 14185 -- If the task type is another unit, we will perform the usual 14186 -- elaboration check on its enclosing unit. If the type is in the 14187 -- same unit, we can trace the task body as for an internal call, 14188 -- but we only need to examine other external calls, because at 14189 -- the point the task is activated, internal subprogram bodies 14190 -- will have been elaborated already. We keep separate lists for 14191 -- each kind of task. 14192 14193 -- Skip this test if errors have occurred, since in this case 14194 -- we can get false indications. 14195 14196 if Serious_Errors_Detected /= 0 then 14197 return; 14198 end if; 14199 14200 if Present (Proc) then 14201 if Outer_Unit (Scope (Proc)) = Enclosing then 14202 14203 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 14204 and then 14205 (not Is_Generic_Instance (Scope (Proc)) 14206 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 14207 then 14208 Error_Msg_Warn := SPARK_Mode /= On; 14209 Error_Msg_N 14210 ("task will be activated before elaboration of its body<<", 14211 Decl); 14212 Error_Msg_N ("\Program_Error [<<", Decl); 14213 14214 elsif Present 14215 (Corresponding_Body (Unit_Declaration_Node (Proc))) 14216 then 14217 Append_Elmt (Proc, Intra_Procs); 14218 end if; 14219 14220 else 14221 -- No need for multiple entries of the same type 14222 14223 Elmt := First_Elmt (Inter_Procs); 14224 while Present (Elmt) loop 14225 if Node (Elmt) = Proc then 14226 return; 14227 end if; 14228 14229 Next_Elmt (Elmt); 14230 end loop; 14231 14232 Append_Elmt (Proc, Inter_Procs); 14233 end if; 14234 end if; 14235 end Add_Task_Proc; 14236 14237 ------------------- 14238 -- Collect_Tasks -- 14239 ------------------- 14240 14241 procedure Collect_Tasks (Decls : List_Id) is 14242 begin 14243 if Present (Decls) then 14244 Decl := First (Decls); 14245 while Present (Decl) loop 14246 if Nkind (Decl) = N_Object_Declaration 14247 and then Has_Task (Etype (Defining_Identifier (Decl))) 14248 then 14249 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 14250 end if; 14251 14252 Next (Decl); 14253 end loop; 14254 end if; 14255 end Collect_Tasks; 14256 14257 ---------------- 14258 -- Outer_Unit -- 14259 ---------------- 14260 14261 function Outer_Unit (E : Entity_Id) return Entity_Id is 14262 Outer : Entity_Id; 14263 14264 begin 14265 Outer := E; 14266 while Present (Outer) loop 14267 if Elaboration_Checks_Suppressed (Outer) then 14268 Cunit_SC := True; 14269 end if; 14270 14271 exit when Is_Child_Unit (Outer) 14272 or else Scope (Outer) = Standard_Standard 14273 or else Ekind (Outer) /= E_Package; 14274 Outer := Scope (Outer); 14275 end loop; 14276 14277 return Outer; 14278 end Outer_Unit; 14279 14280 -- Start of processing for Check_Task_Activation 14281 14282 begin 14283 pragma Assert (Legacy_Elaboration_Checks); 14284 14285 Enclosing := Outer_Unit (Current_Scope); 14286 14287 -- Find all tasks declared in the current unit 14288 14289 if Nkind (N) = N_Package_Body then 14290 P := Unit_Declaration_Node (Corresponding_Spec (N)); 14291 14292 Collect_Tasks (Declarations (N)); 14293 Collect_Tasks (Visible_Declarations (Specification (P))); 14294 Collect_Tasks (Private_Declarations (Specification (P))); 14295 14296 elsif Nkind (N) = N_Package_Declaration then 14297 Collect_Tasks (Visible_Declarations (Specification (N))); 14298 Collect_Tasks (Private_Declarations (Specification (N))); 14299 14300 else 14301 Collect_Tasks (Declarations (N)); 14302 end if; 14303 14304 -- We only perform detailed checks in all tasks that are library level 14305 -- entities. If the master is a subprogram or task, activation will 14306 -- depend on the activation of the master itself. 14307 14308 -- Should dynamic checks be added in the more general case??? 14309 14310 if Ekind (Enclosing) /= E_Package then 14311 return; 14312 end if; 14313 14314 -- For task types defined in other units, we want the unit containing 14315 -- the task body to be elaborated before the current one. 14316 14317 Elmt := First_Elmt (Inter_Procs); 14318 while Present (Elmt) loop 14319 Ent := Node (Elmt); 14320 Task_Scope := Outer_Unit (Scope (Ent)); 14321 14322 if not Is_Compilation_Unit (Task_Scope) then 14323 null; 14324 14325 elsif Suppress_Elaboration_Warnings (Task_Scope) 14326 or else Elaboration_Checks_Suppressed (Task_Scope) 14327 then 14328 null; 14329 14330 elsif Dynamic_Elaboration_Checks then 14331 if not Elaboration_Checks_Suppressed (Ent) 14332 and then not Cunit_SC 14333 and then not Restriction_Active 14334 (No_Entry_Calls_In_Elaboration_Code) 14335 then 14336 -- Runtime elaboration check required. Generate check of the 14337 -- elaboration counter for the unit containing the entity. 14338 14339 Insert_Elab_Check (N, 14340 Make_Attribute_Reference (Loc, 14341 Prefix => 14342 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 14343 Attribute_Name => Name_Elaborated)); 14344 end if; 14345 14346 else 14347 -- Force the binder to elaborate other unit first 14348 14349 if Elab_Info_Messages 14350 and then not Suppress_Elaboration_Warnings (Ent) 14351 and then not Elaboration_Checks_Suppressed (Ent) 14352 and then not Suppress_Elaboration_Warnings (Task_Scope) 14353 and then not Elaboration_Checks_Suppressed (Task_Scope) 14354 then 14355 Error_Msg_Node_2 := Task_Scope; 14356 Error_Msg_NE 14357 ("info: activation of an instance of task type & requires " 14358 & "pragma Elaborate_All on &?$?", N, Ent); 14359 end if; 14360 14361 Activate_Elaborate_All_Desirable (N, Task_Scope); 14362 Set_Suppress_Elaboration_Warnings (Task_Scope); 14363 end if; 14364 14365 Next_Elmt (Elmt); 14366 end loop; 14367 14368 -- For tasks declared in the current unit, trace other calls within the 14369 -- task procedure bodies, which are available. 14370 14371 if not Debug_Flag_Dot_Y then 14372 In_Task_Activation := True; 14373 14374 Elmt := First_Elmt (Intra_Procs); 14375 while Present (Elmt) loop 14376 Ent := Node (Elmt); 14377 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 14378 Next_Elmt (Elmt); 14379 end loop; 14380 14381 In_Task_Activation := False; 14382 end if; 14383 end Check_Task_Activation; 14384 14385 ------------------------ 14386 -- Get_Referenced_Ent -- 14387 ------------------------ 14388 14389 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 14390 Nam : Node_Id; 14391 14392 begin 14393 if Nkind (N) in N_Has_Entity 14394 and then Present (Entity (N)) 14395 and then Ekind (Entity (N)) = E_Variable 14396 then 14397 return Entity (N); 14398 end if; 14399 14400 if Nkind (N) = N_Attribute_Reference then 14401 Nam := Prefix (N); 14402 else 14403 Nam := Name (N); 14404 end if; 14405 14406 if No (Nam) then 14407 return Empty; 14408 elsif Nkind (Nam) = N_Selected_Component then 14409 return Entity (Selector_Name (Nam)); 14410 elsif not Is_Entity_Name (Nam) then 14411 return Empty; 14412 else 14413 return Entity (Nam); 14414 end if; 14415 end Get_Referenced_Ent; 14416 14417 ---------------------- 14418 -- Has_Generic_Body -- 14419 ---------------------- 14420 14421 function Has_Generic_Body (N : Node_Id) return Boolean is 14422 Ent : constant Entity_Id := Get_Generic_Entity (N); 14423 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 14424 Scop : Entity_Id; 14425 14426 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 14427 -- Determine if the list of nodes headed by N and linked by Next 14428 -- contains a package body for the package spec entity E, and if so 14429 -- return the package body. If not, then returns Empty. 14430 14431 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 14432 -- This procedure is called load the unit whose name is given by Nam. 14433 -- This unit is being loaded to see whether it contains an optional 14434 -- generic body. The returned value is the loaded unit, which is always 14435 -- a package body (only package bodies can contain other entities in the 14436 -- sense in which Has_Generic_Body is interested). We only attempt to 14437 -- load bodies if we are generating code. If we are in semantics check 14438 -- only mode, then it would be wrong to load bodies that are not 14439 -- required from a semantic point of view, so in this case we return 14440 -- Empty. The result is that the caller may incorrectly decide that a 14441 -- generic spec does not have a body when in fact it does, but the only 14442 -- harm in this is that some warnings on elaboration problems may be 14443 -- lost in semantic checks only mode, which is not big loss. We also 14444 -- return Empty if we go for a body and it is not there. 14445 14446 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 14447 -- PE is the entity for a package spec. This function locates the 14448 -- corresponding package body, returning Empty if none is found. The 14449 -- package body returned is fully parsed but may not yet be analyzed, 14450 -- so only syntactic fields should be referenced. 14451 14452 ------------------ 14453 -- Find_Body_In -- 14454 ------------------ 14455 14456 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 14457 Nod : Node_Id; 14458 14459 begin 14460 Nod := N; 14461 while Present (Nod) loop 14462 14463 -- If we found the package body we are looking for, return it 14464 14465 if Nkind (Nod) = N_Package_Body 14466 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 14467 then 14468 return Nod; 14469 14470 -- If we found the stub for the body, go after the subunit, 14471 -- loading it if necessary. 14472 14473 elsif Nkind (Nod) = N_Package_Body_Stub 14474 and then Chars (Defining_Identifier (Nod)) = Chars (E) 14475 then 14476 if Present (Library_Unit (Nod)) then 14477 return Unit (Library_Unit (Nod)); 14478 14479 else 14480 return Load_Package_Body (Get_Unit_Name (Nod)); 14481 end if; 14482 14483 -- If neither package body nor stub, keep looking on chain 14484 14485 else 14486 Next (Nod); 14487 end if; 14488 end loop; 14489 14490 return Empty; 14491 end Find_Body_In; 14492 14493 ----------------------- 14494 -- Load_Package_Body -- 14495 ----------------------- 14496 14497 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 14498 U : Unit_Number_Type; 14499 14500 begin 14501 if Operating_Mode /= Generate_Code then 14502 return Empty; 14503 else 14504 U := 14505 Load_Unit 14506 (Load_Name => Nam, 14507 Required => False, 14508 Subunit => False, 14509 Error_Node => N); 14510 14511 if U = No_Unit then 14512 return Empty; 14513 else 14514 return Unit (Cunit (U)); 14515 end if; 14516 end if; 14517 end Load_Package_Body; 14518 14519 ------------------------------- 14520 -- Locate_Corresponding_Body -- 14521 ------------------------------- 14522 14523 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 14524 Spec : constant Node_Id := Declaration_Node (PE); 14525 Decl : constant Node_Id := Parent (Spec); 14526 Scop : constant Entity_Id := Scope (PE); 14527 PBody : Node_Id; 14528 14529 begin 14530 if Is_Library_Level_Entity (PE) then 14531 14532 -- If package is a library unit that requires a body, we have no 14533 -- choice but to go after that body because it might contain an 14534 -- optional body for the original generic package. 14535 14536 if Unit_Requires_Body (PE) then 14537 14538 -- Load the body. Note that we are a little careful here to use 14539 -- Spec to get the unit number, rather than PE or Decl, since 14540 -- in the case where the package is itself a library level 14541 -- instantiation, Spec will properly reference the generic 14542 -- template, which is what we really want. 14543 14544 return 14545 Load_Package_Body 14546 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 14547 14548 -- But if the package is a library unit that does NOT require 14549 -- a body, then no body is permitted, so we are sure that there 14550 -- is no body for the original generic package. 14551 14552 else 14553 return Empty; 14554 end if; 14555 14556 -- Otherwise look and see if we are embedded in a further package 14557 14558 elsif Is_Package_Or_Generic_Package (Scop) then 14559 14560 -- If so, get the body of the enclosing package, and look in 14561 -- its package body for the package body we are looking for. 14562 14563 PBody := Locate_Corresponding_Body (Scop); 14564 14565 if No (PBody) then 14566 return Empty; 14567 else 14568 return Find_Body_In (PE, First (Declarations (PBody))); 14569 end if; 14570 14571 -- If we are not embedded in a further package, then the body 14572 -- must be in the same declarative part as we are. 14573 14574 else 14575 return Find_Body_In (PE, Next (Decl)); 14576 end if; 14577 end Locate_Corresponding_Body; 14578 14579 -- Start of processing for Has_Generic_Body 14580 14581 begin 14582 if Present (Corresponding_Body (Decl)) then 14583 return True; 14584 14585 elsif Unit_Requires_Body (Ent) then 14586 return True; 14587 14588 -- Compilation units cannot have optional bodies 14589 14590 elsif Is_Compilation_Unit (Ent) then 14591 return False; 14592 14593 -- Otherwise look at what scope we are in 14594 14595 else 14596 Scop := Scope (Ent); 14597 14598 -- Case of entity is in other than a package spec, in this case 14599 -- the body, if present, must be in the same declarative part. 14600 14601 if not Is_Package_Or_Generic_Package (Scop) then 14602 declare 14603 P : Node_Id; 14604 14605 begin 14606 -- Declaration node may get us a spec, so if so, go to 14607 -- the parent declaration. 14608 14609 P := Declaration_Node (Ent); 14610 while not Is_List_Member (P) loop 14611 P := Parent (P); 14612 end loop; 14613 14614 return Present (Find_Body_In (Ent, Next (P))); 14615 end; 14616 14617 -- If the entity is in a package spec, then we have to locate 14618 -- the corresponding package body, and look there. 14619 14620 else 14621 declare 14622 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 14623 14624 begin 14625 if No (PBody) then 14626 return False; 14627 else 14628 return 14629 Present 14630 (Find_Body_In (Ent, (First (Declarations (PBody))))); 14631 end if; 14632 end; 14633 end if; 14634 end if; 14635 end Has_Generic_Body; 14636 14637 ----------------------- 14638 -- Insert_Elab_Check -- 14639 ----------------------- 14640 14641 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 14642 Nod : Node_Id; 14643 Loc : constant Source_Ptr := Sloc (N); 14644 14645 Chk : Node_Id; 14646 -- The check (N_Raise_Program_Error) node to be inserted 14647 14648 begin 14649 -- If expansion is disabled, do not generate any checks. Also 14650 -- skip checks if any subunits are missing because in either 14651 -- case we lack the full information that we need, and no object 14652 -- file will be created in any case. 14653 14654 if not Expander_Active or else Subunits_Missing then 14655 return; 14656 end if; 14657 14658 -- If we have a generic instantiation, where Instance_Spec is set, 14659 -- then this field points to a generic instance spec that has 14660 -- been inserted before the instantiation node itself, so that 14661 -- is where we want to insert a check. 14662 14663 if Nkind (N) in N_Generic_Instantiation 14664 and then Present (Instance_Spec (N)) 14665 then 14666 Nod := Instance_Spec (N); 14667 else 14668 Nod := N; 14669 end if; 14670 14671 -- Build check node, possibly with condition 14672 14673 Chk := 14674 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 14675 14676 if Present (C) then 14677 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 14678 end if; 14679 14680 -- If we are inserting at the top level, insert in Aux_Decls 14681 14682 if Nkind (Parent (Nod)) = N_Compilation_Unit then 14683 declare 14684 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 14685 14686 begin 14687 if No (Declarations (ADN)) then 14688 Set_Declarations (ADN, New_List (Chk)); 14689 else 14690 Append_To (Declarations (ADN), Chk); 14691 end if; 14692 14693 Analyze (Chk); 14694 end; 14695 14696 -- Otherwise just insert as an action on the node in question 14697 14698 else 14699 Insert_Action (Nod, Chk); 14700 end if; 14701 end Insert_Elab_Check; 14702 14703 ------------------------------- 14704 -- Is_Call_Of_Generic_Formal -- 14705 ------------------------------- 14706 14707 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 14708 begin 14709 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 14710 14711 -- Always return False if debug flag -gnatd.G is set 14712 14713 and then not Debug_Flag_Dot_GG 14714 14715 -- For now, we detect this by looking for the strange identifier 14716 -- node, whose Chars reflect the name of the generic formal, but 14717 -- the Chars of the Entity references the generic actual. 14718 14719 and then Nkind (Name (N)) = N_Identifier 14720 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 14721 end Is_Call_Of_Generic_Formal; 14722 14723 ------------------------------- 14724 -- Is_Finalization_Procedure -- 14725 ------------------------------- 14726 14727 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 14728 begin 14729 -- Check whether Id is a procedure with at least one parameter 14730 14731 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 14732 declare 14733 Typ : constant Entity_Id := Etype (First_Formal (Id)); 14734 Deep_Fin : Entity_Id := Empty; 14735 Fin : Entity_Id := Empty; 14736 14737 begin 14738 -- If the type of the first formal does not require finalization 14739 -- actions, then this is definitely not [Deep_]Finalize. 14740 14741 if not Needs_Finalization (Typ) then 14742 return False; 14743 end if; 14744 14745 -- At this point we have the following scenario: 14746 14747 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 14748 14749 -- Recover the two possible versions of [Deep_]Finalize using the 14750 -- type of the first parameter and compare with the input. 14751 14752 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 14753 14754 if Is_Controlled (Typ) then 14755 Fin := Find_Prim_Op (Typ, Name_Finalize); 14756 end if; 14757 14758 return (Present (Deep_Fin) and then Id = Deep_Fin) 14759 or else (Present (Fin) and then Id = Fin); 14760 end; 14761 end if; 14762 14763 return False; 14764 end Is_Finalization_Procedure; 14765 14766 ------------------ 14767 -- Output_Calls -- 14768 ------------------ 14769 14770 procedure Output_Calls 14771 (N : Node_Id; 14772 Check_Elab_Flag : Boolean) 14773 is 14774 function Emit (Flag : Boolean) return Boolean; 14775 -- Determine whether to emit an error message based on the combination 14776 -- of flags Check_Elab_Flag and Flag. 14777 14778 function Is_Printable_Error_Name return Boolean; 14779 -- An internal function, used to determine if a name, stored in the 14780 -- Name_Buffer, is either a non-internal name, or is an internal name 14781 -- that is printable by the error message circuits (i.e. it has a single 14782 -- upper case letter at the end). 14783 14784 ---------- 14785 -- Emit -- 14786 ---------- 14787 14788 function Emit (Flag : Boolean) return Boolean is 14789 begin 14790 if Check_Elab_Flag then 14791 return Flag; 14792 else 14793 return True; 14794 end if; 14795 end Emit; 14796 14797 ----------------------------- 14798 -- Is_Printable_Error_Name -- 14799 ----------------------------- 14800 14801 function Is_Printable_Error_Name return Boolean is 14802 begin 14803 if not Is_Internal_Name then 14804 return True; 14805 14806 elsif Name_Len = 1 then 14807 return False; 14808 14809 else 14810 Name_Len := Name_Len - 1; 14811 return not Is_Internal_Name; 14812 end if; 14813 end Is_Printable_Error_Name; 14814 14815 -- Local variables 14816 14817 Ent : Entity_Id; 14818 14819 -- Start of processing for Output_Calls 14820 14821 begin 14822 for J in reverse 1 .. Elab_Call.Last loop 14823 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 14824 14825 Ent := Elab_Call.Table (J).Ent; 14826 Get_Name_String (Chars (Ent)); 14827 14828 -- Dynamic elaboration model, warnings controlled by -gnatwl 14829 14830 if Dynamic_Elaboration_Checks then 14831 if Emit (Elab_Warnings) then 14832 if Is_Generic_Unit (Ent) then 14833 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 14834 elsif Is_Init_Proc (Ent) then 14835 Error_Msg_N ("\\?l?initialization procedure called #", N); 14836 elsif Is_Printable_Error_Name then 14837 Error_Msg_NE ("\\?l?& called #", N, Ent); 14838 else 14839 Error_Msg_N ("\\?l?called #", N); 14840 end if; 14841 end if; 14842 14843 -- Static elaboration model, info messages controlled by -gnatel 14844 14845 else 14846 if Emit (Elab_Info_Messages) then 14847 if Is_Generic_Unit (Ent) then 14848 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 14849 elsif Is_Init_Proc (Ent) then 14850 Error_Msg_N ("\\?$?initialization procedure called #", N); 14851 elsif Is_Printable_Error_Name then 14852 Error_Msg_NE ("\\?$?& called #", N, Ent); 14853 else 14854 Error_Msg_N ("\\?$?called #", N); 14855 end if; 14856 end if; 14857 end if; 14858 end loop; 14859 end Output_Calls; 14860 14861 ---------------------------- 14862 -- Same_Elaboration_Scope -- 14863 ---------------------------- 14864 14865 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 14866 S1 : Entity_Id; 14867 S2 : Entity_Id; 14868 14869 begin 14870 -- Find elaboration scope for Scop1 14871 -- This is either a subprogram or a compilation unit. 14872 14873 S1 := Scop1; 14874 while S1 /= Standard_Standard 14875 and then not Is_Compilation_Unit (S1) 14876 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) 14877 loop 14878 S1 := Scope (S1); 14879 end loop; 14880 14881 -- Find elaboration scope for Scop2 14882 14883 S2 := Scop2; 14884 while S2 /= Standard_Standard 14885 and then not Is_Compilation_Unit (S2) 14886 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) 14887 loop 14888 S2 := Scope (S2); 14889 end loop; 14890 14891 return S1 = S2; 14892 end Same_Elaboration_Scope; 14893 14894 ----------------- 14895 -- Set_C_Scope -- 14896 ----------------- 14897 14898 procedure Set_C_Scope is 14899 begin 14900 while not Is_Compilation_Unit (C_Scope) loop 14901 C_Scope := Scope (C_Scope); 14902 end loop; 14903 end Set_C_Scope; 14904 14905 -------------------------------- 14906 -- Set_Elaboration_Constraint -- 14907 -------------------------------- 14908 14909 procedure Set_Elaboration_Constraint 14910 (Call : Node_Id; 14911 Subp : Entity_Id; 14912 Scop : Entity_Id) 14913 is 14914 Elab_Unit : Entity_Id; 14915 14916 -- Check whether this is a call to an Initialize subprogram for a 14917 -- controlled type. Note that Call can also be a 'Access attribute 14918 -- reference, which now generates an elaboration check. 14919 14920 Init_Call : constant Boolean := 14921 Nkind (Call) = N_Procedure_Call_Statement 14922 and then Chars (Subp) = Name_Initialize 14923 and then Comes_From_Source (Subp) 14924 and then Present (Parameter_Associations (Call)) 14925 and then Is_Controlled (Etype (First_Actual (Call))); 14926 14927 begin 14928 -- If the unit is mentioned in a with_clause of the current unit, it is 14929 -- visible, and we can set the elaboration flag. 14930 14931 if Is_Immediately_Visible (Scop) 14932 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 14933 then 14934 Activate_Elaborate_All_Desirable (Call, Scop); 14935 Set_Suppress_Elaboration_Warnings (Scop); 14936 return; 14937 end if; 14938 14939 -- If this is not an initialization call or a call using object notation 14940 -- we know that the unit of the called entity is in the context, and we 14941 -- can set the flag as well. The unit need not be visible if the call 14942 -- occurs within an instantiation. 14943 14944 if Is_Init_Proc (Subp) 14945 or else Init_Call 14946 or else Nkind (Original_Node (Call)) = N_Selected_Component 14947 then 14948 null; -- detailed processing follows. 14949 14950 else 14951 Activate_Elaborate_All_Desirable (Call, Scop); 14952 Set_Suppress_Elaboration_Warnings (Scop); 14953 return; 14954 end if; 14955 14956 -- If the unit is not in the context, there must be an intermediate unit 14957 -- that is, on which we need to place to elaboration flag. This happens 14958 -- with init proc calls. 14959 14960 if Is_Init_Proc (Subp) or else Init_Call then 14961 14962 -- The initialization call is on an object whose type is not declared 14963 -- in the same scope as the subprogram. The type of the object must 14964 -- be a subtype of the type of operation. This object is the first 14965 -- actual in the call. 14966 14967 declare 14968 Typ : constant Entity_Id := 14969 Etype (First (Parameter_Associations (Call))); 14970 begin 14971 Elab_Unit := Scope (Typ); 14972 while (Present (Elab_Unit)) 14973 and then not Is_Compilation_Unit (Elab_Unit) 14974 loop 14975 Elab_Unit := Scope (Elab_Unit); 14976 end loop; 14977 end; 14978 14979 -- If original node uses selected component notation, the prefix is 14980 -- visible and determines the scope that must be elaborated. After 14981 -- rewriting, the prefix is the first actual in the call. 14982 14983 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 14984 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 14985 14986 -- Not one of special cases above 14987 14988 else 14989 -- Using previously computed scope. If the elaboration check is 14990 -- done after analysis, the scope is not visible any longer, but 14991 -- must still be in the context. 14992 14993 Elab_Unit := Scop; 14994 end if; 14995 14996 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 14997 Set_Suppress_Elaboration_Warnings (Elab_Unit); 14998 end Set_Elaboration_Constraint; 14999 15000 ----------------- 15001 -- Spec_Entity -- 15002 ----------------- 15003 15004 function Spec_Entity (E : Entity_Id) return Entity_Id is 15005 Decl : Node_Id; 15006 15007 begin 15008 -- Check for case of body entity 15009 -- Why is the check for E_Void needed??? 15010 15011 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then 15012 Decl := E; 15013 15014 loop 15015 Decl := Parent (Decl); 15016 exit when Nkind (Decl) in N_Proper_Body; 15017 end loop; 15018 15019 return Corresponding_Spec (Decl); 15020 15021 else 15022 return E; 15023 end if; 15024 end Spec_Entity; 15025 15026 ------------ 15027 -- Within -- 15028 ------------ 15029 15030 function Within (E1, E2 : Entity_Id) return Boolean is 15031 Scop : Entity_Id; 15032 begin 15033 Scop := E1; 15034 loop 15035 if Scop = E2 then 15036 return True; 15037 elsif Scop = Standard_Standard then 15038 return False; 15039 else 15040 Scop := Scope (Scop); 15041 end if; 15042 end loop; 15043 end Within; 15044 15045 -------------------------- 15046 -- Within_Elaborate_All -- 15047 -------------------------- 15048 15049 function Within_Elaborate_All 15050 (Unit : Unit_Number_Type; 15051 E : Entity_Id) return Boolean 15052 is 15053 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 15054 pragma Pack (Unit_Number_Set); 15055 15056 Seen : Unit_Number_Set := (others => False); 15057 -- Seen (X) is True after we have seen unit X in the walk. This is used 15058 -- to prevent processing the same unit more than once. 15059 15060 Result : Boolean := False; 15061 15062 procedure Helper (Unit : Unit_Number_Type); 15063 -- This helper procedure does all the work for Within_Elaborate_All. It 15064 -- walks the dependency graph, and sets Result to True if it finds an 15065 -- appropriate Elaborate_All. 15066 15067 ------------ 15068 -- Helper -- 15069 ------------ 15070 15071 procedure Helper (Unit : Unit_Number_Type) is 15072 CU : constant Node_Id := Cunit (Unit); 15073 15074 Item : Node_Id; 15075 Item2 : Node_Id; 15076 Elab_Id : Entity_Id; 15077 Par : Node_Id; 15078 15079 begin 15080 if Seen (Unit) then 15081 return; 15082 else 15083 Seen (Unit) := True; 15084 end if; 15085 15086 -- First, check for Elaborate_Alls on this unit 15087 15088 Item := First (Context_Items (CU)); 15089 while Present (Item) loop 15090 if Nkind (Item) = N_Pragma 15091 and then Pragma_Name (Item) = Name_Elaborate_All 15092 then 15093 -- Return if some previous error on the pragma itself. The 15094 -- pragma may be unanalyzed, because of a previous error, or 15095 -- if it is the context of a subunit, inherited by its parent. 15096 15097 if Error_Posted (Item) or else not Analyzed (Item) then 15098 return; 15099 end if; 15100 15101 Elab_Id := 15102 Entity 15103 (Expression (First (Pragma_Argument_Associations (Item)))); 15104 15105 if E = Elab_Id then 15106 Result := True; 15107 return; 15108 end if; 15109 15110 Par := Parent (Unit_Declaration_Node (Elab_Id)); 15111 15112 Item2 := First (Context_Items (Par)); 15113 while Present (Item2) loop 15114 if Nkind (Item2) = N_With_Clause 15115 and then Entity (Name (Item2)) = E 15116 and then not Limited_Present (Item2) 15117 then 15118 Result := True; 15119 return; 15120 end if; 15121 15122 Next (Item2); 15123 end loop; 15124 end if; 15125 15126 Next (Item); 15127 end loop; 15128 15129 -- Second, recurse on with's. We could do this as part of the above 15130 -- loop, but it's probably more efficient to have two loops, because 15131 -- the relevant Elaborate_All is likely to be on the initial unit. In 15132 -- other words, we're walking the with's breadth-first. This part is 15133 -- only necessary in the dynamic elaboration model. 15134 15135 if Dynamic_Elaboration_Checks then 15136 Item := First (Context_Items (CU)); 15137 while Present (Item) loop 15138 if Nkind (Item) = N_With_Clause 15139 and then not Limited_Present (Item) 15140 then 15141 -- Note: the following call to Get_Cunit_Unit_Number does a 15142 -- linear search, which could be slow, but it's OK because 15143 -- we're about to give a warning anyway. Also, there might 15144 -- be hundreds of units, but not millions. If it turns out 15145 -- to be a problem, we could store the Get_Cunit_Unit_Number 15146 -- in each N_Compilation_Unit node, but that would involve 15147 -- rearranging N_Compilation_Unit_Aux to make room. 15148 15149 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 15150 15151 if Result then 15152 return; 15153 end if; 15154 end if; 15155 15156 Next (Item); 15157 end loop; 15158 end if; 15159 end Helper; 15160 15161 -- Start of processing for Within_Elaborate_All 15162 15163 begin 15164 Helper (Unit); 15165 return Result; 15166 end Within_Elaborate_All; 15167 15168end Sem_Elab; 15169